├── .gitignore ├── LICENSE ├── README.md ├── demo.png ├── makefile ├── src ├── import.scm ├── json │ ├── json-decode.scm │ └── json-encode.scm ├── kernel.js ├── kernel.json ├── kernel │ ├── comm │ │ ├── comm.scm │ │ ├── version.scm │ │ └── widget │ │ │ ├── backbone.scm │ │ │ ├── custom.scm │ │ │ └── widget.scm │ ├── complete.scm │ ├── error.scm │ ├── execute.scm │ ├── info.scm │ ├── kernel.scm │ ├── session.scm │ ├── shutdown.scm │ ├── stdio.scm │ └── utils.scm ├── load.scm ├── logo-64x64.png ├── runtime │ ├── canvas │ │ ├── canvas.scm │ │ └── install.scm │ ├── runtime.scm │ ├── widget.scm │ └── widgets │ │ ├── button.scm │ │ ├── checkbox.scm │ │ ├── progress.scm │ │ ├── slider.scm │ │ └── text.scm ├── shared.scm ├── view.scm ├── zmq-constants.scm └── zmq.scm └── zmq.cdecl /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | zmq-const 3 | zmq-const.bin 4 | zmq-const.c 5 | zmq-const.o 6 | zmq-const.scm 7 | zmq-shim.c 8 | zmq-shim.o 9 | zmq-shim.so 10 | zmq-types.bin 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Joel Gustafson 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # mit-scheme-kernel 2 | 3 | Jupyter Kernel for MIT Scheme 4 | 5 | ![](demo.png) 6 | 7 | ## Installation 8 | 9 | ### Docker 10 | 11 | [Kevin Kwok](https://github.com/antimatter15) published a [docker image](https://hub.docker.com/r/kkwok/jupyter-mit-scheme/) that does all the things: 12 | 13 | ``` 14 | docker run -it --rm -p 8888:8888 kkwok/jupyter-mit-scheme 15 | ``` 16 | 17 | ### Source 18 | 19 | First get MIT Scheme: 20 | 21 | ``` 22 | $ wget https://ftp.gnu.org/gnu/mit-scheme/stable.pkg/10.1.5/mit-scheme-10.1.5-x86-64.tar.gz 23 | $ tar xvf mit-scheme-10.1.5-x86-64.tar.gz 24 | $ cd mit-scheme-10.1.5/src/ 25 | $ ./configure 26 | $ make compile-microcode 27 | $ sudo make install 28 | ``` 29 | 30 | Then get ZeroMQ: 31 | 32 | ``` 33 | $ wget https://github.com/zeromq/libzmq/releases/download/v4.3.1/zeromq-4.3.1.tar.gz 34 | $ tar xvf zeromq-4.3.1.tar.gz 35 | $ cd zeromq-4.3.1/ 36 | $ ./configure 37 | $ make 38 | $ sudo make install 39 | ``` 40 | 41 | And finally 42 | 43 | ``` 44 | $ git clone https://github.com/joeltg/mit-scheme-kernel 45 | $ cd mit-scheme-kernel 46 | $ make 47 | $ sudo make install 48 | $ jupyter console --kernel mit-scheme 49 | Jupyter console 6.0.0 50 | 51 | MIT Scheme Kernel 52 | 53 | 54 | In [1]: (fold-left cons '() (iota 4)) 55 | Out[1]: ((((() . 0) . 1) . 2) . 3) 56 | ``` 57 | 58 | Building on macOS may require installing `pkg-config` from brew and adding a `-undefined dynamic_lookup` flag to the makefile in the line that builds `zmq-shim.so`. 59 | -------------------------------------------------------------------------------- /demo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joeltg/mit-scheme-kernel/b8ed3443a075e46567570062d73d3eb775b8743f/demo.png -------------------------------------------------------------------------------- /makefile: -------------------------------------------------------------------------------- 1 | SCHEME=/usr/local/bin/mit-scheme 2 | AUXDIR=/usr/local/lib/mit-scheme-x86-64 3 | DESTDIR=/usr/local/share/jupyter/kernels/mit-scheme 4 | 5 | all: build 6 | 7 | install: install-zmq install-kernel 8 | 9 | install-zmq: 10 | install -m 644 zmq-types.bin $(AUXDIR) 11 | install -m 644 zmq-const.bin $(AUXDIR) 12 | install -m 644 zmq-const.scm $(AUXDIR) 13 | install -m 644 zmq-shim.so $(AUXDIR) 14 | 15 | install-kernel: 16 | rm -rf $(DESTDIR) 17 | cp -r src $(DESTDIR) 18 | 19 | clean: 20 | rm zmq-const* zmq-types* zmq-shim* 21 | 22 | build: zmq-shim.so zmq-types.bin zmq-const.bin 23 | 24 | zmq-shim.so: zmq-shim.o 25 | $(CC) -shared -fPIC -o $@ $^ `pkg-config --libs libzmq` 26 | 27 | zmq-shim.o: zmq-shim.c 28 | $(CC) -I$(AUXDIR) -Wall -fPIC `pkg-config --cflags libzmq` -o $@ -c $< 29 | 30 | zmq-shim.c zmq-const.c zmq-types.bin: zmq.cdecl 31 | echo '(generate-shim "zmq" "#include ")' | $(SCHEME) --batch-mode 32 | 33 | zmq-const.bin: zmq-const.scm 34 | echo '(sf "zmq-const")' | $(SCHEME) --batch-mode 35 | 36 | zmq-const.scm: zmq-const 37 | ./zmq-const 38 | 39 | zmq-const: zmq-const.o 40 | $(CC) $(CFLAGS) -o $@ $^ $(LDFLAGS) `pkg-config --libs libzmq` 41 | 42 | zmq-const.o: zmq-const.c 43 | $(CC) `pkg-config --cflags libzmq` $(CFLAGS) -o $@ -c $< 44 | -------------------------------------------------------------------------------- /src/import.scm: -------------------------------------------------------------------------------- 1 | (define (normalize-pathname pathname) 2 | (directory-pathname-as-file (pathname-simplify pathname))) 3 | 4 | (define (initialize-environments ht ie nie nee) 5 | (environment-define nie 'hash-table ht) 6 | (environment-define nie 'import-env nie) 7 | (environment-define nie 'export-env nee) 8 | (environment-define nie 'import-list (make-import-list nie ht)) 9 | (environment-define nie 'export-list (make-export-list nie nee)) 10 | (link-variables nie 'import-from ie 'import-from) 11 | (link-variables nie 'export-to ie 'export-to)) 12 | 13 | (define (copy-bindings symbols source-env target-env) 14 | (for-each 15 | (lambda (symbol) 16 | (link-variables target-env symbol source-env symbol)) 17 | symbols)) 18 | 19 | (define-syntax import-from 20 | (er-macro-transformer 21 | (lambda (exp rename compare) 22 | (let ((path (cadr exp)) 23 | (names (cddr exp))) 24 | `(import-list ,path (quote ,names)))))) 25 | 26 | (define-syntax export-to 27 | (er-macro-transformer 28 | (lambda (exp rename compare) 29 | (let ((names (cdr exp))) 30 | `(export-list (quote ,names)))))) 31 | 32 | (define ((make-export-list import-env export-env) symbols) 33 | (for-each 34 | (lambda (name) (link-variables export-env name import-env name)) 35 | symbols)) 36 | 37 | (define ((make-import-list import-env hash-table) path symbols) 38 | (let* ((working-directory (working-directory-pathname)) 39 | (merged-pathname (merge-pathnames path working-directory)) 40 | (target-pathname (normalize-pathname merged-pathname)) 41 | (key (->namestring target-pathname)) 42 | (export-env (hash-table/get hash-table key #f))) 43 | (if (and export-env (environment? export-env)) 44 | (copy-bindings symbols export-env import-env) 45 | (let ((target-directory (directory-pathname target-pathname)) 46 | (target-file (file-pathname target-pathname)) 47 | (next-import-env (make-top-level-environment)) 48 | (next-export-env (make-root-top-level-environment))) 49 | (initialize-environments hash-table import-env next-import-env next-export-env) 50 | (hash-table/put! hash-table key next-export-env) 51 | (set-working-directory-pathname! target-directory) 52 | (load target-pathname next-import-env) 53 | (set-working-directory-pathname! working-directory) 54 | (copy-bindings symbols next-export-env import-env))))) 55 | 56 | (define import-list 57 | (make-import-list 58 | (the-environment) 59 | (make-string-hash-table))) 60 | -------------------------------------------------------------------------------- /src/json/json-decode.scm: -------------------------------------------------------------------------------- 1 | (load-option '*parser) 2 | 3 | (define (json-vector-list v) 4 | (vector (vector->list v))) 5 | 6 | (define json-object-pair 7 | (*parser 8 | (transform 9 | (lambda (v) 10 | (vector (cons (string->symbol (vector-ref v 0)) (vector-ref v 1)))) 11 | (seq 12 | json-string 13 | (noise 14 | (seq 15 | (* (char-set char-set:whitespace)) 16 | ":" 17 | (* (char-set char-set:whitespace)))) 18 | json-value)))) 19 | 20 | (define json-object 21 | (*parser 22 | (transform 23 | (lambda (v) 24 | (vector (vector->list v))) 25 | (seq 26 | "{" 27 | (noise (* (char-set char-set:whitespace))) 28 | (? (seq (* 29 | (seq 30 | (noise (* (char-set char-set:whitespace))) 31 | json-object-pair 32 | (noise 33 | (seq 34 | (* (char-set char-set:whitespace)) 35 | "," 36 | (* (char-set char-set:whitespace)))))) 37 | json-object-pair 38 | (noise (* (char-set char-set:whitespace))))) 39 | "}")))) 40 | 41 | (define json-array 42 | (*parser 43 | (transform 44 | vector 45 | (seq 46 | "[" 47 | (? (seq (* (seq json-value ",")) json-value)) 48 | "]")))) 49 | 50 | (define json-value 51 | (*parser 52 | (seq 53 | (noise (* (char-set char-set:whitespace))) 54 | (alt 55 | json-string 56 | json-number 57 | json-object 58 | json-array 59 | (transform 60 | (lambda (v) 61 | (let ((const (vector-ref v 0))) 62 | (cond 63 | ((string=? "true" const) (vector #t)) 64 | ((string=? "false" const) (vector #f)) 65 | ((string=? "null" const) (vector #!unspecific))))) 66 | (match (alt "true" "false" "null")))) 67 | (noise (* (char-set char-set:whitespace)))))) 68 | 69 | (define char-set:hex 70 | (char-set-union 71 | char-set:numeric 72 | (string->char-set "abcdefABCDEF"))) 73 | 74 | (define char-set:unicode 75 | (char-set-invert 76 | (scalar-values->char-set '((#xD800 . #xDFFF) #xFFFE #xFFFF)))) 77 | 78 | (define char-set:json 79 | (char-set-difference 80 | char-set:unicode 81 | (string->char-set "\"\\"))) 82 | 83 | (define json-string-hex-digit 84 | (*parser 85 | (transform 86 | json-char-map 87 | (match (char-set char-set:hex))))) 88 | 89 | (define (json-digit-map v) 90 | (integer->char (string->number (list->string (vector->list digits)) 16) 0)) 91 | 92 | (define json-string-unicode 93 | (*parser 94 | (transform 95 | json-digit-map 96 | (seq 97 | "u" 98 | json-string-hex-digit 99 | json-string-hex-digit 100 | json-string-hex-digit 101 | json-string-hex-digit)))) 102 | 103 | (define (json-char-map v) 104 | (vector-map name->char v)) 105 | 106 | (define (json-escape char) 107 | (cond 108 | ((char=? #\b char) #\backspace) 109 | ((char=? #\n char) #\newline) 110 | ((char=? #\f char) #\page) 111 | ((char=? #\t char) #\tab) 112 | ((char=? #\r char) #\return) 113 | (else char))) 114 | 115 | (define (json-escape-map v) 116 | (vector-map json-escape (json-char-map v))) 117 | 118 | (define json-string-char 119 | (*parser 120 | (alt 121 | (seq 122 | "\\" 123 | (alt 124 | json-string-unicode 125 | (transform 126 | json-escape-map 127 | (match (char-set (string->char-set "bnftr/\"\\")))))) 128 | (transform 129 | json-char-map 130 | (match (char-set char-set:json)))))) 131 | 132 | (define json-string 133 | (*parser 134 | (transform 135 | (lambda (v) 136 | (vector (list->string (vector->list v)))) 137 | (seq "\"" (* json-string-char) "\"")))) 138 | 139 | (define json-number 140 | (*parser 141 | (transform 142 | (lambda (v) 143 | (vector (string->number (list->string (vector->list (json-char-map v)))))) 144 | (seq 145 | (? (match "-")) 146 | (alt 147 | "0" 148 | (seq 149 | (match (char-set (char-set-difference char-set:numeric (char-set #\0)))) 150 | (* (match (char-set char-set:numeric))))) 151 | (? 152 | (seq 153 | (match ".") 154 | (+ (match (char-set char-set:numeric))))) 155 | (? 156 | (seq 157 | (match (char-ci #\e)) 158 | (? (match (alt "+" "-"))) 159 | (+ (match (char-set char-set:numeric))))))))) 160 | 161 | (define (json-decode input) 162 | (json-value (string->parser-buffer input))) 163 | 164 | (export-to json-decode) -------------------------------------------------------------------------------- /src/json/json-encode.scm: -------------------------------------------------------------------------------- 1 | (define (json-atom l) 2 | (cons l (last-pair l))) 3 | 4 | (define (number->json number) 5 | (if (integer? number) 6 | (if (exact? number) 7 | (json-atom (string->list (number->string number))) 8 | (json-atom (string->list (string-append (number->string number) "0")))) 9 | (let ((r (abs number)) 10 | (s (< 0 number))) 11 | (let ((l (string->list (number->string (exact->inexact r))))) 12 | (let ((l (if (< r 1) (cons #\0 l) l))) 13 | (let ((l (if s l (cons #\- l)))) 14 | (cons l (last-pair l)))))))) 15 | 16 | (define (escape-char char str) 17 | (cond 18 | ((char=? char #\\) (cons #\\ (cons #\\ str))) 19 | ((char=? char #\") (cons #\\ (cons #\" str))) 20 | ((char=? char #\newline) (cons #\\ (cons #\n str))) 21 | ((char=? char #\escape) 22 | (cons #\\ (cons #\u (cons #\0 (cons #\0 (cons #\1 (cons #\b str))))))) 23 | (else (cons char str)))) 24 | 25 | (define (string->json s) 26 | (if (string-null? s) 27 | (json-atom (list #\" #\")) 28 | (let ((initial (list #\"))) 29 | (let ((l (fold-right escape-char initial (string->list s)))) 30 | (cons (cons #\" l) initial))))) 31 | 32 | (define (symbol->json symbol) 33 | (string->json (symbol->string symbol))) 34 | 35 | (define (boolean->json boolean) 36 | (json-atom (string->list (if boolean "true" "false")))) 37 | 38 | (define (null->json null) 39 | (json-atom (string->list "null"))) 40 | 41 | (define (json-splice e a) 42 | (set-cdr! (cdr e) a) 43 | (cons #\, (car e))) 44 | 45 | (define (vector->json v) 46 | (if (= (vector-length v) 0) 47 | (json-atom (list #\[ #\])) 48 | (let ((initial (list #\]))) 49 | (cons 50 | (cons 51 | #\[ 52 | (cdr (fold-right json-splice initial (map json (vector->list v))))) 53 | initial)))) 54 | 55 | (define (pair->json p) 56 | (let ((key (symbol->json (car p))) 57 | (value (json (cdr p))) 58 | (pivot (list #\:))) 59 | (set-cdr! pivot (car value)) 60 | (set-cdr! (cdr key) pivot) 61 | (cons (car key) (cdr value)))) 62 | 63 | (define (alist->json a) 64 | (if (null? a) 65 | (list #\{ #\}) 66 | (let ((initial (list #\}))) 67 | (cons 68 | (cons 69 | #\{ 70 | (cdr (fold-right json-splice initial (map pair->json a)))) 71 | initial)))) 72 | 73 | (define (json-error object) 74 | (error "invalid json object" object)) 75 | 76 | (define (json object) 77 | (cond 78 | ((null? object) (json-atom (string->list "{}"))) 79 | ((eq? #!unspecific object) (null->json object)) 80 | ((boolean? object) (boolean->json object)) 81 | ((symbol? object) (symbol->json object)) 82 | ((string? object) (string->json object)) 83 | ((number? object) (number->json object)) 84 | ((vector? object) (vector->json object)) 85 | ((alist? object) (alist->json object)) 86 | (else (json-error object)))) 87 | 88 | (define (json-encode object) 89 | (list->string (car (json object)))) 90 | 91 | (export-to json-encode) -------------------------------------------------------------------------------- /src/kernel.js: -------------------------------------------------------------------------------- 1 | // define("mywidget", ["@jupyter-widgets/base"], function(widgets) { 2 | // console.log("defining widgets or something") 3 | // const MyWidgetView = widgets.DOMWidgetView.extend({ 4 | // render() { 5 | // MyWidgetView.__super__.render.apply(this, arguments) 6 | // this._count_changed() 7 | // this.listenTo(this.model, "change:count", this._count_changed, this) 8 | // }, 9 | 10 | // _count_changed() { 11 | // var old_value = this.model.previous("count") 12 | // var new_value = this.model.get("count") 13 | // this.el.textContent = String(old_value) + " -> " + String(new_value) 14 | // }, 15 | // }) 16 | 17 | // return { 18 | // MyWidgetView, 19 | // onload() { 20 | // console.log("LOADED THIS THING THING") 21 | // }, 22 | // } 23 | // }) 24 | 25 | // module.exports = { 26 | // onload() { 27 | // console.log("MAYBE THIS WILL WORK", arguments) 28 | // }, 29 | // } 30 | 31 | // define(function(require, config, options) { 32 | // return { 33 | // onload: function() { 34 | // console.info( 35 | // "Kernel specific javascript loaded FJSDKLF JSDKF JKLSD FJKLSD JFLKS" 36 | // ) 37 | // }, 38 | // } 39 | // }) 40 | 41 | function handle_kernel(Jupyter, kernel) { 42 | if (kernel.comm_manager && kernel.widget_manager === undefined) { 43 | // Clear any old widget manager 44 | if (Jupyter.WidgetManager) { 45 | Jupyter.WidgetManager._managers[0].clear_state() 46 | } 47 | 48 | kernel.widget_manager = new Jupyter.WidgetManager( 49 | kernel.comm_manager, 50 | Jupyter.notebook 51 | ) 52 | } 53 | } 54 | 55 | define(["base/js/namespace", "base/js/events", "notebook/js/outputarea"], ( 56 | Jupyter, 57 | events, 58 | outputarea 59 | ) => ({ 60 | onload() { 61 | if (Jupyter.notebook && Jupyter.notebook.kernel) { 62 | handle_kernel(Jupyter, Jupyter.notebook.kernel) 63 | } else { 64 | const handle = "kernel_created.Kernel kernel_created.Session" 65 | events.on(handle, (event, data) => handle_kernel(Jupyter, data.kernel)) 66 | } 67 | const handle = 68 | "kernel_killed.Session kernel_killed.Kernel kernel_restarting.Kernel" 69 | events.on(handle, (event, data) => { 70 | const { kernel } = data 71 | if (kernel && kernel.widget_manager) { 72 | kernel.widget_manager.disconnect() 73 | } 74 | }) 75 | console.log("LOADED THE SHIT", stuff) 76 | }, 77 | })) 78 | -------------------------------------------------------------------------------- /src/kernel.json: -------------------------------------------------------------------------------- 1 | { 2 | "argv": [ 3 | "scheme", 4 | "--silent", 5 | "--load", 6 | "/usr/local/share/jupyter/kernels/mit-scheme/load.scm", 7 | "--", 8 | "{connection_file}" 9 | ], 10 | "display_name": "MIT Scheme", 11 | "language": "mit-scheme" 12 | } 13 | -------------------------------------------------------------------------------- /src/kernel/comm/comm.scm: -------------------------------------------------------------------------------- 1 | (import-from "../../shared" 2 | print 3 | session-comms 4 | comm-target 5 | comm-id) 6 | (import-from "../utils" asss) 7 | 8 | (define comm-targets '()) 9 | (define (add-comm-target! comm-target) 10 | (set! comm-targets (cons comm-target comm-targets))) 11 | (define make-comm-target list) 12 | (define comm-target-name first) 13 | (define comm-target-open second) 14 | (define comm-target-handler third) 15 | 16 | (define (get-comm-target target-name) 17 | (let ((target (asss target-name comm-targets))) 18 | (or target (error "invalid comm target" target-name)))) 19 | 20 | (define comm-ref (association-procedure string=? comm-id)) 21 | 22 | (define (comm-info-request session content reply pub . env) 23 | (pub "comm_info_reply" '((status . "ok") (comms)))) 24 | 25 | (define (comm-open session content reply pub . env) 26 | (let ((comm-id (cdr (assq 'comm_id content))) 27 | (data (cdr (assq 'data content))) 28 | (target-name (cdr (assq 'target_name content)))) 29 | (let ((comm-target (get-comm-target target-name))) 30 | ((comm-target-open comm-target) session pub comm-id data)))) 31 | 32 | (define (comm-msg session content reply pub . env) 33 | (pub "status" '((execution_state . "busy"))) 34 | (let ((id (cdr (assq 'comm_id content))) 35 | (data (cdr (assq 'data content)))) 36 | (let ((target-name (comm-target (comm-ref id (session-comms session))))) 37 | (let ((comm-target (get-comm-target target-name))) 38 | ((comm-target-handler comm-target) session pub id data)))) 39 | (pub "status" '((execution_state . "idle")))) 40 | 41 | (export-to 42 | make-comm-target 43 | comm-info-request 44 | comm-open comm-msg 45 | add-comm-target!) -------------------------------------------------------------------------------- /src/kernel/comm/version.scm: -------------------------------------------------------------------------------- 1 | (import-from "comm" make-comm-target add-comm-target!) 2 | (import-from "../../shared" print make-comm send-comm-msg) 3 | 4 | (define comm-version "~2.1.4") 5 | (define comm-version-name "jupyter.widget.version") 6 | (define (comm-version-handler session pub id data) 7 | (if (cdr (assq 'validated data)) 8 | (print "widget comms validated") 9 | (warn "invalid jupter widget version"))) 10 | 11 | (define (comm-version-open session pub id data) 12 | (let ((comm (make-comm session comm-version-name id))) 13 | (send-comm-msg comm `((version . ,comm-version))))) 14 | 15 | (define comm-version-target 16 | (make-comm-target comm-version-name comm-version-open comm-version-handler)) 17 | (add-comm-target! comm-version-target) 18 | -------------------------------------------------------------------------------- /src/kernel/comm/widget/backbone.scm: -------------------------------------------------------------------------------- 1 | (import-from "../../../shared" print merge-states widget-handlers widget-state set-widget-state!) 2 | (import-from "widget" make-widget-method add-widget-method!) 3 | (define backbone-name "backbone") 4 | 5 | (define (backbone-handler session widget data) 6 | (let ((state (cdr (assq 'sync_data data)))) 7 | (set-widget-state! 8 | widget 9 | (merge-states (widget-state widget) state)) 10 | (for-each 11 | (lambda (handler) 12 | ((cdr handler) state)) 13 | (widget-handlers widget)))) 14 | 15 | (define backbone-method (make-widget-method backbone-name backbone-handler)) 16 | (add-widget-method! backbone-method) -------------------------------------------------------------------------------- /src/kernel/comm/widget/custom.scm: -------------------------------------------------------------------------------- 1 | (import-from "../../../shared" print) 2 | (import-from "widget" make-widget-method add-widget-method!) 3 | (define custom-name "custom") 4 | 5 | (define (custom-handler session widget data) 6 | (print "custom handler" data)) 7 | 8 | (define widget-method-custom (make-widget-method custom-name custom-handler)) 9 | (add-widget-method! widget-method-custom) 10 | -------------------------------------------------------------------------------- /src/kernel/comm/widget/widget.scm: -------------------------------------------------------------------------------- 1 | (import-from "../../../shared" print make-comm widget-ref session-widgets) 2 | (import-from "../../utils" asss) 3 | (import-from "../comm" make-comm-target add-comm-target!) 4 | 5 | (define comm-widget-name "jupyter.widget") 6 | 7 | (define widget-methods '()) 8 | (define make-widget-method cons) 9 | (define widget-method-name car) 10 | (define widget-method-handler cdr) 11 | (define (add-widget-method! widget-method) 12 | (set! widget-methods (cons widget-method widget-methods))) 13 | 14 | (define (comm-widget-open session pub id data) 15 | (let ((comm (make-comm session comm-widget-name id)) 16 | (widget-class (cdr (assq 'widget_class data)))) 17 | (print "opened new widget of class" widget-class))) 18 | 19 | (define (comm-widget-handler session pub id data) 20 | (let ((widget (widget-ref id (session-widgets session))) 21 | (method-name (cdr (assq 'method data)))) 22 | (let ((widget-method (asss method-name widget-methods))) 23 | (if widget-method 24 | ((widget-method-handler widget-method) session widget data) 25 | (error "invalid widget method"))))) 26 | 27 | (define comm-target-widget 28 | (make-comm-target comm-widget-name comm-widget-open comm-widget-handler)) 29 | (add-comm-target! comm-target-widget) 30 | 31 | (export-to make-widget-method widget-method-name widget-method-handler add-widget-method!) -------------------------------------------------------------------------------- /src/kernel/complete.scm: -------------------------------------------------------------------------------- 1 | (define ((complete-hook s) condition) 2 | (invoke-restart 3 | (find-restart 'jupyter-complete) 4 | (let ((name (condition-type/name (condition/type condition)))) 5 | (cond ((string=? name "premature-eof") 6 | `((status . "incomplete") 7 | (indent . ,(make-string 8 | (* 2 (abs (- (length (string-search-all "(" s)) 9 | (length (string-search-all ")" s))))) 10 | #\space)))) 11 | ((string=? name "illegal-char") 12 | '((status . "invalid"))) 13 | (else '((status . "invalid"))))))) 14 | 15 | (define ((complete-effector kappa) status) 16 | (kappa status)) 17 | 18 | (define (is-complete-request session content reply pub . env) 19 | (pub "status" '((execution_state . "busy"))) 20 | (is-complete-reply content reply) 21 | (pub "status" '((execution_state . "idle")))) 22 | 23 | (define (completion content) 24 | (call-with-current-continuation 25 | (lambda (kappa) 26 | (with-restart 27 | 'jupyter-complete "check code completion" 28 | (complete-effector kappa) #f 29 | (lambda () 30 | (let ((s (cdr (assq 'code content)))) 31 | (fluid-let ((standard-error-hook (complete-hook s))) 32 | (let ((code (open-input-string s))) 33 | (let iter ((exp (read code))) 34 | (if (eof-object? exp) 35 | `((status . "complete")) 36 | (iter (read code)))))))))))) 37 | 38 | (define (is-complete-reply content reply) 39 | (reply "is_complete_reply" (completion content))) 40 | 41 | (export-to is-complete-request) -------------------------------------------------------------------------------- /src/kernel/error.scm: -------------------------------------------------------------------------------- 1 | (import-from "../shared" session-pub session-count) 2 | (import-from "utils" colorize) 3 | 4 | (define (error-hook condition) 5 | (invoke-restart (find-restart 'jupyter-error) 6 | (condition-type/name (condition/type condition)) 7 | (condition/report-string condition))) 8 | 9 | (define ((effector kappa session) name report) 10 | (error-result session name report) 11 | (kappa "error")) 12 | 13 | (define (error-result session name report ) 14 | (let ((content `((ename . ,name) 15 | (evalue . ,report) 16 | (traceback . #(,(colorize report))) 17 | (execution_count . ,(session-count session)) 18 | (user_expressions)))) 19 | ((session-pub session) "error" content))) 20 | 21 | (define has-fluid (environment-bound? (the-environment) 'let-fluid)) 22 | 23 | (define (with-error session thunk) 24 | (call-with-current-continuation 25 | (lambda (kappa) 26 | (with-restart 27 | 'jupyter-error "report error to jupyter client" 28 | (effector kappa session) 29 | #f 30 | (lambda () 31 | (fluid-let ((standard-error-hook error-hook)) 32 | (thunk) 33 | "ok")))))) 34 | 35 | (export-to with-error) 36 | -------------------------------------------------------------------------------- /src/kernel/execute.scm: -------------------------------------------------------------------------------- 1 | (import-from "../shared" session-env session-count) 2 | (import-from "error" with-error) 3 | (import-from "stdio" with-stdio) 4 | (import-from "session" prepare-session! session-count!) 5 | 6 | (define (get-expressions content) 7 | (let ((code (open-input-string (cdr (assq 'code content))))) 8 | (let iter ((expression (read code)) (expressions '())) 9 | (if (eof-object? expression) 10 | expressions 11 | (iter (read code) (cons expression expressions)))))) 12 | 13 | (define (evaluate session content pub) 14 | (fold-right 15 | (lambda (exp pre) 16 | (let ((env (session-env session))) 17 | (eval exp env))) 18 | #!unspecific 19 | (get-expressions content))) 20 | 21 | (define (with-session session thunk) 22 | (with-error session 23 | (lambda () 24 | (with-stdio session thunk)))) 25 | 26 | (define (execute-request session content reply pub . env) 27 | (pub "status" '((execution_state . "busy"))) 28 | (session-count! session) 29 | (prepare-session! session pub) 30 | (pub "execute_input" 31 | `(,(assq 'code content) 32 | (execution_count . ,(session-count session)))) 33 | (execute-reply 34 | session reply 35 | (with-session session 36 | (lambda () 37 | (execute-result session content pub)))) 38 | (pub "status" '((execution_state . "idle")))) 39 | 40 | (define (execute-result session content pub) 41 | (let ((value (evaluate session content pub))) 42 | (if (not (eq? value #!unspecific)) 43 | (pub 44 | "execute_result" 45 | `((data . ((text/plain . ,(write-to-string value)))) 46 | (metadata) 47 | (execution_count . ,(session-count session))))))) 48 | 49 | (define (execute-reply session reply status) 50 | (reply "execute_reply" 51 | `((status . ,status) 52 | (execution_count . ,(session-count session)) 53 | (user_expressions)))) 54 | 55 | (export-to execute-request with-session) -------------------------------------------------------------------------------- /src/kernel/info.scm: -------------------------------------------------------------------------------- 1 | (define kernel-info 2 | '((protocol_version . "5.1.0") 3 | (implementation . "mit-scheme-kernel") 4 | (implementation_version . "0.0.2") 5 | (language_info . ((name . "MIT Scheme") 6 | (version . "9.2.1") 7 | (mimetype . "application/x-scheme") 8 | (file_extension . ".scm") 9 | (pygments_lexer . "scheme") 10 | (codemirror_mode . "scheme"))) 11 | (banner . "MIT Scheme Kernel") 12 | (help_links . #(((text . "GitHub") 13 | (url . "https://github.com/joeltg/mit-scheme-kernel")))))) 14 | 15 | 16 | (define (kernel-info-request session content reply pub . env) 17 | (pub "status" '((execution_state . "busy"))) 18 | (kernel-info-reply reply) 19 | (pub "status" '((execution_state . "idle")))) 20 | 21 | (define (kernel-info-reply reply) 22 | (reply "kernel_info_reply" kernel-info)) 23 | 24 | (export-to kernel-info-request) -------------------------------------------------------------------------------- /src/kernel/kernel.scm: -------------------------------------------------------------------------------- 1 | (import-from "../json/json-decode" json-decode) 2 | 3 | (import-from "../zmq" 4 | make-zmq-context 5 | make-zmq-socket 6 | zmq-socket/bind! 7 | 8 | ; make-zmq-poller 9 | ; zmq-poller/destroy! 10 | ; zmq-poller/add! 11 | ; zmq-poller/remove! 12 | ; zmq-poller/wait 13 | 14 | zmq-poll 15 | zmq-pollitem/revents 16 | make-zmq-pollitems 17 | zmq-poll/event? 18 | receive-message 19 | receive-messages 20 | zmq-message/echo!) 21 | 22 | (import-from "../shared" set-session-pub!) 23 | (import-from "utils" delimiter send asss vector-ref-0) 24 | (import-from "info" kernel-info-request) 25 | (import-from "shutdown" shutdown-request) 26 | (import-from "session" session-ref make-session) 27 | (import-from "complete" is-complete-request) 28 | (import-from "execute" execute-request) 29 | (import-from "comm/comm" comm-info-request comm-open comm-msg) 30 | (import-from "comm/version") 31 | (import-from "comm/widget/widget") 32 | (import-from "comm/widget/backbone") 33 | (import-from "comm/widget/custom") 34 | 35 | (define get-header car) 36 | (define get-parent cadr) 37 | (define get-metadata caddr) 38 | (define get-content cadddr) 39 | 40 | (define ((handle env) pollitem handler socket) 41 | (if (zmq-poll/event? 'pollin (zmq-pollitem/revents pollitem)) 42 | (handler socket env))) 43 | 44 | (define (inspect-request session content reply pub . env) #!unspecific) 45 | (define (complete-request session content reply pub . env) #!unspecific) 46 | (define (history-request session content reply pub . env) #!unspecific) 47 | (define (input-reply session content reply pub . env) #!unspecific) 48 | 49 | (define routes 50 | `(("execute_request" . ,execute-request) 51 | ("inspect_request" . ,inspect-request) 52 | ("complete_request" . ,complete-request) 53 | ("history_request" . ,history-request) 54 | ("is_complete_request" . ,is-complete-request) 55 | ("comm_info_request" . ,comm-info-request) 56 | ("comm_open" . ,comm-open) 57 | ("comm_msg" . ,comm-msg) 58 | ("kernel_info_request" . ,kernel-info-request) 59 | ("shutdown_request" . ,shutdown-request) 60 | ("input_reply" . ,input-reply))) 61 | 62 | (define (router msg-type) 63 | (let ((route (asss msg-type routes))) 64 | (if route 65 | (cdr route) 66 | (error "invalid message type")))) 67 | 68 | (define ((make-reply socket identity parent signature-scheme key) msg-type content) 69 | (send socket identity parent msg-type signature-scheme key content)) 70 | 71 | (define ((make-pub iopub-socket identity parent signature-scheme key) msg-type content) 72 | (send iopub-socket identity parent msg-type signature-scheme key content)) 73 | 74 | (define ((make-handler iopub-socket get-session signature-scheme key) socket env) 75 | (let ((blobs (reverse (receive-messages socket)))) 76 | (let ((identities (take-while (lambda (x) (not (bytevector=? x delimiter))) blobs)) 77 | (rest (drop-while (lambda (x) (not (bytevector=? x delimiter))) blobs))) 78 | (let ((deli (car rest)) 79 | (hmac (cadr rest)) 80 | (json (map vector-ref-0 (map json-decode (map utf8->string (cddr rest)))))) 81 | (assert (bytevector=? deli delimiter)) 82 | (let ((identity (car identities)) ; Use the first identity as the key 83 | (header (get-header json)) 84 | (content (get-content json))) 85 | (let ((session (get-session identity header)) 86 | (reply (make-reply socket identity header signature-scheme key)) 87 | (pub (make-pub iopub-socket identity header signature-scheme key)) 88 | (route (router (cdr (assq 'msg_type header))))) 89 | (set-session-pub! session pub) 90 | (apply route session content reply pub env)))) 91 | ) 92 | )) 93 | 94 | (define (listen 95 | transport 96 | ip 97 | signature-scheme 98 | key 99 | control-port 100 | shell-port 101 | stdin-port 102 | hb-port 103 | iopub-port) 104 | 105 | (define (make-endpoint port) 106 | (string-append transport "://" ip ":" (number->string port))) 107 | 108 | (define control-endpoint (make-endpoint control-port)) 109 | (define shell-endpoint (make-endpoint shell-port)) 110 | (define stdin-endpoint (make-endpoint stdin-port)) 111 | (define hb-endpoint (make-endpoint hb-port)) 112 | (define iopub-endpoint (make-endpoint iopub-port)) 113 | 114 | (define endpoints 115 | (list hb-endpoint shell-endpoint control-endpoint stdin-endpoint)) 116 | 117 | (define context (make-zmq-context)) 118 | 119 | (define hb-socket (make-zmq-socket context 'rep)) 120 | (define shell-socket (make-zmq-socket context 'router)) 121 | (define control-socket (make-zmq-socket context 'router)) 122 | (define iopub-socket (make-zmq-socket context 'pub)) 123 | (define stdin-socket (make-zmq-socket context 'router)) 124 | 125 | (define sockets (list hb-socket shell-socket control-socket stdin-socket)) 126 | (define pollitems (make-zmq-pollitems 4 sockets)) 127 | 128 | ; (define poller-width (length sockets)) 129 | ; (define poller (make-zmq-poller)) 130 | ; (for-each 131 | ; (lambda (socket) 132 | ; (zmq-poller/add! poller socket 'pollin)) 133 | ; sockets) 134 | 135 | (zmq-socket/bind! iopub-socket iopub-endpoint) 136 | (for-each zmq-socket/bind! sockets endpoints) 137 | 138 | (define env 139 | (list context endpoints sockets iopub-endpoint iopub-socket)) 140 | 141 | (define sessions '()) 142 | 143 | (define (get-session identity header) 144 | (let ((session (cdr (assq 'session header)))) 145 | (or (session-ref session sessions) 146 | (let ((s (make-session identity session))) 147 | (set! sessions (cons s sessions)) 148 | s)))) 149 | 150 | (define shell-handler (make-handler iopub-socket get-session signature-scheme key)) 151 | (define control-handler shell-handler) 152 | (define stdin-handler shell-handler) 153 | 154 | (define (hb-handler socket env) 155 | (zmq-message/echo! socket socket)) 156 | 157 | (define handlers 158 | (list hb-handler shell-handler control-handler stdin-handler)) 159 | 160 | ; (define poller-events (malloc (* (c-sizeof "")))) 161 | (let poll () 162 | (zmq-poll (car pollitems) (length pollitems) -1) 163 | (for-each (handle env) 164 | pollitems 165 | handlers 166 | sockets) 167 | (poll))) 168 | 169 | (export-to listen) -------------------------------------------------------------------------------- /src/kernel/session.scm: -------------------------------------------------------------------------------- 1 | ;; a session has an id (from client), an execution counter, 2 | ;; and an environment 3 | (import-from "../shared" 4 | initialize-session 5 | session-id 6 | session-env 7 | session-count 8 | session-stdio 9 | set-session-pub! 10 | set-session-count! 11 | set-session-stdio!) 12 | 13 | (import-from "stdio" make-stdio) 14 | 15 | (define source-directory 16 | (pathname-simplify 17 | (merge-pathnames 18 | "../" 19 | (working-directory-pathname)))) 20 | 21 | (define runtime 22 | (pathname-simplify 23 | (merge-pathnames 24 | "runtime/runtime.scm" 25 | source-directory))) 26 | 27 | (define (prepare-session! session pub) 28 | (set-session-pub! session pub) 29 | (let ((env (session-env session))) 30 | (environment-define env 'session session))) 31 | 32 | (define session-ref (association-procedure string=? session-id)) 33 | 34 | (define (initialize-env! session) 35 | (let ((env (session-env session))) 36 | (environment-define env '*source-directory* source-directory) 37 | (environment-define env '*session* session) 38 | (load runtime env))) 39 | 40 | (define (make-session identity id) 41 | (let ((session (initialize-session identity id))) 42 | (set-session-stdio! session (make-stdio #f)) 43 | (set-textual-port-state! (session-stdio session) session) 44 | (initialize-env! session) 45 | session)) 46 | 47 | (define (session-count! session) 48 | (set-session-count! session (+ 1 (session-count session)))) 49 | 50 | (export-to 51 | prepare-session! 52 | session-ref 53 | make-session 54 | session-count!) -------------------------------------------------------------------------------- /src/kernel/shutdown.scm: -------------------------------------------------------------------------------- 1 | (import-from "../zmq" 2 | zmq-socket/unbind! 3 | zmq-socket/close! 4 | zmq-context/terminate!) 5 | 6 | (define (shutdown-reply reply content) 7 | (reply "shutdown_reply" content)) 8 | 9 | (define (shutdown-request 10 | session content reply pub 11 | context endpoints sockets iopub-endpoint iopub-socket) 12 | (write-string "Exiting mit-scheme\n" (console-i/o-port)) 13 | (shutdown-reply reply content) 14 | (for-each zmq-socket/unbind! sockets endpoints) 15 | (for-each zmq-socket/close! sockets) 16 | (zmq-socket/unbind! iopub-socket iopub-endpoint) 17 | (zmq-socket/close! iopub-socket) 18 | (zmq-context/terminate! context) 19 | (%exit)) 20 | 21 | (export-to shutdown-request) -------------------------------------------------------------------------------- /src/kernel/stdio.scm: -------------------------------------------------------------------------------- 1 | (import-from "../shared" session-stdio session-pub) 2 | 3 | (define (with-stdio session thunk) 4 | (let ((port (session-stdio session))) 5 | (with-output-to-port port thunk))) 6 | 7 | (define (stdio-write-char port char) 8 | ((session-pub (port/state port)) 9 | "stream" 10 | `((name . "stdout") 11 | (text . ,(char->string char)))) 12 | 0) 13 | 14 | (define (stdio-write-substring port string start end) 15 | ((session-pub (port/state port)) 16 | "stream" 17 | `((name . "stdout") 18 | (text . ,(substring string start end)))) 19 | 0) 20 | 21 | (define stdio-port-type 22 | (make-textual-port-type 23 | `((write-substring ,stdio-write-substring) 24 | (write-char ,stdio-write-char)) 25 | #f)) 26 | 27 | (define (make-stdio session) 28 | (make-textual-port stdio-port-type session)) 29 | 30 | (export-to with-stdio make-stdio) -------------------------------------------------------------------------------- /src/kernel/utils.scm: -------------------------------------------------------------------------------- 1 | (import-from "../json/json-encode" json-encode) 2 | (import-from "../zmq" zmq-socket/send) 3 | (import-from "../shared" make-id) 4 | 5 | (load-option 'synchronous-subprocess) 6 | 7 | (define version "5.1.0") 8 | 9 | ; (define delimiter "") 10 | (define delimiter #u8(60 73 68 83 124 77 83 71 62)) 11 | 12 | (define asss (association-procedure string=? car)) 13 | 14 | (define (vector-ref-0 vector) 15 | (if (and vector (vector? vector) (= 1 (vector-length vector))) 16 | (vector-ref vector 0) 17 | (error "could not parse json"))) 18 | 19 | (define (pad n l) 20 | (let ((s (number->string n))) 21 | (string-append 22 | (make-string (- l (string-length s)) #\0) s))) 23 | 24 | (define (colorize string) 25 | (string-append "\033[31m" string "\033[0m")) 26 | 27 | (define (make-date) 28 | (let ((time (global-decoded-time))) 29 | (string-append 30 | (pad (decoded-time/year time) 4) "-" 31 | (pad (decoded-time/month time) 2) "-" 32 | (pad (decoded-time/day time) 2) "T" 33 | (pad (decoded-time/hour time) 2) ":" 34 | (pad (decoded-time/minute time) 2) ":" 35 | (pad (decoded-time/second time) 2) "Z"))) 36 | 37 | (define (make-header parent msg-type) 38 | (let ((username (cdr (assq 'username parent))) 39 | (session (cdr (assq 'session parent)))) 40 | `((msg_id . ,(make-id)) 41 | (username . ,username) 42 | (session . ,session) 43 | (date . ,(make-date)) 44 | (msg_type . ,msg-type) 45 | (version . ,version)))) 46 | 47 | (define (make-hmac scheme key blobs) 48 | (cond 49 | ((string=? scheme "hmac-sha256") 50 | (let ((concat (apply string-append blobs)) 51 | (sha256 (string-append "openssl dgst -sha256 -hmac " key)) 52 | (stdout (open-output-string))) 53 | (run-shell-command sha256 54 | 'input (open-input-string concat) 55 | 'output stdout) 56 | (let ((hmac (get-output-string stdout))) 57 | (substring hmac 58 | (- (string-length hmac) 64 1) 59 | (- (string-length hmac) 1))))) 60 | (else (warn "signature scheme not recognized") ""))) 61 | 62 | (define (send socket identity parent msg-type signature-scheme key content) 63 | (let ((header (make-header parent msg-type))) 64 | (let ((json (list header parent '() content))) 65 | (let ((blobs (map json-encode json))) 66 | (let ((hmac (make-hmac signature-scheme key blobs))) 67 | (apply zmq-socket/send socket identity delimiter hmac blobs)))))) 68 | 69 | (export-to delimiter send colorize asss vector-ref-0) -------------------------------------------------------------------------------- /src/load.scm: -------------------------------------------------------------------------------- 1 | (define working-directory (working-directory-pathname)) 2 | (cd "/usr/local/share/jupyter/kernels/mit-scheme") 3 | 4 | (load "import") 5 | 6 | (import-from "json/json-decode" json-decode) 7 | (import-from "kernel/kernel" listen) 8 | 9 | (cd working-directory) 10 | 11 | (define args (command-line)) 12 | (assert (> (length args) 0)) 13 | 14 | 15 | (define file (open-input-file (last args))) 16 | (define text (read-string (char-set) file)) 17 | (define json (json-decode text)) 18 | (assert 19 | (and (vector? json) 20 | (= 1 (vector-length json)))) 21 | 22 | (define (ref key) 23 | (cdr (assq key (vector-ref json 0)))) 24 | 25 | (listen (ref 'transport) 26 | (ref 'ip) 27 | (ref 'signature_scheme) 28 | (ref 'key) 29 | (ref 'control_port) 30 | (ref 'shell_port) 31 | (ref 'stdin_port) 32 | (ref 'hb_port) 33 | (ref 'iopub_port)) 34 | -------------------------------------------------------------------------------- /src/logo-64x64.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joeltg/mit-scheme-kernel/b8ed3443a075e46567570062d73d3eb775b8743f/src/logo-64x64.png -------------------------------------------------------------------------------- /src/runtime/canvas/canvas.scm: -------------------------------------------------------------------------------- 1 | (define *canvas-size* 300) 2 | (define *frame-height* 400) 3 | (define *frame-width* 400) 4 | (define *foreground-color* "white") 5 | (define *background-color* "black") 6 | (define *can-use-colors* #t) 7 | (define *frame-x-position* (if (eq? 'unix microcode-id/operating-system) -10 532)) 8 | (define *frame-y-position* 0) 9 | (define *frame-width* (if (eq? 'unix microcode-id/operating-system) 400 100)) 10 | (define *frame-height* (if (eq? 'unix microcode-id/operating-system) 400 100)) 11 | 12 | (define (get-pointer-coordinates-default-continuation x y button) *silence*) 13 | (define get-pointer-coordinates-continuation get-pointer-coordinates-default-continuation) 14 | 15 | (define-structure 16 | (canvas (constructor make-canvas (#!optional xmin xmax ymin ymax))) 17 | (id 0) 18 | (xmin 0) 19 | (xmax *canvas-size*) 20 | (ymin 0) 21 | (ymax *canvas-size*) 22 | (frame-width *canvas-size*) 23 | (frame-height *canvas-size*) 24 | (frame-x-position 0) 25 | (frame-y-position 0)) 26 | 27 | (define (send-canvas canvas action #!optional value) 28 | (*send* 2 (symbol->json action) (number->string (canvas-id canvas)) (json value))) 29 | 30 | (define (canvas-available? . args) #t) 31 | 32 | (define (canvas-coordinate-limits canvas) 33 | (list (canvas-xmin canvas) (canvas-ymax canvas) 34 | (canvas-xmax canvas) (canvas-ymin canvas))) 35 | 36 | (define (canvas-device-coordinate-limits canvas) 37 | (list 0 0 (canvas-frame-width canvas) (canvas-frame-height canvas))) 38 | 39 | (define (canvas-set-coordinate-limits canvas x-left y-bottom x-right y-top) 40 | (set-canvas-xmin! canvas x-left) 41 | (set-canvas-ymin! canvas y-bottom) 42 | (set-canvas-xmax! canvas x-right) 43 | (set-canvas-ymax! canvas y-top) 44 | (send-canvas canvas 'set_coordinate_limits (list x-left y-bottom x-right y-top))) 45 | 46 | (define (canvas-drag-cursor canvas x y) 47 | (send-canvas canvas 'drag_cursor (list x y))) 48 | 49 | (define (canvas-move-cursor canvas x y) 50 | (send-canvas canvas 'move_cursor (list x y))) 51 | 52 | (define (canvas-reset-clip-rectangle canvas) 53 | (send-canvas canvas 'reset_clip_rectangle (canvas-coordinate-limits canvas))) 54 | 55 | (define (canvas-set-clip-rectangle canvas x-left y-bottom x-right y-top) 56 | (send-canvas canvas 'set_clip_rectangle (list x-left y-bottom x-right y-top))) 57 | 58 | (define (canvas-set-drawing-mode canvas mode) 59 | (send-canvas canvas 'set_drawing_mode `((mode ,mode)))) 60 | 61 | (define (canvas-set-line-style canvas style) 62 | (send-canvas canvas 'set_line_style `((style ,style)))) 63 | 64 | (define (canvas-clear canvas) 65 | (send-canvas canvas 'clear)) 66 | 67 | (define (canvas-flush canvas) 68 | ; *silence*) 69 | #!unspecific) 70 | 71 | (define (canvas-close canvas) 72 | (send-canvas canvas 'close)) 73 | 74 | (define (canvas-draw-rect canvas x y width height) 75 | (send-canvas canvas 'draw_rect (list x y width height))) 76 | 77 | (define (canvas-erase-rect canvas x y width height) 78 | (send-canvas canvas 'erase_rect (list x y width height))) 79 | 80 | (define (canvas-draw-rects canvas rects) 81 | (send-canvas canvas 'draw_rects rects)) 82 | 83 | (define (canvas-erase-rects canvas rects) 84 | (send-canvas canvas 'erase_rects rects)) 85 | 86 | (define (canvas-draw-point canvas x y) 87 | (send-canvas canvas 'draw_point (list x y))) 88 | 89 | (define (canvas-draw-points canvas points) 90 | (send-canvas canvas 'draw_points points)) 91 | 92 | (define (canvas-erase-point canvas x y) 93 | (send-canvas canvas 'erase_point (list x y))) 94 | 95 | (define (canvas-erase-points canvas points) 96 | (send-canvas canvas 'erase_points points)) 97 | 98 | (define (canvas-draw-line canvas x-start y-start x-end y-end) 99 | (send-canvas canvas 'draw_line (list x-start y-start x-end y-end))) 100 | 101 | (define (canvas-draw-text canvas x y string) 102 | (send-canvas canvas 'draw_text (list x y string))) 103 | 104 | (define (canvas-set-font canvas font-name) 105 | (send-canvas canvas 'set_font font-name)) 106 | 107 | (define (canvas-set-background-color canvas color) 108 | (send-canvas canvas 'set_background_color color)) 109 | 110 | (define (canvas-set-foreground-color canvas color) 111 | (send-canvas canvas 'set_foreground_color color)) 112 | 113 | (define (canvas-get-pointer-coordinates canvas cont) 114 | (set! get-pointer-coordinates-continuation 115 | (lambda (x y button) 116 | (set! get-pointer-coordinates-continuation get-pointer-coordinates-default-continuation) 117 | (cont x y button))) 118 | (send-canvas canvas 'get_pointer_coordinates)) -------------------------------------------------------------------------------- /src/runtime/canvas/install.scm: -------------------------------------------------------------------------------- 1 | (define (canvas-open generator . args) 2 | (let ((canvas (apply make-canvas args))) 3 | (let ((device (generator canvas))) 4 | (set-canvas-id! canvas (hash device)) 5 | (send-canvas canvas 'open (canvas-coordinate-limits canvas)) 6 | device))) 7 | 8 | (define (*safe-graphics-close* graphics-device) 9 | (ignore-errors 10 | (lambda () 11 | (graphics-close graphics-device))) 12 | *silence*) 13 | 14 | (define descriptor) 15 | 16 | (define (canvas-wrapper f) 17 | (lambda (canvas . args) 18 | (let ((descriptor (record-accessor (record-type-descriptor canvas) 'descriptor))) 19 | (apply f (descriptor canvas) args)))) 20 | 21 | (define graphics-type/canvas (make-graphics-device-type 'canvas 22 | `((clear ,(canvas-wrapper canvas-clear)) 23 | (close ,(canvas-wrapper canvas-close)) 24 | (available? ,canvas-available?) 25 | (coordinate-limits ,(canvas-wrapper canvas-coordinate-limits)) 26 | (device-coordinate-limits ,(canvas-wrapper canvas-device-coordinate-limits)) 27 | (drag-cursor ,(canvas-wrapper canvas-drag-cursor)) 28 | (draw-line ,(canvas-wrapper canvas-draw-line)) 29 | (draw-point ,(canvas-wrapper canvas-draw-point)) 30 | (draw-text ,(canvas-wrapper canvas-draw-text)) 31 | (move-cursor ,(canvas-wrapper canvas-move-cursor)) 32 | (open ,canvas-open) 33 | (flush ,canvas-flush) 34 | (reset-clip-rectangle ,(canvas-wrapper canvas-reset-clip-rectangle)) 35 | (set-clip-rectangle ,(canvas-wrapper canvas-set-clip-rectangle)) 36 | (set-coordinate-limits ,(canvas-wrapper canvas-set-coordinate-limits)) 37 | (set-drawing-mode ,(canvas-wrapper canvas-set-drawing-mode)) 38 | (set-line-style ,(canvas-wrapper canvas-set-line-style)) 39 | (set-background-color ,(canvas-wrapper canvas-set-background-color)) 40 | (set-foreground-color ,(canvas-wrapper canvas-set-foreground-color)) 41 | 42 | (draw-points ,(canvas-wrapper canvas-draw-points)) 43 | (draw-rect ,(canvas-wrapper canvas-draw-rect)) 44 | (draw-rects ,(canvas-wrapper canvas-draw-rects)) 45 | (erase-point ,(canvas-wrapper canvas-erase-point)) 46 | (erase-points ,(canvas-wrapper canvas-erase-points)) 47 | (erase-rect ,(canvas-wrapper canvas-erase-rect)) 48 | (erase-rects ,(canvas-wrapper canvas-erase-rects)) 49 | (set-font ,(canvas-wrapper canvas-set-font)) 50 | (get-pointer-coordinates ,(canvas-wrapper canvas-get-pointer-coordinates))))) 51 | 52 | (define (make-window/canvas width height x y) 53 | (make-graphics-device 'canvas)) 54 | 55 | (define (make-window width height x y #!optional display) 56 | (let ((window (make-window/canvas width height x y))) 57 | (graphics-set-coordinate-limits window 0 (- (- height 1)) (- width 1) 0) 58 | window)) 59 | 60 | (define (make-display-frame #!optional xmin xmax ymin ymax frame-width frame-height frame-x-position frame-y-position display) 61 | (let ((xmin (if (default-object? xmin) 0. xmin)) 62 | (xmax (if (default-object? xmax) 1. xmax)) 63 | (ymin (if (default-object? ymin) 0. ymin)) 64 | (ymax (if (default-object? ymax) 1. ymax)) 65 | (frame-x (if (default-object? frame-x-position) *frame-x-position* frame-x-position)) 66 | (frame-y (if (default-object? frame-y-position) *frame-y-position* frame-y-position)) 67 | (frame-width (if (default-object? frame-width) *frame-width* frame-width)) 68 | (frame-height (if (default-object? frame-height) *frame-height* frame-height))) 69 | (if (not 70 | (and (integer? frame-width) 71 | (> frame-width 0) 72 | (integer? frame-height) 73 | (> frame-height 0))) 74 | (error "Bad frame width or height")) 75 | (let ((window 76 | (if (default-object? display) 77 | (make-window frame-width frame-height frame-x frame-y) 78 | (make-window frame-width frame-height frame-x frame-y display)))) 79 | (graphics-set-coordinate-limits window xmin ymin xmax ymax) 80 | (graphics-set-clip-rectangle window xmin ymin xmax ymax) 81 | (let ((name (graphics-type-name (graphics-type #f)))) 82 | (let ((temp name)) 83 | (cond ((eq? temp 'x) (graphics-operation window 'set-border-color "green") 84 | (graphics-operation window 'set-mouse-color "green")) 85 | ((eq? temp 'win32) 'nothing-to-do) 86 | ((eq? temp 'os/2) 'nothing-to-do) 87 | ((eq? temp 'canvas) 'nothing-to-do) 88 | (else (error "Unsupported graphics type:" name))))) 89 | (graphics-operation window 'set-background-color *background-color*) 90 | (graphics-operation window 'set-foreground-color *foreground-color*) 91 | (graphics-clear window) 92 | window))) 93 | 94 | (define frame make-display-frame) 95 | (define window-coordinates graphics-coordinate-limits) 96 | (define (window-size window) (map 1+ (cddr (graphics-device-coordinate-limits window)))) 97 | (define (get-pointer-coordinates win cont) (graphics-operation win 'get-pointer-coordinates cont)) 98 | 99 | (define (plot-line-internal window x0 y0 x1 y1) 100 | (graphics-draw-line window 101 | (exact->inexact x0) 102 | (exact->inexact y0) 103 | (exact->inexact x1) 104 | (exact->inexact y1))) 105 | 106 | (define (plot-point-internal window x y) 107 | (graphics-draw-point window (exact->inexact x) (exact->inexact y))) 108 | 109 | (define (plot-function window f #!optional x0 x1 dx) 110 | (if (default-object? x0) 111 | (let ((bounds (window-coordinates window)) (size (window-size window))) 112 | (set! x0 (car bounds)) 113 | (set! x1 (cadr bounds)) 114 | (set! dx (/ (- x1 x0) (car size))))) 115 | (let loop ((x x0) (fx (f x0))) 116 | (let ((nx (+ x dx))) 117 | (let ((nfx (f nx))) 118 | (plot-line-internal window x fx nx nfx) 119 | (if (< (* (- nx x0) (- nx x1)) 0.) 120 | (loop nx nfx)))))) 121 | 122 | (define (plot-point window x y) 123 | (plot-point-internal window x y)) -------------------------------------------------------------------------------- /src/runtime/runtime.scm: -------------------------------------------------------------------------------- 1 | (import-from (merge-pathnames "shared" *source-directory*) 2 | session-add-comm! 3 | session-add-widget! 4 | session-pub 5 | initialize-widget 6 | widget-comm 7 | widget-state 8 | set-widget-state!) 9 | (define *the-environment* (the-environment)) 10 | (load (merge-pathnames "runtime/widget" *source-directory*)) 11 | -------------------------------------------------------------------------------- /src/runtime/widget.scm: -------------------------------------------------------------------------------- 1 | (define comm-version "~2.1.4") 2 | (define comm-widget-name "jupyter.widget") 3 | (define comm-module "jupyter-js-widgets") 4 | 5 | (define widget-links '()) 6 | 7 | (define (make-widget-model widget) 8 | (string-append "IPY_MODEL_" (comm-id (widget-comm widget)))) 9 | 10 | (define (make-widget-data model view #!optional state) 11 | (fold-right 12 | cons 13 | (if (default-object? state) '() state) 14 | `((_view_module . ,comm-module) 15 | (_view_name . ,view) 16 | (msg_throttle . 1) 17 | (_dom_classes . #()) 18 | (_model_module . ,comm-module) 19 | (_model_module_version . ,comm-version) 20 | (_view_module_version . ,comm-version) 21 | (_model_name . ,model)))) 22 | 23 | (define (make-widget model view #!optional state) 24 | (let ((state (if (default-object? state) '() state))) 25 | (let ((data (make-widget-data model view state))) 26 | (let ((comm (open-comm session comm-widget-name data))) 27 | (let ((widget (initialize-widget (comm-id comm) comm model view state))) 28 | (session-add-comm! session comm) 29 | (session-add-widget! session widget) 30 | widget))))) 31 | 32 | (define (display-widget widget) 33 | (let ((comm (widget-comm widget))) 34 | (send-comm-msg comm '((method . "display"))) 35 | ((session-pub (comm-session comm)) 36 | "display_data" 37 | `((transient) 38 | (data 39 | (application/vnd.jupyter.widget-view+json 40 | (model_id . ,(comm-id comm)))) 41 | (metadata))))) 42 | 43 | (define (update-widget! widget state) 44 | (let ((comm (widget-comm widget))) 45 | (send-comm-msg comm `((method . "update") (state . ,state))) 46 | (set-widget-state! widget (merge-states (widget-state widget) state)))) 47 | 48 | (define ((widget-updater property #!optional predicate) widget value) 49 | (assert (or (default-object? predicate) (predicate value))) 50 | (update-widget! widget (list (cons property value)))) 51 | 52 | (define set-widget-value! (widget-updater 'value)) 53 | 54 | (define (widget-value widget) 55 | (cdr (assq 'value (widget-state widget)))) 56 | 57 | (define (create-widget-state layout #!optional style value) 58 | (let ((v (if (default-object? value) '() (list (cons 'value value)))) 59 | (s (if (default-object? style) '() (list (cons 'style (make-widget-model style)))))) 60 | (print v s) 61 | (print (make-widget-model layout)) 62 | (append (list (cons 'layout (make-widget-model layout))) v s))) 63 | 64 | (define ((create-widget name #!optional style-name) #!optional value) 65 | (let ((layout (make-widget "LayoutModel" "LayoutView")) 66 | (style (if (default-object? style-name) 67 | #!default 68 | (make-widget 69 | (string-append style-name "StyleModel") 70 | "StyleView"))) 71 | (model (string-append name "Model")) 72 | (view (string-append name "View"))) 73 | (let ((state (create-widget-state layout style value))) 74 | (print state) 75 | (let ((widget (make-widget model view state))) 76 | (display-widget widget) 77 | widget)))) 78 | 79 | (define make-button (create-widget "Button" "Button")) 80 | (define make-int-slider (create-widget "IntSlider" "Slider")) 81 | (define make-float-slider (create-widget "FloatSlider")) 82 | (define make-int-text (create-widget "IntText")) 83 | (define make-float-text (create-widget "FloatText")) 84 | (define make-text (create-widget "Text")) 85 | (define make-textarea (create-widget "Textarea")) 86 | (define make-checkbox (create-widget "Checkbox")) 87 | (define make-toggle-button (create-widget "ToggleButton")) 88 | (define make-toggle-buttons (create-widget "ToggleButtons")) 89 | (define make-label (create-widget "Label")) 90 | (define make-bounded-int-text (create-widget "BoundedIntText")) 91 | (define make-bounded-float-text (create-widget "BoundedFloatText")) 92 | (define make-int-progress (create-widget "IntProgress" "Progress")) 93 | (define make-float-progress (create-widget "FloatProgress")) 94 | (define make-color-picker (create-widget "ColorPicker")) 95 | (define make-play (create-widget "Play")) 96 | 97 | (define (link source target) 98 | (make-widget "LinkModel" #!unspecific 99 | `((source . #(,(make-widget-model source) value)) 100 | (target . #(,(make-widget-model target) value))))) 101 | 102 | (define make-handler cons) 103 | (define handler-name car) 104 | (define handler-effector cdr) 105 | (define (handler? handler) 106 | (and 107 | (pair? handler) 108 | (symbol? (handler-name handler)) 109 | (procedure? (handler-effector handler)) 110 | (= 1 (procedure-arity-min (procedure-arity (cdr handler)))))) 111 | 112 | (define (add-widget-handler! widget handler) 113 | (assert (handler? handler)) 114 | (set-widget-handlers! 115 | widget 116 | (cons handler (widget-handlers widget)))) 117 | 118 | (define (clear-widget-handlers! widget) 119 | (set-widget-handlers! widget '())) 120 | 121 | ; (define (link widget symbol) 122 | ; (assert (symbol? symbol)) 123 | ; (if (environment-bound? *the-environment* symbol) 124 | ; (set-widget-value! widget (environment-lookup *the-environment* symbol)) 125 | ; (environment-define *the-environment* symbol (widget-value widget))) 126 | ; (let ((l (assq symbol widget-links))) 127 | ; (if l 128 | ; (set-cdr! l (cons widget (cdr l))) 129 | ; (set! widget-links (cons (list symbol widget) widget-links)))) 130 | ; (add-widget-handler! 131 | ; widget 132 | ; (make-handler 133 | ; symbol 134 | ; (lambda (state) 135 | ; (let ((value (cdr (assq 'value state)))) 136 | ; (for-each 137 | ; (lambda (w) 138 | ; (if (not (eq? w widget)) 139 | ; (set-widget-value! w value))) 140 | ; (cdr (assq symbol widget-links))) 141 | ; (environment-assign! *the-environment* symbol value)))))) 142 | 143 | ; (define (clear-all-links!) 144 | ; (set! widget-links '())) 145 | 146 | ; (define (clear-links! symbol) 147 | ; (let ((l (assq symbol widget-links))) 148 | ; (if l 149 | ; (for-each 150 | ; (lambda (w) 151 | ; (del-assq! symbol (widget-handlers w))) 152 | ; (cdr l))))) -------------------------------------------------------------------------------- /src/runtime/widgets/button.scm: -------------------------------------------------------------------------------- 1 | (define (make-button-state style layout #!optional description) 2 | `((style . ,(make-widget-model style)) 3 | (layout . ,(make-widget-model layout)) 4 | (description . ,(if (default-object? description) "" description)) 5 | (disabled . #f))) 6 | 7 | (define (make-button #!optional description) 8 | (let ((style (make-widget "ButtonStyleModel" "StyleView")) 9 | (layout (make-widget "LayoutModel" "LayoutView"))) 10 | (let ((state (make-slider-state style layout))) 11 | (let ((widget (make-widget "ButtonModel" "ButtonView" state))) 12 | (display-widget widget) 13 | widget)))) 14 | 15 | (define set-button-description! (widget-updater 'description string?)) 16 | (define set-button-disabled! (widget-updater 'disabled boolean?)) 17 | -------------------------------------------------------------------------------- /src/runtime/widgets/checkbox.scm: -------------------------------------------------------------------------------- 1 | (define (make-checkbox-state layout #!optional description value) 2 | `((value . (if (default-object? value) #f value)) 3 | (description . ,(if (default-object? description) "" description)) 4 | (disabled . #f) 5 | (layout . ,(make-widget-model layout)) 6 | (_dom_classes . #()) 7 | (continuous_update . #t))) 8 | 9 | (define (make-checkbox #!optional description value) 10 | (let ((layout (make-widget "LayoutModel" "LayoutView"))) 11 | (let ((state (make-checkbox-state layout description value))) 12 | (let ((widget (make-widget "CheckboxModel" "CheckboxView"))) 13 | (display-widget widget) 14 | widget)))) 15 | 16 | (define set-progress-value! (widget-updater 'value boolean?)) 17 | (define set-progress-description! (widget-updater 'description string?)) 18 | (define set-progress-disabled! (widget-updater 'disabled boolean?)) 19 | -------------------------------------------------------------------------------- /src/runtime/widgets/progress.scm: -------------------------------------------------------------------------------- 1 | (define (make-progress-state style layout) 2 | `((value . 0) 3 | (min . 0) 4 | (max . 100) 5 | (step . 1) 6 | (description . "") 7 | (orientation . "horizontal") 8 | (disabled . #f) 9 | (style . ,(make-widget-model style)) 10 | (layout . ,(make-widget-model layout)) 11 | (continuous_update . #t))) 12 | 13 | (define (make-progress) 14 | (let ((layout (make-widget "LayoutModel" "LayoutView")) 15 | (style (make-widget "ProgressStyleModel" "StyleView"))) 16 | (let ((state (make-progress-state layout style))) 17 | (let ((widget (make-widget "ProgressModel" "ProgressView"))) 18 | (display-widget widget) 19 | widget)))) 20 | 21 | (define set-progress-value! (widget-updater 'value integer?)) 22 | (define set-progress-min! (widget-updater 'min integer?)) 23 | (define set-progress-max! (widget-updater 'max integer?)) 24 | (define set-progress-step! (widget-updater 'step integer?)) 25 | (define set-progress-description! (widget-updater 'description string?)) 26 | (define set-progress-orientation! (widget-updater 'orientation string?)) 27 | (define set-progress-disabled! (widget-updater 'disabled boolean?)) 28 | -------------------------------------------------------------------------------- /src/runtime/widgets/slider.scm: -------------------------------------------------------------------------------- 1 | (define (make-slider-state style layout #!optional description value) 2 | `((max . 100) 3 | (style . ,(make-widget-model style)) 4 | (layout . ,(make-widget-model layout)) 5 | (orientation . "horizontal") 6 | (continuous_update . #t) 7 | (step . 1) 8 | (readout_format . "d") 9 | (readout . #t) 10 | (disabled . #f) 11 | (description . ,(if (default-object? description) "" description)) 12 | (value . ,(if (default-object? value) 0 value)))) 13 | 14 | (define (make-slider #!optional description value) 15 | (let ((style (make-widget "SliderStyleModel" "StyleView")) 16 | (layout (make-widget "LayoutModel" "LayoutView"))) 17 | (let ((state (make-slider-state style layout description value))) 18 | (let ((widget (make-widget "IntSliderModel" "IntSliderView" state))) 19 | (display-widget widget) 20 | widget)))) 21 | 22 | (define set-slider-value! (widget-updater 'value integer?)) 23 | (define set-slider-min! (widget-updater 'min integer?)) 24 | (define set-slider-max! (widget-updater 'max integer?)) 25 | (define set-slider-step! (widget-updater 'step integer?)) 26 | (define set-slider-orientation! (widget-updater 'orientation string?)) 27 | (define set-slider-disabled! (widget-updater 'disabled boolean?)) 28 | -------------------------------------------------------------------------------- /src/runtime/widgets/text.scm: -------------------------------------------------------------------------------- 1 | (define (make-text-state layout #!optional value) 2 | `((value . ,(if (default-object? value) 0 value)) 3 | (min . 0) 4 | (max . 100) 5 | (step . 1) 6 | (disabled . #f) 7 | (layout . ,(make-widget-model layout)) 8 | (_dom_classes . #()) 9 | (continuous_update . #t))) 10 | 11 | (define (make-text #!optional value) 12 | (let ((layout (make-widget "LayoutModel" "LayoutView"))) 13 | (let ((state (make-text-state layout value))) 14 | (let ((widget (make-widget "IntTextModel" "IntTextView"))) 15 | (display-widget widget) 16 | widget)))) 17 | 18 | (define set-text-value! (widget-updater 'value integer?)) 19 | (define set-text-min! (widget-updater 'min integer?)) 20 | (define set-text-max! (widget-updater 'max integer?)) 21 | (define set-text-step! (widget-updater 'step integer?)) 22 | (define set-text-disabled! (widget-updater 'disabled boolean?)) 23 | -------------------------------------------------------------------------------- /src/shared.scm: -------------------------------------------------------------------------------- 1 | (define shared-env (the-environment)) 2 | 3 | ;; Util 4 | (define (make-id) 5 | (number->string (random (expt 2 128)) 16)) 6 | 7 | (define (print . args) 8 | (for-each (lambda (arg) (pp arg (console-i/o-port))) args)) 9 | 10 | ;; Session 11 | (define (default-pub . args) 12 | (apply print "default pub!" args)) 13 | 14 | (define-structure 15 | (session (constructor initialize-session (identity id))) 16 | (identity) 17 | (id) 18 | (pub default-pub) 19 | (count 0) 20 | (stdio #!unspecific) 21 | (env (extend-top-level-environment shared-env)) 22 | (comms '()) 23 | (widgets '())) 24 | 25 | (define (session-add-comm! session comm) 26 | (set-session-comms! session (cons comm (session-comms session)))) 27 | 28 | (define (session-add-widget! session widget) 29 | (set-session-widgets! session (cons widget (session-widgets session)))) 30 | 31 | ;; Comm 32 | (define-structure 33 | (comm (constructor initialize-comm (session target #!optional id))) 34 | (session) 35 | (target) 36 | (id (make-id))) 37 | 38 | (define (make-comm session target #!optional id) 39 | (let ((comm (initialize-comm session target id))) 40 | (session-add-comm! session comm) 41 | comm)) 42 | 43 | (define (make-comm-content comm #!optional data) 44 | `((comm_id . ,(comm-id comm)) 45 | (target_name . ,(comm-target comm)) 46 | (target_module . #!unspecific) 47 | (data . ,(if (default-object? data) '() data)))) 48 | 49 | (define (open-comm session target #!optional data) 50 | (let ((comm (make-comm session target))) 51 | ((session-pub session) 52 | "comm_open" 53 | (make-comm-content comm data)) 54 | comm)) 55 | 56 | (define (send-comm-msg comm data) 57 | ((session-pub (comm-session comm)) 58 | "comm_msg" 59 | `((comm_id . ,(comm-id comm)) 60 | (target_name . ,(comm-target comm)) 61 | (target_module . #!unspecific) 62 | (data . ,data)))) 63 | 64 | ; ;; Widget 65 | (define-structure 66 | (widget (constructor initialize-widget (id comm model view state))) 67 | (id) 68 | (comm) 69 | (model) 70 | (view) 71 | (handler (lambda args #!unspecific)) 72 | (state '()) 73 | (handlers '())) 74 | 75 | (define widget-ref (association-procedure string=? widget-id)) 76 | 77 | (define (merge-states old new) 78 | (fold-right 79 | cons 80 | new 81 | (filter (lambda (e) (not (assq (car e) new))) old))) 82 | 83 | (export-to 84 | make-id 85 | print 86 | initialize-session 87 | session-id 88 | session-pub 89 | set-session-pub! 90 | session-count 91 | set-session-count! 92 | session-stdio 93 | set-session-stdio! 94 | session-env 95 | session-comms 96 | session-widgets 97 | session-add-comm! 98 | session-add-widget! 99 | comm-session 100 | comm-target 101 | comm-id 102 | make-comm 103 | open-comm 104 | send-comm-msg 105 | initialize-widget 106 | widget-comm 107 | widget-model 108 | widget-ref 109 | widget-handler 110 | set-widget-handler! 111 | widget-state 112 | set-widget-state! 113 | widget-handlers 114 | set-widget-handlers! 115 | merge-states) -------------------------------------------------------------------------------- /src/view.scm: -------------------------------------------------------------------------------- 1 | (define inspectors '()) 2 | (define make-inspector cons) 3 | (define inspector-type car) 4 | (define inspector-effector cdr) 5 | 6 | (define (attach-inspector! predicate effector) 7 | (set! inspectors 8 | (cons 9 | (make-inspector type effector) 10 | inspectors))) 11 | 12 | (define ((inspect-find inspector) object) 13 | ((inspector-effector inspector) object)) 14 | 15 | (define (inspect object . args) 16 | (let ((inspector (find (inspect-find object) inspectors))) 17 | (if inspector 18 | (apply (inspector-effector inspector) object args) 19 | (error "invalid inspect application")))) 20 | 21 | -------------------------------------------------------------------------------- /src/zmq-constants.scm: -------------------------------------------------------------------------------- 1 | ;; Contexts 2 | (define zmq-context-options 3 | '((io-threads 1) 4 | (max-sockets 2) 5 | (socket-limit 3) 6 | (thread-priority 3) 7 | (thread-sched-policy 4) 8 | (max-msgsz 5) 9 | (msg-t-size 6) 10 | (thread-affinity-cpu-add 7) 11 | (thread-affinity-cpu-remove 8) 12 | (thread-name-prefix 9))) 13 | 14 | ;; Sockets 15 | (define zmq-socket-types 16 | '((pair 0) 17 | (pub 1) 18 | (sub 2) 19 | (req 3) 20 | (rep 4) 21 | (dealer 5) 22 | (router 6) 23 | (pull 7) 24 | (push 8) 25 | (xpub 9) 26 | (xsub 10) 27 | (stream 11))) 28 | 29 | (define zmq-socket-options 30 | '((affinity 4) 31 | (routing-id 5) 32 | (subscribe 6) 33 | (unsubscribe 7) 34 | (rate 8) 35 | (recovery-ivl 9) 36 | (sndbuf 11) 37 | (rcvbuf 12) 38 | (rcvmore 13) 39 | (fd 14) 40 | (events 15) 41 | (type 16) 42 | (linger 17) 43 | (reconnect-ivl 18) 44 | (backlog 19) 45 | (reconnect-ivl-max 21) 46 | (maxmsgsize 22) 47 | (sndhwm 23) 48 | (rcvhwm 24) 49 | (multicast-hops 25) 50 | (rcvtimeo 27) 51 | (sndtimeo 28) 52 | (last-endpoint 32) 53 | (router-mandatory 33) 54 | (tcp-keepalive 34) 55 | (tcp-keepalive-cnt 35) 56 | (tcp-keepalive-idle 36) 57 | (tcp-keepalive-intvl 37) 58 | (immediate 39) 59 | (xpub-verbose 40) 60 | (router-raw 41) 61 | (ipv6 42) 62 | (mechanism 43) 63 | (plain-server 44) 64 | (plain-username 45) 65 | (plain-password 46) 66 | (curve-server 47) 67 | (curve-publickey 48) 68 | (curve-secretkey 49) 69 | (curve-serverkey 50) 70 | (probe-router 51) 71 | (req-correlate 52) 72 | (req-relaxed 53) 73 | (conflate 54) 74 | (zap-domain 55) 75 | (router-handover 56) 76 | (tos 57) 77 | (connect-routing-id 61) 78 | (gssapi-server 62) 79 | (gssapi-principal 63) 80 | (gssapi-service-principal 64) 81 | (gssapi-plaintext 65) 82 | (handshake-ivl 66) 83 | (socks-proxy 68) 84 | (xpub-nodrop 69) 85 | (blocky 70) 86 | (xpub-manual 71) 87 | (xpub-welcome-msg 72) 88 | (stream-notify 73) 89 | (invert-matching 74) 90 | (heartbeat-ivl 75) 91 | (heartbeat-ttl 76) 92 | (heartbeat-timeout 77) 93 | (xpub-verboser 78) 94 | (connect-timeout 79) 95 | (tcp-maxrt 80) 96 | (thread-safe 81) 97 | (multicast-maxtpdu 84) 98 | (vmci-buffer-size 85) 99 | (vmci-buffer-min-size 86) 100 | (vmci-buffer-max-size 87) 101 | (vmci-connect-timeout 88) 102 | (use-fd 89) 103 | (gssapi-principal-nametype 90) 104 | (gssapi-service-principal-nametype 91) 105 | (bindtodevice 92))) 106 | 107 | ;; Poll Event Types 108 | (define zmq-poll-events 109 | '((pollin 1) 110 | (pollout 2) 111 | (pollerr 4) 112 | (pollpri 8))) 113 | 114 | ;; Messages 115 | (define zmq-message-options 116 | '((more 1) 117 | (srcfd 2) 118 | (shared 3))) 119 | 120 | (export-to 121 | zmq-context-options 122 | zmq-socket-types 123 | zmq-socket-options 124 | zmq-poll-events 125 | zmq-message-options) -------------------------------------------------------------------------------- /src/zmq.scm: -------------------------------------------------------------------------------- 1 | ;; ZeroMQ for MIT Scheme 2 | 3 | (import-from "zmq-constants" 4 | zmq-context-options 5 | zmq-socket-types 6 | zmq-socket-options 7 | zmq-poll-events 8 | zmq-message-options) 9 | 10 | (define ld-library-path "/usr/local/lib/mit-scheme-x86-64/:/usr/local/lib/") 11 | (set-environment-variable! "LD_LIBRARY_PATH" ld-library-path) 12 | 13 | (load-option 'ffi) 14 | (c-include "zmq") 15 | 16 | (define message-size 64) 17 | (define (make-message) 18 | (malloc message-size 'zmq_msg_t)) 19 | 20 | (define (make-pointer) 21 | (copy-alien null-alien)) 22 | 23 | ;; Errors 24 | (define (zmq-error message) 25 | (error message 26 | (c-peek-cstring 27 | (c-call "zmq_strerror" 28 | (make-pointer) 29 | (c-call "zmq_errno"))))) 30 | 31 | ;; Contexts 32 | (define (make-zmq-context) 33 | (define context (c-call "zmq_ctx_new" (make-pointer))) 34 | (if (alien-null? context) 35 | (zmq-error "make-zmq-context") 36 | context)) 37 | 38 | (define (zmq-context/terminate! context) 39 | (if (= -1 (c-call "zmq_ctx_term" context)) 40 | (zmq-error "zmq-context/terminate!"))) 41 | 42 | (define (zmq-context/shutdown! context) 43 | (if (= -1 (c-call "zmq_ctx_shutdown" context)) 44 | (zmq-error "zmq-context/shutdown!"))) 45 | 46 | (define (zmq-context/destroy! context) 47 | (if (= -1 (c-call "zmq_ctx_destroy" context)) 48 | (zmq-error "zmq-context/destroy!"))) 49 | 50 | (define (zmq-context/get context option) 51 | (define option-value (cadr (assq option zmq-context-options))) 52 | (define result (c-call "zmq_ctx_get" context option-value)) 53 | (if (= -1 result) 54 | (zmq-error "zmq-context/get") 55 | result)) 56 | 57 | (define (zmq-context/set! context option value) 58 | (define option-value (cadr (assq option zmq-context-options))) 59 | (define result (c-call "zmq_ctx_get" context option-value value)) 60 | (if (= -1 result) 61 | (zmq-error "zmq-context/set!") 62 | result)) 63 | 64 | ;; Sockets 65 | (define (make-zmq-socket context type) 66 | (define type-value (cadr (assq type zmq-socket-types))) 67 | (define socket (c-call "zmq_socket" (make-pointer) context type-value)) 68 | (if (alien-null? socket) 69 | (zmq-error "make-zmq-socket") 70 | socket)) 71 | 72 | (define (zmq-socket/close! socket) 73 | (if (= -1 (c-call "zmq_close" socket)) 74 | (zmq-error "zmq-socket/close!"))) 75 | 76 | (define (zmq-socket/connect! socket endpoint) 77 | (if (= -1 (c-call "zmq_connect" socket endpoint)) 78 | (zmq-error "zmq-socket/connect!"))) 79 | 80 | (define (zmq-socket/disconnect! socket endpoint) 81 | (if (= -1 (c-call "zmq_disconnect" socket endpoint)) 82 | (zmq-error "zmq-socket/disconnect!"))) 83 | 84 | (define (zmq-socket/bind! socket endpoint) 85 | (if (= -1 (c-call "zmq_bind" socket endpoint)) 86 | (zmq-error "zmq-socket/bind!"))) 87 | 88 | (define (zmq-socket/unbind! socket endpoint) 89 | (if (= -1 (c-call "zmq_unbind" socket endpoint)) 90 | (zmq-error "zmq-socket/unbind!"))) 91 | 92 | (define (zmq-socket/monitor! socket endpoint events) 93 | (define events-value (fold + 0 events)) 94 | (if (= -1 (c-call "zmq_socket_monitor" socket endpoint events-value)) 95 | (zmq-error "zmq-socket/monitor!"))) 96 | 97 | ; (define (zmq-socket/get socket option) 98 | ; ) 99 | 100 | ; (define (zmq-socket/set! socket option value) 101 | ; ) 102 | 103 | (define (zmq-socket-option option) 104 | (cadr (assq option zmq-socket-options))) 105 | 106 | (define (zmq-socket/send socket . messages) 107 | (fold-left 108 | (lambda (rest message) 109 | (define flag (if (null? rest) 0 2)) 110 | (define data (->bytevector message)) 111 | (define len (bytevector-length data)) 112 | (define buf (bytevector->buffer data len)) 113 | (if (= -1 (c-call "zmq_send" socket buf len flag)) 114 | (zmq-error "zmq-socket/send") 115 | (if (null? rest) #!unspecific (cdr rest)))) 116 | (if (null? messages) #!unspecific (cdr messages)) 117 | messages)) 118 | 119 | (define (zmq-socket/receive socket len . flags) 120 | (define flag (fold + 0 (map zmq-socket-option flags))) 121 | (define buf (malloc len 'char)) 122 | (define result (c-call "zmq_recv" socket buf len flag)) 123 | (if (= -1 result) 124 | (zmq-error "zmq-socket/receive") 125 | (buffer->bytevector buf result))) 126 | 127 | ;; Messages 128 | (define (zmq-message/close! message) 129 | (if (= -1 (c-call "zmq_msg_close" message)) 130 | (zmq-error "zmq-message/close!"))) 131 | 132 | (define (zmq-message/copy dest src) 133 | (if (= -1 (c-call "zmq_msg_copy" dest src)) 134 | (zmq-error "zmq-message/copy"))) 135 | 136 | (define (zmq-message/move dest src) 137 | (if (= -1 (c-call "zmq_msg_move" dest src)) 138 | (zmq-error "zmq-message/move"))) 139 | 140 | (define (zmq-message/size message) 141 | (define size (c-call "zmq_msg_size" message)) 142 | (if (= -1 result) 143 | (zmq-error "zmq-message/size") 144 | size)) 145 | 146 | (define (zmq-message/more? message) 147 | (= 1 (c-call "zmq_msg_more" message))) 148 | 149 | (define (zmq-message/init! message) 150 | (if (= -1 (c-call "zmq_msg_init" message)) 151 | (zmq-error "zmq-message/init"))) 152 | 153 | (define (zmq-message/init-size! message size) 154 | (if (= -1 (c-call "zmq_msg_init_size" message size)) 155 | (zmq-error "make-zmq-message/msg_init_size"))) 156 | 157 | (define (zmq-message/data message) 158 | (define data (c-call "zmq_msg_data" (make-pointer) message)) 159 | (if (alien-null? data) 160 | (zmq-error "zmq-message/data") 161 | data)) 162 | 163 | (define (zmq-message/receive message socket) 164 | (define size (c-call "zmq_msg_recv" message socket 0)) 165 | (if (= -1 size) 166 | (zmq-error "zmq-message/receive") 167 | size)) 168 | 169 | (define (zmq-message/echo! input output) 170 | (let ((message (make-message))) 171 | (zmq-message/init! message) 172 | (if (= -1 (c-call "zmq_msg_recv" message input 0)) 173 | (zmq-error "zmq-message/echo! zmq_msg_recv") 174 | (if (= -1 (c-call "zmq_msg_send" message output 0)) 175 | (zmq-error "zmq-message/echo! zmq_msg_send"))))) 176 | 177 | (define (make-zmq-message #!optional data) 178 | (define message (make-message)) 179 | (define size (bytevector-length data)) 180 | (if (or (default-object? data) (= 0 size)) 181 | (begin 182 | (zmq-message/init! message) 183 | message) 184 | (begin 185 | (zmq-message/init-size! message size) 186 | (let iter ((i 0) (cell (zmq-message/data message))) 187 | (if (< i size) 188 | (begin 189 | (c->= cell "char" (bytevector-u8-ref data i)) 190 | (alien-byte-increment! cell 1 'char) 191 | (iter (1+ i) cell)) 192 | message))))) 193 | 194 | ;; Polling 195 | 196 | #| 197 | (define (zmq-poll-event event) 198 | (cadr (assq event zmq-poll-events))) 199 | 200 | (define (make-zmq-poller) 201 | (c-call "zmq_poller_new" (make-pointer))) 202 | 203 | (define (zmq-poller/destroy! poller) 204 | (if (= -1 (c-call "zmq_poller_destroy" poller)) 205 | (zmq-error "zmq-poller/destroy!"))) 206 | 207 | (define (zmq-poller/add! poller socket . events) 208 | (define event (fold + 0 (map zmq-poll-event events))) 209 | (if (= -1 (c-call "zmq_poller_add" poller socket null-alien event)) 210 | (zmq-error "zmq-poller/add!"))) 211 | 212 | (define (zmq-poller/remove! poller socket) 213 | (if (= -1 (c-call "zmq_poller_remove" poller socket)) 214 | (zmq-error "zmq-poller/remove!"))) 215 | 216 | (define (zmq-poller/wait poller events count) 217 | (pp "wow")) 218 | |# 219 | 220 | (define zmq-poll-size (c-sizeof "zmq_pollitem_t")) 221 | (define zmq-poll-event 1) 222 | 223 | (define (get-zmq-pollitem alien i) 224 | (alien-byte-increment alien (* i zmq-poll-size) 'zmq_pollitem_t)) 225 | 226 | (define ((make-zmq-pollitem pollitems) i socket) 227 | (let ((pollitem (get-zmq-pollitem pollitems i))) 228 | (c->= pollitem "zmq_pollitem_t socket" socket) 229 | (c->= pollitem "zmq_pollitem_t events" zmq-poll-event) 230 | pollitem)) 231 | 232 | (define (make-zmq-pollitems n sockets) 233 | (map 234 | (make-zmq-pollitem 235 | (malloc (* n zmq-poll-size) 'zmq_pollitem_t)) 236 | (iota n) 237 | sockets)) 238 | 239 | (define (zmq-poll/event? event revents) 240 | (odd? (quotient revents (cadr (assq event zmq-poll-events))))) 241 | 242 | (define (zmq-pollitem/revents pollitem) 243 | (c-> pollitem "zmq_pollitem_t revents")) 244 | 245 | (define (zmq-poll items nitems timeout) 246 | (c-call "zmq_poll" items nitems timeout)) 247 | 248 | (define (->bytevector data) 249 | (cond 250 | ((bytevector? data) data) 251 | ((string? data) (string->utf8 data)) 252 | (else (error "Unrecognized input")))) 253 | 254 | (define (bytevector->buffer data len) 255 | (define buf (malloc len 'char)) 256 | (let iter ((i 0) (elm (copy-alien buf))) 257 | (if (< i len) 258 | (let ((char (bytevector-u8-ref data i))) 259 | (c->= elm "char" char) 260 | (alien-byte-increment! elm 1 'char) 261 | (iter (1+ i) elm)) 262 | buf))) 263 | 264 | (define (buffer->bytevector buf len) 265 | (define data (make-bytevector len)) 266 | (let iter ((i 0) (elm (copy-alien buf))) 267 | (if (< i len) 268 | (let ((char (c-> elm "char"))) 269 | (bytevector-u8-set! data i char) 270 | (alien-byte-increment! elm 1 'char) 271 | (iter (1+ i) elm)) 272 | data))) 273 | 274 | (define (receive-message socket) 275 | (define message (make-message)) 276 | (zmq-message/init! message) 277 | (define size (zmq-message/receive message socket)) 278 | (define cell (zmq-message/data message)) 279 | (define data (make-bytevector size)) 280 | (let iter ((i 0)) 281 | (if (or (>= i size) (alien-null? cell)) 282 | (begin 283 | (zmq-message/close! message) 284 | data) 285 | (begin 286 | (bytevector-u8-set! data i (c-> cell "char")) 287 | (alien-byte-increment! cell 1 'char) 288 | (iter (1+ i)))))) 289 | 290 | (define (receive-messages socket) 291 | (let next ((message (make-message)) (messages '())) 292 | (c-call "zmq_msg_init" message) 293 | (zmq-message/init! message) 294 | (define size (zmq-message/receive message socket)) 295 | (define cell (zmq-message/data message)) 296 | (define data (make-bytevector size)) 297 | (let iter ((i 0)) 298 | (if (or (>= i size) (alien-null? cell)) 299 | (let ((more (zmq-message/more? message)) 300 | (messages (cons data messages))) 301 | (zmq-message/close! message) 302 | (if more (next (make-message) messages) messages)) 303 | (begin 304 | (bytevector-u8-set! data i (c-> cell "char")) 305 | (alien-byte-increment! cell 1 'char) 306 | (iter (1+ i))))))) 307 | 308 | (export-to 309 | make-zmq-context 310 | zmq-context/terminate! 311 | make-zmq-socket 312 | zmq-socket/bind! 313 | zmq-socket/unbind! 314 | zmq-socket/close! 315 | ; make-zmq-poller 316 | ; zmq-poller/destroy! 317 | ; zmq-poller/add! 318 | ; zmq-poller/remove! 319 | ; zmq-poller/wait 320 | make-zmq-pollitems 321 | zmq-pollitem/revents 322 | zmq-poll/event? 323 | zmq-poll 324 | zmq-socket/send 325 | receive-message 326 | receive-messages 327 | zmq-message/echo!) -------------------------------------------------------------------------------- /zmq.cdecl: -------------------------------------------------------------------------------- 1 | (typedef size_t uint) 2 | (typedef uint32_t uint) 3 | 4 | (typedef zmq_pollitem_t 5 | (struct zmq_pollitem_t 6 | (socket (* void)) 7 | (fd int) 8 | (events short) 9 | (revents short))) 10 | 11 | #| 12 | (extern int 13 | zmq_atomic_counter_dec 14 | (counter (* void))) 15 | 16 | (extern void 17 | zmq_atomic_counter_destroy 18 | (counter_p (* (* void)))) 19 | 20 | (extern int 21 | zmq_atomic_counter_inc 22 | (counter (* void))) 23 | 24 | (extern (* void) 25 | zmq_atomic_counter_new) 26 | 27 | (extern void 28 | zmq_atomic_counter_set 29 | (counter (* void)) 30 | (value int)) 31 | 32 | (extern int 33 | zmq_atomic_counter_value 34 | (counter (* void))) 35 | |# 36 | 37 | (extern int 38 | zmq_bind 39 | (socket (* void)) 40 | (endpoint (* (const char)))) 41 | 42 | (extern int 43 | zmq_close 44 | (socket (* void))) 45 | 46 | (extern int 47 | zmq_connect 48 | (socket (* void)) 49 | (endpoint (* (const char)))) 50 | 51 | (extern int 52 | zmq_ctx_destroy 53 | (context (* void))) 54 | 55 | (extern int 56 | zmq_ctx_get 57 | (context (* void)) 58 | (option_name int)) 59 | 60 | (extern (* void) 61 | zmq_ctx_new) 62 | 63 | (extern int 64 | zmq_ctx_set 65 | (context (* void)) 66 | (option_name int) 67 | (option_value int)) 68 | 69 | (extern int 70 | zmq_ctx_shutdown 71 | (context (* void))) 72 | 73 | (extern int 74 | zmq_ctx_term 75 | (context (* void))) 76 | 77 | (extern int 78 | zmq_curve_keypair 79 | (z85_public_key (* char)) 80 | (z85_secret_key (* char))) 81 | 82 | (extern int 83 | zmq_curve_public 84 | (z85_public_key (* char)) 85 | (z85_secret_key (* char))) 86 | 87 | (extern int 88 | zmq_disconnect 89 | (socket (* void)) 90 | (endpoint (* (const char)))) 91 | 92 | (extern int 93 | zmq_errno) 94 | 95 | (extern int 96 | zmq_getsockopt 97 | (socket (* void)) 98 | (option_name int) 99 | (option_value (* void)) 100 | (option_len (* size_t))) 101 | 102 | (extern int 103 | zmq_has 104 | (capability (* (const char)))) 105 | 106 | (extern int 107 | zmq_msg_close 108 | (msg (* zmq_msg_t))) 109 | 110 | (extern int 111 | zmq_msg_copy 112 | (dest (* zmq_msg_t)) 113 | (src (* zmq_msg_t))) 114 | 115 | (extern (* void) 116 | zmq_msg_data 117 | (msg (* zmq_msg_t))) 118 | 119 | (extern (* (const char)) 120 | zmq_msg_gets 121 | (message (* zmq_msg_t)) 122 | (property (* (const char)))) 123 | 124 | (extern int 125 | zmq_msg_get 126 | (message (* zmq_msg_t)) 127 | (property int)) 128 | 129 | (callback void 130 | zmq_free_fn 131 | (data (* void)) 132 | (ID (* void))) 133 | 134 | (extern int 135 | zmq_msg_init_data 136 | (msg (* zmq_msg_t)) 137 | (data (* void)) 138 | (size size_t) 139 | (ffn (* zmq_free_fn)) 140 | (ID (* void))) 141 | 142 | (extern int 143 | zmq_msg_init_size 144 | (msg (* zmq_msg_t)) 145 | (size size_t)) 146 | 147 | (extern int 148 | zmq_msg_init 149 | (msg (* zmq_msg_t))) 150 | 151 | (extern int 152 | zmq_msg_more 153 | (message (* zmq_msg_t))) 154 | 155 | (extern int 156 | zmq_msg_move 157 | (dest (* zmq_msg_t)) 158 | (src (* zmq_msg_t))) 159 | 160 | (extern int 161 | zmq_msg_recv 162 | (msg (* zmq_msg_t)) 163 | (socket (* void)) 164 | (flags int)) 165 | 166 | #| 167 | (extern uint32_t 168 | zmq_msg_routing_id 169 | (message (* zmq_msg_t))) 170 | |# 171 | 172 | (extern int 173 | zmq_msg_send 174 | (msg (* zmq_msg_t)) 175 | (socket (* void)) 176 | (flags int)) 177 | 178 | #| 179 | (extern int 180 | zmq_msg_set_routing_id 181 | (message (* zmq_msg_t)) 182 | (routing_id uint32_t)) 183 | |# 184 | 185 | (extern int 186 | zmq_msg_set 187 | (msg (* zmq_msg_t)) 188 | (property int) 189 | (value int)) 190 | 191 | (extern size_t 192 | zmq_msg_size 193 | (msg (* zmq_msg_t))) 194 | 195 | #| 196 | (extern (* void) 197 | zmq_poller_new) 198 | 199 | (extern int 200 | zmq_poller_destroy 201 | (poller_p (* (* void)))) 202 | 203 | (extern int 204 | zmq_poller_add 205 | (poller (* void)) 206 | (socket (* void)) 207 | (user_data (* void)) 208 | (events short)) 209 | 210 | (extern int 211 | zmq_poller_modify 212 | (poller (* void)) 213 | (socket (* void)) 214 | (events short)) 215 | 216 | (extern int 217 | zmq_poller_remove 218 | (poller (* void)) 219 | (socket (* void))) 220 | 221 | (extern int 222 | zmq_poller_add_fd 223 | (poller (* void)) 224 | (fd int) 225 | (user_data (* void)) 226 | (events short)) 227 | 228 | (extern int 229 | zmq_poller_modify_fd 230 | (poller (* void)) 231 | (fd int) 232 | (events short)) 233 | 234 | (extern int 235 | zmq_poller_remove_fd 236 | (poller (* void)) 237 | (fd int)) 238 | 239 | (typedef zmq_poller_event_t 240 | (struct zmq_poller_event_t 241 | (socket (* void)) 242 | (fd int) 243 | (user_data (* void)) 244 | (events short))) 245 | 246 | (extern int 247 | zmq_poller_wait_all 248 | (poller (* void)) 249 | (events (* zmq_poller_event_t)) 250 | (n_events int) 251 | (timeout long)) 252 | |# 253 | 254 | (extern int 255 | zmq_poll 256 | (items (* zmq_pollitem_t)) 257 | (nitems int) 258 | (timeout long)) 259 | 260 | (extern int 261 | zmq_proxy_steerable 262 | (frontend (* void)) 263 | (backend (* void)) 264 | (capture (* void)) 265 | (control (* void))) 266 | 267 | (extern int 268 | zmq_proxy 269 | (frontend (* void)) 270 | (backend (* void)) 271 | (capture (* void))) 272 | 273 | (extern int 274 | zmq_recv 275 | (socket (* void)) 276 | (buf (* void)) 277 | (len size_t) 278 | (flags int)) 279 | 280 | (extern int 281 | zmq_send_const 282 | (socket (* void)) 283 | (buf (* void)) 284 | (len size_t) 285 | (flags int)) 286 | 287 | (extern int 288 | zmq_send 289 | (socket (* void)) 290 | (buf (* void)) 291 | (len size_t) 292 | (flags int)) 293 | 294 | (extern int 295 | zmq_setsockopt 296 | (socket (* void)) 297 | (option_name int) 298 | (option_value (* void)) 299 | (option_len size_t)) 300 | 301 | (extern int 302 | zmq_socket_monitor 303 | (socket (* void)) 304 | (endpoint (* char)) 305 | (events int)) 306 | 307 | (extern (* void) 308 | zmq_socket 309 | (context (* void)) 310 | (type int)) 311 | 312 | (extern (* (const char)) 313 | zmq_strerror 314 | (errnum int)) 315 | 316 | (extern int 317 | zmq_term 318 | (context (* void))) 319 | 320 | (callback void 321 | zmq_timer_fn 322 | (timer_id int) 323 | (ID (* void))) 324 | 325 | (extern (* void) 326 | zmq_timers_new) 327 | 328 | (extern int 329 | zmq_timers_destroy 330 | (timers_p (* (* void)))) 331 | 332 | (extern int 333 | zmq_timers_add 334 | (timers (* void)) 335 | (interval size_t) 336 | (handler zmq_timer_fn) 337 | (ID (* void))) 338 | 339 | (extern int 340 | zmq_timers_cancel 341 | (timers (* void)) 342 | (timer_id int)) 343 | 344 | (extern int 345 | zmq_timers_set_interval 346 | (timers (* void)) 347 | (timer_id int) 348 | (interval size_t)) 349 | 350 | (extern int 351 | zmq_timers_reset 352 | (timers (* void)) 353 | (timer_id int)) 354 | 355 | (extern long 356 | zmq_timers_timeout 357 | (timers (* void))) 358 | 359 | (extern int 360 | zmq_timers_execute 361 | (timers (* void))) 362 | 363 | (extern int 364 | zmq_unbind 365 | (socket (* void)) 366 | (endpoint (* (const char)))) 367 | 368 | (extern void 369 | zmq_version 370 | (major (* int)) 371 | (minor (* int)) 372 | (patch (* int))) 373 | 374 | (extern (* uint8_t) 375 | zmq_z85_decode 376 | (dest (* uint8_t)) 377 | (string (* (const char)))) 378 | 379 | (extern (* char) 380 | zmq_z85_encode 381 | (dest (* char)) 382 | (data (* (const uint8_t))) 383 | (size size_t)) 384 | 385 | 386 | --------------------------------------------------------------------------------