├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── chibi-ffi.scm ├── hello-3d.scm ├── lib.scm ├── main.scm ├── raylib-chibi.c ├── raylib.stub └── screenshot.png /.gitignore: -------------------------------------------------------------------------------- 1 | raylib-chibi 2 | raylib.c 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2020 Vincent Toups 2 | 3 | This license applies to files in this repository unless another license is indicated at the top thereof. 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 6 | 7 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | raylib.c: raylib.stub 2 | ./chibi-ffi.scm raylib.stub 3 | raylib-chibi: raylib.c raylib-chibi.c 4 | cc raylib-chibi.c -o ./raylib-chibi `pkg-config --libs --cflags raylib` `pkg-config --libs --cflags chibi-scheme` 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Raylib-Chibi 2 | ============ 3 | 4 | Rudimentary (but almost 100% complete) bindings to [Raylib][raylib] for [Chibi Scheme][chibi]. 5 | 6 | Requirements 7 | ============ 8 | 9 | Raylib's headers somewhere accessible and Chibi Scheme. 10 | 11 | Building 12 | ======== 13 | 14 | I've only tested the build on OSX, where you can say: 15 | 16 | make raylib-chibi 17 | 18 | Running 19 | ======= 20 | 21 | These bindings operate like Love2D - you start the raylib-chibi 22 | executable and it reads a script which defines your game in 23 | Chibi-Scheme. Eg: 24 | 25 | ./raylib-chibi main.scm 26 | 27 | Where `main.scm` looks like: 28 | 29 | (define (init) 30 | (init-window 800 450 "Hello World") 31 | (set-target-fps 60) 32 | #f) 33 | 34 | (define (draw) 35 | (begin-drawing) 36 | (clear-background (color 255 255 255 255)) 37 | (draw-text "Welcome to Raylib-Chibi" 190 200 20 (color 192 192 192 255)) 38 | (draw-rectangle 220 220 40 40 (color 192 0 0 255)) 39 | (end-drawing)) 40 | 41 | Will generate a nice little red box and a welcome message. 42 | 43 | In general, your script needs an `init` and a `draw` method. 44 | 45 | Completeness 46 | ============ 47 | 48 | Almost the entire Raylib API is bound in more or less the obvious way 49 | (eg, `DrawCircle` becomes `draw-circle`). 50 | 51 | Some exceptions: 52 | 53 | `SetLogTraceCallback` is waiting on a stroke of inspiration about the 54 | right way to do the reverse call. 55 | 56 | Some of the file and directory functions are left out because they 57 | return things tricky to bind and because chibi exposes alternatives. 58 | 59 | `DrawTriangleFan` requires an array of Vector2's which I haven't 60 | decided how to represent yet. 61 | 62 | The most notable issues are with the Shader functions, some of which I 63 | need to learn more about Shaders to bind properly. 64 | 65 | I believe most of the pieces are in place to pass the appropriate 66 | values in, but have to work it out. 67 | 68 | I've also skipped all the VR functions for now as I don't have VR 69 | equipment to work or test with. 70 | 71 | `raylib.stub` is a Scheme program (despite the name) that works along 72 | with the slightly modified `chibi-ffi.scm` from Chibi to generate the 73 | bindings and is thus relatively good documentation about which 74 | functions are bound. 75 | 76 | [raylib]:https://www.raylib.com/ 77 | [chibi]:http://synthcode.com/scheme/chibi 78 | -------------------------------------------------------------------------------- /chibi-ffi.scm: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env chibi-scheme 2 | 3 | ;; Copyright (c) 2009-2018 Alex Shinn 4 | ;; All rights reserved. 5 | 6 | ;; Redistribution and use in source and binary forms, with or without 7 | ;; modification, are permitted provided that the following conditions 8 | ;; are met: 9 | ;; 1. Redistributions of source code must retain the above copyright 10 | ;; notice, this list of conditions and the following disclaimer. 11 | ;; 2. Redistributions in binary form must reproduce the above copyright 12 | ;; notice, this list of conditions and the following disclaimer in the 13 | ;; documentation and/or other materials provided with the distribution. 14 | ;; 3. The name of the author may not be used to endorse or promote products 15 | ;; derived from this software without specific prior written permission. 16 | 17 | ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 18 | ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 19 | ;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 20 | ;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 21 | ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 22 | ;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 26 | ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | 28 | ;; Note: this evolved as a throw-away script to provide certain core 29 | ;; modules, and so is a mess. Tread carefully. 30 | 31 | ;; Simple C FFI. "chibi-ffi file.stub" will read in the C function 32 | ;; FFI definitions from file.stub and output the appropriate C 33 | ;; wrappers into file.c. You can then compile that file with: 34 | ;; 35 | ;; cc -fPIC -shared file.c -lchibi-scheme 36 | ;; 37 | ;; (or using whatever flags are appropriate to generate shared libs on 38 | ;; your platform) and then the generated .so file can be loaded 39 | ;; directly with load, or portably using (include-shared "file") in a 40 | ;; module definition (note that include-shared uses no suffix). 41 | ;; 42 | ;; Passing the -c/--compile option will attempt to compile the .so 43 | ;; file in a single step. 44 | 45 | ;; The goal of this interface is to make access to C types and 46 | ;; functions easy, without requiring the user to write any C code. 47 | ;; That means the stubber needs to be intelligent about various C 48 | ;; calling conventions and idioms, such as return values passed in 49 | ;; actual parameters. Writing C by hand is still possible, and 50 | ;; several of the core modules provide C interfaces directly without 51 | ;; using the stubber. 52 | 53 | ;; For bootstrapping purposes we depend only on the core language. 54 | (import (chibi)) 55 | 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | ;; globals 58 | 59 | (define *ffi-version* "0.4") 60 | (define *types* '()) 61 | (define *type-getters* '()) 62 | (define *type-setters* '()) 63 | (define *typedefs* '()) 64 | (define *funcs* '()) 65 | (define *methods* '()) 66 | (define *consts* '()) 67 | (define *inits* '()) 68 | (define *clibs* '()) 69 | (define *cflags* '()) 70 | (define *frameworks* '()) 71 | (define *tags* '()) 72 | (define *open-namespaces* '()) 73 | (define *c++?* #f) 74 | (define wdir ".") 75 | (define *post-init-hook* '()) 76 | (define auto-expand-limit (* 10 1024 1024)) 77 | 78 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 79 | ;; type objects 80 | 81 | (define (make-type) (make-vector 18 #f)) 82 | 83 | (define (type-base type) (vector-ref type 0)) 84 | (define (type-free? type) (vector-ref type 1)) 85 | (define (type-const? type) (vector-ref type 2)) 86 | (define (type-null? type) (vector-ref type 3)) 87 | (define (type-pointer? type) (vector-ref type 4)) 88 | (define (type-reference? type) (vector-ref type 5)) 89 | (define (type-struct? type) (vector-ref type 6)) 90 | (define (type-link? type) (vector-ref type 7)) 91 | (define (type-result? type) (vector-ref type 8)) 92 | (define (type-array type) (vector-ref type 9)) 93 | (define (type-value type) (vector-ref type 10)) 94 | (define (type-default? type) (vector-ref type 11)) 95 | (define (type-template type) (vector-ref type 12)) 96 | (define (type-new? type) (vector-ref type 13)) 97 | (define (type-error type) (vector-ref type 14)) 98 | (define (type-address-of? type) (vector-ref type 15)) 99 | (define (type-no-free? type) (vector-ref type 16)) 100 | (define (type-index type) (vector-ref type 17)) 101 | (define (type-index-set! type i) (vector-set! type 17 i)) 102 | 103 | (define (add-post-init-hook fn) 104 | (set! *post-init-hook* (cons fn *post-init-hook*))) 105 | 106 | (define (spec->type type . o) 107 | (let ((res (make-type))) 108 | (if (pair? o) 109 | (type-index-set! res (car o))) 110 | (let lp ((type type)) 111 | (define (next) (if (null? (cddr type)) (cadr type) (cdr type))) 112 | (case (and (pair? type) (car type)) 113 | ((free) 114 | (vector-set! res 1 #t) 115 | (lp (next))) 116 | ((const) 117 | (vector-set! res 2 #t) 118 | (lp (next))) 119 | ((maybe-null) 120 | (vector-set! res 3 #t) 121 | (lp (next))) 122 | ((pointer) 123 | (vector-set! res 4 #t) 124 | (lp (next))) 125 | ((reference) 126 | (vector-set! res 5 #t) 127 | (lp (next))) 128 | ((struct) 129 | (vector-set! res 6 #t) 130 | (lp (next))) 131 | ((link) 132 | (vector-set! res 7 #t) 133 | (lp (next))) 134 | ((result) 135 | (vector-set! res 8 #t) 136 | (lp (next))) 137 | ((array) 138 | (vector-set! res 9 (if (pair? (cddr type)) (car (cddr type)) #t)) 139 | (lp (cadr type))) 140 | ((value) 141 | (vector-set! res 10 (cadr type)) 142 | (lp (cddr type))) 143 | ((default) 144 | (vector-set! res 10 (cadr type)) 145 | (vector-set! res 11 #t) 146 | (lp (cddr type))) 147 | ((template) 148 | (vector-set! res 12 (cadr type)) 149 | (lp (cddr type))) 150 | ((new) 151 | (vector-set! res 13 #t) 152 | (lp (next))) 153 | ((error) 154 | (vector-set! res 8 #t) 155 | (vector-set! res 14 (cadr type)) 156 | (lp (cddr type))) 157 | ((address-of) 158 | (vector-set! res 15 #t) 159 | (lp (next))) 160 | ((no-free) 161 | (vector-set! res 16 #t) 162 | (lp (next))) 163 | (else 164 | (let ((base (if (and (pair? type) (null? (cdr type))) 165 | (car type) 166 | type))) 167 | (vector-set! res 0 base) 168 | res)))))) 169 | 170 | (define (parse-type type . o) 171 | (cond 172 | ((vector? type) 173 | (if (and (pair? o) (car o)) 174 | (let ((res (vector-copy type))) 175 | (type-index-set! res (car o)) 176 | res) 177 | type)) 178 | (else 179 | (apply spec->type type o)))) 180 | 181 | (define (type-auto-expand? type) 182 | (and (pair? (type-array type)) 183 | (memq 'auto-expand (type-array type)))) 184 | 185 | (define (type-index-string type) 186 | (if (integer? (type-index type)) 187 | (number->string (type-index type)) 188 | "")) 189 | 190 | (define (struct-fields ls) 191 | (let lp ((ls ls) (res '())) 192 | (cond ((not (pair? ls)) (reverse res)) 193 | ((symbol? (car ls)) (lp (if (pair? (cdr ls)) (cddr ls) (cdr ls)) res)) 194 | (else (lp (cdr ls) (cons (car ls) res)))))) 195 | 196 | (define (lookup-type type) 197 | (or (assq type *types*) 198 | (assq type *typedefs*))) 199 | 200 | (define (type-field-type type field) 201 | (cond 202 | ((lookup-type (type-base (parse-type type))) 203 | => (lambda (x) 204 | (let lp ((ls (struct-fields (cdr x)))) 205 | (cond 206 | ((null? ls) #f) 207 | ((eq? field (caar ls)) (car (cdar ls))) 208 | (else (lp (cdr ls))))))) 209 | (else 210 | #f))) 211 | 212 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 213 | ;; type predicates 214 | 215 | (define *c-int-types* '()) 216 | (define *c-enum-types* '()) 217 | 218 | (define-syntax define-c-int-type 219 | (syntax-rules () 220 | ((define-c-int-type type) 221 | (if (not (memq 'type *c-int-types*)) 222 | (set! *c-int-types* (cons 'type *c-int-types*))) 223 | #f))) 224 | 225 | (define-syntax define-c-enum 226 | ;; TODO: support conversion to/from symbolic names 227 | (syntax-rules () 228 | ((define-c-enum (scheme-name c-name) . args) 229 | (if (not (assq 'scheme-name *c-enum-types*)) 230 | (set! *c-enum-types* 231 | `((scheme-name . c-name) ,@*c-enum-types*))) 232 | #f) 233 | ((define-c-enum scheme-name . args) 234 | (let ((c-name (mangle 'scheme-name))) 235 | (if (not (assq 'scheme-name *c-enum-types*)) 236 | (set! *c-enum-types* 237 | `((scheme-name . ,c-name) ,@*c-enum-types*))) 238 | #f)))) 239 | 240 | (define (enum-type? type) 241 | (assq type *c-enum-types*)) 242 | 243 | (define (signed-int-type? type) 244 | (or (memq type '(signed-char short int long s8 s16 s32 s64)) 245 | (memq type *c-int-types*) 246 | (enum-type? type))) 247 | 248 | (define (unsigned-int-type? type) 249 | (memq type '(unsigned-char unsigned-short unsigned unsigned-int unsigned-long 250 | size_t off_t time_t clock_t dev_t ino_t mode_t nlink_t 251 | uid_t gid_t pid_t blksize_t blkcnt_t sigval_t 252 | u1 u8 u16 u32 u64))) 253 | 254 | (define (int-type? type) 255 | (or (signed-int-type? type) (unsigned-int-type? type))) 256 | 257 | (define (float-type? type) 258 | (memq type '(float double long-double long-long-double f32 f64))) 259 | 260 | (define (string-type? type) 261 | (or (memq type '(char* string env-string non-null-string)) 262 | (and (vector? type) 263 | (type-array type) 264 | (not (type-pointer? type)) 265 | (eq? 'char (type-base type))))) 266 | 267 | (define (port-type? type) 268 | (memq type '(port input-port output-port input-output-port))) 269 | 270 | (define (error-type? type) 271 | (or (type-error type) 272 | (memq (type-base type) 273 | '(errno status-bool non-null-string non-null-pointer)))) 274 | 275 | (define (array-type? type) 276 | (and (type-array type) (not (eq? 'char (type-base type))))) 277 | 278 | (define (basic-type? type) 279 | (let ((type (parse-type type))) 280 | (and (not (type-array type)) 281 | (not (void-pointer-type? type)) 282 | (not (lookup-type (type-base type)))))) 283 | 284 | (define (void-pointer-type? type) 285 | (or (and (eq? 'void (type-base type)) (type-pointer? type)) 286 | (eq? 'void* (type-base type)))) 287 | 288 | (define (uniform-vector-type-code type) 289 | (case type 290 | ((u1vector) 'SEXP_U1) 291 | ((u8vector) 'SEXP_U8) 292 | ((s8vector) 'SEXP_S8) 293 | ((u16vector) 'SEXP_U16) 294 | ((s16vector) 'SEXP_S16) 295 | ((u32vector) 'SEXP_U32) 296 | ((s32vector) 'SEXP_S32) 297 | ((u64vector) 'SEXP_U64) 298 | ((s64vector) 'SEXP_S64) 299 | ((f32vector) 'SEXP_F32) 300 | ((f64vector) 'SEXP_F64) 301 | ((c64vector) 'SEXP_C64) 302 | ((c128vector) 'SEXP_C128) 303 | (else #f))) 304 | 305 | (define (uniform-vector-type? type) 306 | (or (eq? type 'uvector) 307 | (and (uniform-vector-type-code type) #t))) 308 | 309 | (define (uniform-vector-ctype type) 310 | (case type 311 | ((uvector) "sexp") 312 | ((u1vector) "char*") 313 | ((u8vector) "unsigned char*") 314 | ((s8vector) "signed char*") 315 | ((u16vector) "unsigned short*") 316 | ((s16vector) "signed short*") 317 | ((u32vector) "unsigned int*") 318 | ((s32vector) "signed int*") 319 | ((u64vector) "sexp_uint_t*") 320 | ((s64vector) "sexp_sint_t*") 321 | ((f32vector) "float*") 322 | ((f64vector) "double*") 323 | ((c64vector) "float*") 324 | ((c128vector) "double*") 325 | (else #f))) 326 | 327 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 328 | ;; function objects 329 | 330 | (define (parse-func func . o) 331 | (if (not (and (= 3 (length func)) 332 | (or (identifier? (cadr func)) 333 | (and (list? (cadr func)) 334 | (<= 1 (length (cadr func)) 3) 335 | (every (lambda (x) (or (identifier? x) (not x) (string? x))) 336 | (cadr func)))) 337 | (list? (car (cddr func))))) 338 | (error "bad function definition" func)) 339 | (let* ((method? (and (pair? o) (car o))) 340 | (ret-type (parse-type (car func))) 341 | (scheme-name (if (pair? (cadr func)) (car (cadr func)) (cadr func))) 342 | (c-name (if (pair? (cadr func)) 343 | (cadr (cadr func)) 344 | (mangle scheme-name))) 345 | (stub-name (if (and (pair? (cadr func)) (pair? (cddr (cadr func)))) 346 | (car (cddr (cadr func))) 347 | (generate-stub-name scheme-name)))) 348 | (let lp ((ls (if (equal? (car (cddr func)) '(void)) '() (car (cddr func)))) 349 | (i 0) 350 | (results '()) 351 | (c-args '()) 352 | (s-args '())) 353 | (cond 354 | ((null? ls) 355 | (vector scheme-name c-name stub-name ret-type 356 | (reverse results) (reverse c-args) (reverse s-args) 357 | method?)) 358 | (else 359 | (let ((type (parse-type (car ls) i))) 360 | (cond 361 | ((type-result? type) 362 | (lp (cdr ls) (+ i 1) (cons type results) (cons type c-args) s-args)) 363 | ((and (type-value type) (not (type-default? type))) 364 | (lp (cdr ls) (+ i 1) results (cons type c-args) s-args)) 365 | (else 366 | (lp (cdr ls) (+ i 1) results (cons type c-args) (cons type s-args))) 367 | ))))))) 368 | 369 | (define (func-scheme-name func) (vector-ref func 0)) 370 | (define (func-c-name func) (vector-ref func 1)) 371 | (define (func-stub-name func) (vector-ref func 2)) 372 | (define (func-ret-type func) (vector-ref func 3)) 373 | (define (func-results func) (vector-ref func 4)) 374 | (define (func-c-args func) (vector-ref func 5)) 375 | (define (func-scheme-args func) (vector-ref func 6)) 376 | (define (func-method? func) (vector-ref func 7)) 377 | 378 | (define (func-stub-name-set! func x) (vector-set! func 2 x)) 379 | 380 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 381 | ;; utilities 382 | 383 | (define (cat . args) 384 | (for-each (lambda (x) (if (procedure? x) (x) (display x))) args)) 385 | 386 | (define (join ls . o) 387 | (if (pair? ls) 388 | (let ((sep (if (pair? o) (car o) " "))) 389 | (let lp ((ls ls)) 390 | (if (pair? (cdr ls)) 391 | (cat (car ls) sep (lambda () (lp (cdr ls)))) 392 | (cat (car ls))))) 393 | "")) 394 | 395 | (define (x->string x) 396 | (cond ((string? x) x) 397 | ((symbol? x) (symbol->string x)) 398 | ((number? x) (number->string x)) 399 | (else (error "non-stringable object" x)))) 400 | 401 | (define (filter pred ls) 402 | (cond ((null? ls) '()) 403 | ((pred (car ls)) (cons (car ls) (filter pred (cdr ls)))) 404 | (else (filter pred (cdr ls))))) 405 | 406 | (define (remove pred ls) 407 | (cond ((null? ls) '()) 408 | ((pred (car ls)) (remove pred (cdr ls))) 409 | (else (cons (car ls) (remove pred (cdr ls)))))) 410 | 411 | (define (strip-extension path) 412 | (let lp ((i (- (string-length path) 1))) 413 | (cond ((<= i 0) path) 414 | ((eq? #\. (string-ref path i)) (substring path 0 i)) 415 | (else (lp (- i 1)))))) 416 | 417 | (define (string-concatenate-reverse ls) 418 | (cond ((null? ls) "") 419 | ((null? (cdr ls)) (car ls)) 420 | (else (string-concatenate (reverse ls))))) 421 | 422 | (define (string-replace str c r) 423 | (let ((len (string-length str))) 424 | (let lp ((from 0) (i 0) (res '())) 425 | (define (collect) (if (= i from) res (cons (substring str from i) res))) 426 | (cond 427 | ((>= i len) (string-concatenate-reverse (collect))) 428 | ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect)))) 429 | (else (lp from (+ i 1) res)))))) 430 | 431 | (define (string-split str c . o) 432 | (let ((test? 433 | (if (procedure? c) 434 | c 435 | (lambda (char) (eqv? char c)))) 436 | (start (if (pair? o) (car o) 0)) 437 | (end (string-length str))) 438 | (let lp ((from start) (i start) (res '())) 439 | (define (collect) (if (= i from) res (cons (substring str from i) res))) 440 | (cond 441 | ((>= i end) (reverse (collect))) 442 | ((test? (string-ref str i)) (lp (+ i 1) (+ i 1) (collect))) 443 | (else (lp from (+ i 1) res)))))) 444 | 445 | (define (string-scan c str . o) 446 | (let ((end (string-length str))) 447 | (let lp ((i (if (pair? o) (car o) 0))) 448 | (cond ((>= i end) #f) 449 | ((eqv? c (string-ref str i)) i) 450 | (else (lp (+ i 1))))))) 451 | 452 | (define (string-downcase str) 453 | (list->string (map char-downcase (string->list str)))) 454 | 455 | (define (with-output-to-string thunk) 456 | (call-with-output-string 457 | (lambda (out) 458 | (let ((old-out (current-output-port))) 459 | (current-output-port out) 460 | (thunk) 461 | (current-output-port old-out))))) 462 | 463 | (define (warn msg . args) 464 | (let ((err (current-error-port))) 465 | (display "WARNING: " err) 466 | (display msg err) 467 | (if (pair? args) (display ":" err)) 468 | (for-each (lambda (x) (display " " err) (write x err)) args) 469 | (newline err))) 470 | 471 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 472 | ;; naming 473 | 474 | (define (c-char? c) 475 | (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?)))) 476 | 477 | (define (c-escape str) 478 | (let ((len (string-length str))) 479 | (let lp ((from 0) (i 0) (res '())) 480 | (define (collect) (if (= i from) res (cons (substring str from i) res))) 481 | (cond 482 | ((>= i len) (string-concatenate-reverse (collect))) 483 | ((not (c-char? (string-ref str i))) 484 | (lp (+ i 1) (+ i 1) 485 | `("_" ,(number->string (char->integer (string-ref str i)) 16) 486 | ,@(collect)))) 487 | (else (lp from (+ i 1) res)))))) 488 | 489 | (define (mangle x) 490 | (string-replace 491 | (string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p") 492 | #\! "_x")) 493 | 494 | (define (generate-stub-name sym) 495 | (string-append "sexp_" (mangle sym) "_stub")) 496 | 497 | (define (type-id-name sym) 498 | (string-append "sexp_" (mangle sym) "_type_obj")) 499 | 500 | (define (make-integer x) 501 | (case x 502 | ((-1) "SEXP_NEG_ONE") ((0) "SEXP_ZERO") ((1) "SEXP_ONE") 503 | ((2) "SEXP_TWO") ((3) "SEXP_THREE") ((4) "SEXP_FOUR") 504 | ((5) "SEXP_FIVE") ((6) "SEXP_SIX") ((7) "SEXP_SEVEN") 505 | ((8) "SEXP_EIGHT") ((9) "SEXP_NINE") ((10) "SEXP_TEN") 506 | (else (string-append "sexp_make_fixnum(" (x->string x) ")")))) 507 | 508 | (define (string-scan-right str ch) 509 | (let lp ((i (string-cursor-end str))) 510 | (let ((i2 (string-cursor-prev str i))) 511 | (cond ((string-cursorsymbol 517 | (let* ((x (x->string x)) 518 | (i (string-scan-right x #\:))) 519 | (if (> i 0) 520 | (substring-cursor x i) 521 | x)))) 522 | 523 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 524 | ;; .stub file interface 525 | 526 | (define (ffi-include file) 527 | (load file (current-environment))) 528 | 529 | (define (c-link lib) 530 | (set! *clibs* (cons lib *clibs*))) 531 | 532 | (define (c-framework lib) 533 | (set! *frameworks* (cons lib *frameworks*))) 534 | 535 | (define (c-flags-from-script cmd) 536 | (eval '(import (chibi process)) (current-environment)) 537 | (let ((string-null? (lambda (str) (equal? str ""))) 538 | (process->string (eval 'process->string (current-environment)))) 539 | (set! *cflags* 540 | (append *cflags* 541 | (filter 542 | (lambda (x) (not (string-null? x))) 543 | (string-split (process->string cmd) char-whitespace?)))))) 544 | 545 | (define (c-declare . args) 546 | (apply cat args) 547 | (newline)) 548 | 549 | (define (c-include header) 550 | (cat "\n#include \"" header "\"\n")) 551 | 552 | (define (c-system-include header) 553 | (cat "\n#include <" header ">\n")) 554 | 555 | (define (c-include-verbatim file) 556 | (call-with-input-file (if (eqv? #\/ (string-ref file 0)) 557 | file 558 | (string-append wdir "/" file)) 559 | (lambda (in) 560 | (let lp () 561 | (let ((c (read-char in))) 562 | (cond 563 | ((not (eof-object? c)) 564 | (write-char c) 565 | (lp)))))))) 566 | 567 | (define (c-init x) 568 | (set! *inits* (cons x *inits*))) 569 | 570 | (define (parse-struct-like ls) 571 | (let lp ((ls ls) (res '())) 572 | (cond 573 | ((null? ls) 574 | (reverse res)) 575 | ((symbol? (car ls)) 576 | (lp (cddr ls) (cons (cadr ls) (cons (car ls) res)))) 577 | ((pair? (car ls)) 578 | (lp (cdr ls) (cons (cons (parse-type (caar ls)) (cdar ls)) res))) 579 | (else 580 | (lp (cdr ls) (cons (car ls) res)))))) 581 | 582 | (define-syntax define-struct-like 583 | (er-macro-transformer 584 | (lambda (expr rename compare) 585 | (set! *types* 586 | `((,(cadr expr) 587 | ,@(parse-struct-like (cddr expr))) 588 | ,@*types*)) 589 | (set! *tags* `(,(type-id-name (cadr expr)) ,@*tags*)) 590 | #f))) 591 | 592 | (define-syntax define-c-struct 593 | (er-macro-transformer 594 | (lambda (expr rename compare) 595 | `(define-struct-like ,(cadr expr) type: struct ,@(cddr expr))))) 596 | 597 | (define-syntax define-c-class 598 | (er-macro-transformer 599 | (lambda (expr rename compare) 600 | `(define-struct-like ,(cadr expr) type: class ,@(cddr expr))))) 601 | 602 | (define-syntax define-c-union 603 | (er-macro-transformer 604 | (lambda (expr rename compare) 605 | `(define-struct-like ,(cadr expr) type: union ,@(cddr expr))))) 606 | 607 | (define-syntax define-c-type 608 | (er-macro-transformer 609 | (lambda (expr rename compare) 610 | `(define-struct-like ,(cadr expr) ,@(cddr expr))))) 611 | 612 | (define-syntax declare-c-struct 613 | (er-macro-transformer 614 | (lambda (expr rename compare) 615 | `(define-struct-like ,(cadr expr) type: struct imported?: #t)))) 616 | 617 | (define-syntax declare-c-class 618 | (er-macro-transformer 619 | (lambda (expr rename compare) 620 | `(define-struct-like ,(cadr expr) type: class imported?: #t)))) 621 | 622 | (define-syntax declare-c-union 623 | (er-macro-transformer 624 | (lambda (expr rename compare) 625 | `(define-struct-like ,(cadr expr) type: union imported?: #t)))) 626 | 627 | (define-syntax define-c 628 | (er-macro-transformer 629 | (lambda (expr rename compare) 630 | (set! *funcs* (cons (parse-func (cdr expr)) *funcs*)) 631 | #f))) 632 | 633 | (define-syntax define-c-const 634 | (er-macro-transformer 635 | (lambda (expr rename compare) 636 | (let ((type (parse-type (cadr expr)))) 637 | (for-each (lambda (x) (set! *consts* (cons (list type x) *consts*))) 638 | (cddr expr)))))) 639 | 640 | ;; custom strerror which reports constants as their names 641 | (define-syntax define-c-strerror 642 | (er-macro-transformer 643 | (lambda (expr rename compare) 644 | (let ((name (cadr expr)) 645 | (errnos (cddr expr))) 646 | `(,(rename 'c-declare) 647 | ,(string-concatenate 648 | `("\nchar* " ,(x->string name) "(const int err) { 649 | static char buf[64]; 650 | switch (err) { 651 | " 652 | ,@(map (lambda (errno) 653 | (let ((e (x->string errno))) 654 | (string-append " case " e ": return \"" e "\";\n"))) 655 | errnos) 656 | 657 | " } 658 | sprintf(buf, \"unknown error: %d\", err); 659 | return buf; 660 | }"))))))) 661 | 662 | (define-syntax c-typedef 663 | (er-macro-transformer 664 | (lambda (expr rename compare) 665 | (let ((type (parse-type (cadr expr))) 666 | (name (car (cddr expr)))) 667 | (set! *typedefs* `((,name ,@type) ,@*typedefs*)) 668 | `(,(rename 'cat) "typedef " ,(type-c-name type) " " ',name ";\n"))))) 669 | 670 | (define (c++) 671 | (set! *c++?* #t)) 672 | 673 | (define (ensure-c++ name) 674 | (cond 675 | ((not *c++?*) 676 | (display "WARNING: assuming c++ mode from " (current-error-port)) 677 | (display name (current-error-port)) 678 | (display " - use (c++) to make this explicit\n" (current-error-port)) 679 | (c++)))) 680 | 681 | (define-syntax c++-namespace 682 | (er-macro-transformer 683 | (lambda (expr rename compare) 684 | (ensure-c++ 'c++-namespace) 685 | (let ((namespace (cadr expr))) 686 | (cond 687 | ((null? (cddr expr)) 688 | (set! *open-namespaces* (cons namespace *open-namespaces*)) 689 | `(,(rename 'cat) "namespace " ',namespace ";\n")) 690 | (else 691 | `(,(rename 'begin) 692 | (,(rename 'cat) "namespace " ',namespace " {\n") 693 | ,@(cddr expr) 694 | (,(rename 'cat) "} // namespace " ',namespace "\n\n")))))))) 695 | 696 | (define-syntax c++-using 697 | (er-macro-transformer 698 | (lambda (expr rename compare) 699 | (ensure-c++ 'c++-using) 700 | `(,(rename 'cat) "using " ',(cadr expr) ";\n")))) 701 | 702 | (define-syntax define-c++-method 703 | (er-macro-transformer 704 | (lambda (expr rename compare) 705 | (ensure-c++ 'define-c++-method) 706 | (let* ((class (cadr expr)) 707 | (ret-type (car (cddr expr))) 708 | (name (cadr (cddr expr))) 709 | (meths (map (lambda (x) 710 | (parse-func `(,ret-type ,name (,class ,@x)) #t)) 711 | (cddr (cddr expr))))) 712 | (set! *methods* (cons (cons name meths) *methods*)))))) 713 | 714 | (define-syntax define-c++-constructor 715 | (er-macro-transformer 716 | (lambda (expr rename compare) 717 | (ensure-c++ 'define-c++-constructor) 718 | (set! *funcs* 719 | (cons (parse-func `((new ,(if (pair? (cadr expr)) 720 | (cadr (cadr expr)) 721 | (cadr expr))) 722 | ,(cadr expr) 723 | ,@(cddr expr))) 724 | *funcs*)) 725 | #f))) 726 | 727 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 728 | ;; C code generation 729 | 730 | (define (type-predicate type) 731 | (let ((base (type-base (parse-type type)))) 732 | (cond 733 | ((int-type? base) "sexp_exact_integerp") 734 | ((float-type? base) "sexp_flonump") 735 | ((string-type? base) "sexp_stringp") 736 | (else 737 | (case base 738 | ((bytevector u8vector) "sexp_bytesp") 739 | ((char) "sexp_charp") 740 | ((bool boolean status-bool) "sexp_booleanp") 741 | ((port) "sexp_portp") 742 | ((input-port) "sexp_iportp") 743 | ((output-port) "sexp_oportp") 744 | ((input-output-port) "sexp_ioportp") 745 | ((fileno fileno-nonblock) "sexp_filenop") 746 | ((uvector) "sexp_uvectorp") 747 | ((u1vector) "sexp_u1vectorp") 748 | ((s8vector) "sexp_s8vectorp") 749 | ((u16vector) "sexp_u16vectorp") 750 | ((s16vector) "sexp_s16vectorp") 751 | ((u32vector) "sexp_u32vectorp") 752 | ((s32vector) "sexp_s32vectorp") 753 | ((u64vector) "sexp_u64vectorp") 754 | ((s64vector) "sexp_s64vectorp") 755 | ((f32vector) "sexp_f32vectorp") 756 | ((f64vector) "sexp_f64vectorp") 757 | ((c64vector) "sexp_c64vectorp") 758 | ((c128vector) "sexp_c128vectorp") 759 | (else #f)))))) 760 | 761 | (define (type-name type) 762 | (let ((base (type-base (parse-type type)))) 763 | (cond 764 | ((int-type? base) "integer") 765 | ((float-type? base) "flonum") 766 | ((memq base '(bool boolean status-bool)) (if *c++?* "bool" "int")) 767 | (else base)))) 768 | 769 | (define (type-id-number type . o) 770 | (let ((base (type-base type))) 771 | (cond 772 | ((int-type? base) "SEXP_FIXNUM") 773 | ((float-type? base) "SEXP_FLONUM") 774 | ((string-type? base) "SEXP_STRING") 775 | ((memq base '(bytevector u8vector)) "SEXP_BYTES") 776 | ((eq? base 'char) "SEXP_CHAR") 777 | ((memq base '(bool boolean status-bool)) "SEXP_BOOLEAN") 778 | ((eq? base 'string) "SEXP_STRING") 779 | ((eq? base 'symbol) "SEXP_SYMBOL") 780 | ((eq? base 'pair) "SEXP_PAIR") 781 | ((eq? base 'port) "SEXP_IPORT") 782 | ((eq? base 'input-port) "SEXP_IPORT") 783 | ((eq? base 'output-port) "SEXP_OPORT") 784 | ((eq? base 'input-output-port) "SEXP_IPORT") 785 | ((memq base '(fileno fileno-nonblock)) "SEXP_FILENO") 786 | ((uniform-vector-type? base) 787 | "SEXP_UNIFORM_VECTOR") 788 | ((void-pointer-type? type) "SEXP_CPOINTER") 789 | ((lookup-type base) 790 | ;; (string-append "sexp_type_tag(" (type-id-name base) ")") 791 | (let ((i (type-index type))) 792 | (cond 793 | ((not i) 794 | ;;(warn "type-id-number on unknown arg" type) 795 | (if (and (pair? o) (car o)) 796 | "sexp_unbox_fixnum(sexp_opcode_return_type(self))" 797 | (string-append "sexp_type_tag(" (type-id-name base) ")"))) 798 | ((< i 3) 799 | (string-append 800 | "sexp_unbox_fixnum(sexp_opcode_arg" 801 | (number->string (+ i 1)) "_type(self))")) 802 | (else 803 | (string-append 804 | "sexp_unbox_fixnum(sexp_vector_ref(sexp_opcode_argn_type(self), " 805 | (make-integer (- i 3)) "))"))))) 806 | (else "SEXP_OBJECT")))) 807 | 808 | (define (type-id-value type . o) 809 | (cond 810 | ((eq? 'void (type-base type)) 811 | "SEXP_VOID") 812 | (else 813 | (make-integer (apply type-id-number type o))))) 814 | 815 | (define (type-id-init-value type) 816 | (cond 817 | ((lookup-type (type-base type)) 818 | (make-integer 819 | (string-append "sexp_type_tag(" (type-id-name (type-base type)) ")"))) 820 | (else 821 | (type-id-value type)))) 822 | 823 | (define (c-array-length type) 824 | (if (memq 'result (type-array type)) 825 | "sexp_unbox_fixnum(res)" 826 | "-1")) 827 | 828 | (define (c-type-free? type) 829 | (or (type-free? type) 830 | (type-new? type) 831 | (and (type-result? type) 832 | (not (basic-type? type)) 833 | (not (type-no-free? type))))) 834 | 835 | (define (c->scheme-converter type val . o) 836 | (let ((base (type-base type))) 837 | (cond 838 | ((and (eq? base 'void) (not (type-pointer? type))) 839 | (cat "((" val "), SEXP_VOID)")) 840 | ((or (eq? base 'sexp) (error-type? type)) 841 | (cat val)) 842 | ((memq base '(bool boolean status-bool)) 843 | (cat "sexp_make_boolean(" val ")")) 844 | ((eq? base 'time_t) 845 | (cat "sexp_make_integer(ctx, sexp_shift_epoch(" val "))")) 846 | ((unsigned-int-type? base) 847 | (cat "sexp_make_unsigned_integer(ctx, " val ")")) 848 | ((signed-int-type? base) 849 | (cat "sexp_make_integer(ctx, " val ")")) 850 | ((float-type? base) 851 | (cat "sexp_make_flonum(ctx, " val ")")) 852 | ((eq? base 'char) 853 | (if (type-array type) 854 | (cat "sexp_c_string(ctx, " val ", " (c-array-length type) ")") 855 | (cat "sexp_make_character(" val ")"))) 856 | ((eq? 'env-string base) 857 | (cat "(p=strchr(" val ", '=') ? " 858 | "sexp_cons(ctx, str=sexp_c_string(ctx, " val 859 | ", p - " val "), str=sexp_c_string(ctx, p, -1))" 860 | " : sexp_cons(ctx, str=" val ", SEXP_FALSE)")) 861 | ((string-type? base) 862 | (if (and *c++?* (eq? 'string base)) 863 | (cat "sexp_c_string(ctx, " val ".c_str(), " val ".size())") 864 | (cat "sexp_c_string(ctx, " val ", " (c-array-length type) ")"))) 865 | ((memq base '(bytevector u8vector)) 866 | (if *c++?* 867 | (cat "sexp_string_to_bytes(ctx, sexp_c_string(ctx, " 868 | val ".data(), " val ".size()))") 869 | (cat "sexp_string_to_bytes(ctx, sexp_c_string(ctx, " val ", " 870 | (c-array-length type val) "))"))) 871 | ((eq? 'input-port base) 872 | (cat "sexp_make_non_null_input_port(ctx, " val ", SEXP_FALSE)")) 873 | ((eq? 'output-port base) 874 | (cat "sexp_make_non_null_output_port(ctx, " val ", SEXP_FALSE)")) 875 | ((eq? 'input-output-port base) 876 | (cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)")) 877 | ((memq base '(fileno fileno-nonblock)) 878 | (cat "sexp_make_fileno(ctx, sexp_make_fixnum(" val "), SEXP_FALSE)")) 879 | ((eq? base 'uvector) 880 | val) 881 | ((uniform-vector-type? base) 882 | (cat "sexp_make_cuvector(ctx, " (uniform-vector-type-code base) ", " 883 | val ", " (if (c-type-free? type) 1 0) ")")) 884 | (else 885 | (let ((ctype (lookup-type base)) 886 | (void*? (void-pointer-type? type))) 887 | (cond 888 | ((or ctype void*?) 889 | (cat "sexp_make_cpointer(ctx, " 890 | (if void*? 891 | "SEXP_CPOINTER" 892 | ;;(string-append "sexp_type_tag(" (type-id-name base) ")") 893 | (type-id-number type #t)) 894 | ", " 895 | val ", " (or (and (pair? o) (car o)) "SEXP_FALSE") ", " 896 | (if (c-type-free? type) 1 0) 897 | ")")) 898 | (else 899 | (error "unknown type" base)))))))) 900 | 901 | (define (scheme->c-converter type val) 902 | (let* ((type (parse-type type)) 903 | (base (type-base type))) 904 | (cond 905 | ((eq? base 'sexp) 906 | (cat val)) 907 | ((memq base '(bool boolean status-bool)) 908 | (cat "sexp_truep(" val ")")) 909 | ((eq? base 'time_t) 910 | (cat "sexp_unshift_epoch(sexp_uint_value(" val "))")) 911 | ((enum-type? base) 912 | => (lambda (x) (cat "((" (cdr x) ")sexp_sint_value(" val "))"))) 913 | ((signed-int-type? base) 914 | (cat "sexp_sint_value(" val ")")) 915 | ((unsigned-int-type? base) 916 | (cat "sexp_uint_value(" val ")")) 917 | ((float-type? base) 918 | (cat "sexp_flonum_value(" val ")")) 919 | ((eq? base 'char) 920 | (cat "sexp_unbox_character(" val ")")) 921 | ((eq? base 'env-string) 922 | (cat "sexp_concat_env_string(" val ")")) 923 | ((string-type? base) 924 | (cat (if (type-null? type) 925 | "sexp_string_maybe_null_data" 926 | "sexp_string_data") 927 | "(" val ")")) 928 | ((memq base '(bytevector u8vector)) 929 | (cat (if (type-null? type) 930 | "sexp_bytes_maybe_null_data" 931 | "sexp_bytes_data") 932 | "(" val ")")) 933 | ((eq? base 'port-or-fileno) 934 | (cat "(sexp_portp(" val ") ? sexp_port_fileno(" val ")" 935 | " : sexp_filenop(" val ") ? sexp_fileno_fd(" val ")" 936 | " : sexp_unbox_fixnum(" val "))")) 937 | ((port-type? base) 938 | (cat "sexp_port_stream(" val ")")) 939 | ((memq base '(fileno fileno-nonblock)) 940 | (cat "(sexp_filenop(" val ") ? sexp_fileno_fd(" val ")" 941 | " : sexp_unbox_fixnum(" val "))")) 942 | ((uniform-vector-type? base) 943 | (cat "((" (uniform-vector-ctype base) ") sexp_uvector_data(" val "))")) 944 | (else 945 | (let ((ctype (lookup-type base)) 946 | (void*? (void-pointer-type? type))) 947 | (cond 948 | ((or ctype void*?) 949 | (cat (if (or (type-struct? type) (type-reference? type)) "*" "") 950 | "(" (type-c-name type) ")" 951 | (if (type-address-of? type) "&" "") 952 | (if (type-null? type) 953 | "sexp_cpointer_maybe_null_value" 954 | "sexp_cpointer_value") 955 | "(" val ")")) 956 | (else 957 | (error "unknown type" base)))))))) 958 | 959 | (define (base-type-c-name base) 960 | (case base 961 | ((string env-string non-null-string bytevector u8vector) 962 | (if *c++?* "string" "char*")) 963 | ((fileno fileno-nonblock) "int") 964 | ((u1 u8 u16 u32 u64 s8 s16 s32 s64 f32 f64) 965 | (let ((a 966 | (uniform-vector-ctype 967 | (string->symbol 968 | (string-append (x->string base) "vector"))))) 969 | (substring a 0 (- (string-length a) 1)))) 970 | (else 971 | (if (uniform-vector-type? base) 972 | (uniform-vector-ctype base) 973 | (string-replace (symbol->string base) #\- " "))))) 974 | 975 | (define (type-struct-type type) 976 | (let ((type-spec (lookup-type (if (vector? type) (type-base type) type)))) 977 | (cond ((and type-spec (memq 'type: type-spec)) => cadr) 978 | (else #f)))) 979 | 980 | (define (type-c-name-derefed type) 981 | (let* ((type (parse-type type)) 982 | (base (type-base type)) 983 | (type-spec (lookup-type base)) 984 | (struct-type (type-struct-type type))) 985 | (string-append 986 | (if (type-const? type) "const " "") 987 | (if (and struct-type (not *c++?*)) 988 | (string-append (symbol->string struct-type) " ") 989 | "") 990 | (base-type-c-name base) 991 | (if (type-template type) 992 | (string-append 993 | "<" 994 | (string-concatenate (map type-c-name (type-template type)) ", ") 995 | ">") 996 | "")))) 997 | 998 | (define (type-c-name type) 999 | (let ((type (parse-type type))) 1000 | (string-append 1001 | (type-c-name-derefed type) 1002 | (if (type-struct-type type) "*" "") 1003 | (if (type-pointer? type) "*" "")))) 1004 | 1005 | (define (type-finalizer-name type) 1006 | (let ((name (type-c-name-derefed type))) 1007 | (string-append "sexp_finalize_" (string-replace name #\: "_")))) 1008 | 1009 | (define (check-type arg type) 1010 | (let* ((type (parse-type type)) 1011 | (base (type-base type))) 1012 | (cond 1013 | ((eq? base 'env-string) 1014 | (cat "(sexp_pairp(" arg ") && sexp_stringp(sexp_car(" arg 1015 | ")) && sexp_stringp(sexp_cdr(" arg ")))")) 1016 | ((memq base '(fileno fileno-nonblock)) 1017 | (cat "(sexp_filenop(" arg ") || sexp_fixnump(" arg "))")) 1018 | ((string-type? base) 1019 | (cat 1020 | (if (type-null? type) "(" "") 1021 | (type-predicate type) "(" arg ")" 1022 | (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) 1023 | ((or (eq? base 'char) (int-type? base) (float-type? base) (port-type? base) 1024 | (memq base '(bytevector u8vector)) (uniform-vector-type? base)) 1025 | (cat (type-predicate type) "(" arg ")")) 1026 | ((or (lookup-type base) (void-pointer-type? type)) 1027 | (cat 1028 | (if (type-null? type) "(" "") 1029 | "(sexp_pointerp(" arg ")" 1030 | " && (sexp_pointer_tag(" arg ") == " 1031 | (if (void-pointer-type? type) 1032 | "SEXP_CPOINTER" 1033 | (type-id-number type)) 1034 | "))" 1035 | (lambda () (if (type-null? type) (cat " || sexp_not(" arg "))"))))) 1036 | (else 1037 | (warn "don't know how to check" type) 1038 | (cat "1"))))) 1039 | 1040 | (define (write-validator arg type) 1041 | (let* ((type (parse-type type)) 1042 | (array (type-array type)) 1043 | (base-type (type-base type))) 1044 | (cond 1045 | ((and array (not (string-type? type))) 1046 | (cond 1047 | ((number? array) 1048 | (cat " if (!sexp_listp(ctx, " arg ")" 1049 | " || sexp_unbox_fixnum(sexp_length(ctx, " arg ")) != " array ")\n" 1050 | " return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n"))) 1051 | (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" 1052 | " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" 1053 | " return sexp_xtype_exception(ctx, self, \"not a list of " 1054 | (type-name type) "s\", " arg ");\n") 1055 | (if (not (number? array)) 1056 | (cat " if (! sexp_nullp(res))\n" 1057 | " return sexp_xtype_exception(ctx, self, \"not a list of " 1058 | (type-name type) "s\", " arg ");\n"))) 1059 | ((eq? base-type 'port-or-fileno) 1060 | (cat " if (! (sexp_portp(" arg ") || sexp_filenop(" arg ") || sexp_fixnump(" arg ")))\n" 1061 | " return sexp_xtype_exception(ctx, self, \"not a port or file descriptor\"," arg ");\n")) 1062 | ((or (int-type? base-type) 1063 | (float-type? base-type) 1064 | (string-type? base-type) 1065 | (port-type? base-type) 1066 | (uniform-vector-type? base-type) 1067 | (memq base-type '(bytevector u8vector fileno fileno-nonblock)) 1068 | (and (not array) (eq? 'char base-type))) 1069 | (cat 1070 | " if (! " (lambda () (check-type arg type)) ")\n" 1071 | " return sexp_type_exception(ctx, self, " 1072 | (type-id-number type) ", " arg ");\n")) 1073 | ((or (lookup-type base-type) (void-pointer-type? type)) 1074 | (cat 1075 | " if (! " (lambda () (check-type arg type)) ")\n" 1076 | " return sexp_type_exception(ctx, self, " 1077 | (type-id-number type) ", " arg ");\n")) 1078 | ((eq? 'sexp base-type)) 1079 | ((string-type? type) 1080 | (write-validator arg 'string)) 1081 | ((memq base-type '(bool boolean status-bool))) 1082 | (else 1083 | (warn "don't know how to validate" type))))) 1084 | 1085 | (define (write-parameters args) 1086 | (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args))) 1087 | 1088 | (define (take ls n) 1089 | (let lp ((ls ls) (n n) (res '())) 1090 | (if (zero? n) (reverse res) (lp (cdr ls) (- n 1) (cons (car ls) res))))) 1091 | 1092 | (define max-gc-vars 7) 1093 | 1094 | (define (write-gc-vars ls . o) 1095 | (let ((num-gc-vars (length ls))) 1096 | (cond 1097 | ((zero? num-gc-vars)) 1098 | ((<= num-gc-vars max-gc-vars) 1099 | (cat " sexp_gc_var" num-gc-vars "(") 1100 | (display (car ls)) 1101 | (for-each (lambda (x) (display ", ") (display x)) (cdr ls)) 1102 | (cat ");\n")) 1103 | (else 1104 | (write-gc-vars (take ls max-gc-vars)) 1105 | (let lp ((ls (list-tail ls max-gc-vars)) 1106 | (i (+ max-gc-vars 1))) 1107 | (cond 1108 | ((pair? ls) 1109 | (cat " sexp_gc_var(" (car ls) ", __sexp_gc_preserver" i ");\n") 1110 | (lp (cdr ls) (+ i 1))))))))) 1111 | 1112 | (define (write-gc-preserves ls) 1113 | (let ((num-gc-vars (length ls))) 1114 | (cond 1115 | ((zero? num-gc-vars)) 1116 | ((<= num-gc-vars max-gc-vars) 1117 | (cat " sexp_gc_preserve" num-gc-vars "(ctx") 1118 | (for-each (lambda (x) (display ", ") (display x)) ls) 1119 | (cat ");\n")) 1120 | (else 1121 | (write-gc-preserves (take ls max-gc-vars)) 1122 | (let lp ((ls (list-tail ls max-gc-vars)) 1123 | (i (+ max-gc-vars 1))) 1124 | (cond 1125 | ((pair? ls) 1126 | (cat " sexp_gc_preserve(ctx, " (car ls) 1127 | ", __sexp_gc_preserver" i ");\n") 1128 | (lp (cdr ls) (+ i 1))))))))) 1129 | 1130 | (define (write-gc-release ls) 1131 | (if (pair? ls) 1132 | (cat " sexp_gc_release" (min max-gc-vars (length ls)) "(ctx);\n"))) 1133 | 1134 | (define (get-array-length func x) 1135 | (let ((len (if (pair? (type-array x)) 1136 | (car (reverse (type-array x))) 1137 | (type-array x)))) 1138 | (cond 1139 | ((number? len) 1140 | len) 1141 | (else 1142 | (and func 1143 | (symbol? len) 1144 | (let* ((str (symbol->string len)) 1145 | (len2 (string-length str))) 1146 | (and (> len2 3) 1147 | (string=? "arg" (substring str 0 3)) 1148 | (let ((i (string->number (substring str 3 len2)))) 1149 | (if i 1150 | (let ((y (list-ref (func-c-args func) i))) 1151 | (or (type-value y) len))))))))))) 1152 | 1153 | (define (write-locals func) 1154 | (define (arg-res x) 1155 | (string-append "res" (type-index-string x))) 1156 | (let* ((ret-type (func-ret-type func)) 1157 | (results (func-results func)) 1158 | (scheme-args (func-scheme-args func)) 1159 | (return-res? (not (error-type? ret-type))) 1160 | (preserve-res? (> (+ (length results)) (if return-res? 0 1))) 1161 | (single-res? (and (= 1 (length results)) (not return-res?))) 1162 | (tmp-string? (any (lambda (a) 1163 | (and (type-array a) 1164 | (string-type? (type-base a)))) 1165 | (cons ret-type results))) 1166 | (gc-vars (map arg-res results)) 1167 | (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) 1168 | (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars)) 1169 | (sexps (if preserve-res? '() '("res"))) 1170 | (ints (if (or return-res? 1171 | (memq (type-base ret-type) 1172 | '(status-bool non-null-string non-null-pointer))) 1173 | '() 1174 | '("err"))) 1175 | (ints (if (or (array-type? ret-type) 1176 | (any array-type? results) 1177 | (any array-type? scheme-args)) 1178 | (cons "i" ints) 1179 | ints))) 1180 | (case (type-base ret-type) 1181 | ((status-bool) (cat " bool err;\n")) 1182 | ((non-null-string) (cat " char *err;\n")) 1183 | ((non-null-pointer) (cat " void *err;\n"))) 1184 | (if (type-struct? ret-type) 1185 | (cat " struct " (type-base ret-type) " struct_res;\n" 1186 | " struct " (type-base ret-type) "* ptr_res;\n")) 1187 | (cond 1188 | ((pair? ints) 1189 | (cat " int " (car ints) " = 0" 1190 | (lambda () 1191 | (for-each (lambda (x) (cat ", " x " = 0")) (cdr ints))) 1192 | ";\n"))) 1193 | (if (any (lambda (a) (eq? 'env-string (type-base a))) 1194 | (cons ret-type results)) 1195 | (cat " char *p;\n")) 1196 | (for-each 1197 | (lambda (x) 1198 | (let ((len (get-array-length func x))) 1199 | (cat " " (if (type-const? x) "const " "") 1200 | (type-c-name (type-base x)) " ") 1201 | (if (or (and (type-array x) (not (number? len))) (type-pointer? x)) 1202 | (cat "*")) 1203 | (cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x)) 1204 | (if (number? len) 1205 | (cat "[" len "]")) 1206 | (cond 1207 | ((type-reference? x) 1208 | (cat " = NULL")) 1209 | ((type-error x) 1210 | (cat " = 0"))) 1211 | (cat ";\n") 1212 | (if (or (vector? len) (type-auto-expand? x)) 1213 | (cat " int len" (type-index x) ";\n")) 1214 | (if (type-auto-expand? x) 1215 | (cat " " (type-c-name (type-base x)) 1216 | " *tmp" (type-index-string x) ";\n")))) 1217 | (append (if (or (type-array ret-type) (type-pointer? ret-type)) 1218 | (list ret-type) 1219 | '()) 1220 | results 1221 | (remove type-result? (filter type-array scheme-args)))) 1222 | (for-each 1223 | (lambda (arg) 1224 | (cond 1225 | ((and (type-pointer? arg) (basic-type? arg)) 1226 | (cat " " (if (type-const? arg) "const " "") 1227 | (type-c-name (type-base arg)) 1228 | " tmp" (type-index arg) ";\n")))) 1229 | scheme-args) 1230 | (cond 1231 | ((pair? sexps) 1232 | (cat " sexp " (car sexps)) 1233 | (for-each (lambda (x) (display ", ") (display x)) (cdr sexps)) 1234 | (cat ";\n"))) 1235 | ;; Declare the gc vars. 1236 | (write-gc-vars gc-vars) 1237 | ;; Shortcut returns should come before preserving. 1238 | (write-validators (func-scheme-args func)) 1239 | (write-additional-checks (func-c-args func)) 1240 | ;; Preserve the gc vars. 1241 | (write-gc-preserves gc-vars))) 1242 | 1243 | (define (write-validators args) 1244 | (for-each 1245 | (lambda (a) 1246 | (write-validator (string-append "arg" (type-index-string a)) a)) 1247 | args)) 1248 | 1249 | (define (write-additional-checks args) 1250 | (for-each 1251 | (lambda (a) 1252 | (if (port-type? (type-base a)) 1253 | (cat " if (!sexp_stream_portp(arg" (type-index a) "))\n" 1254 | " return sexp_xtype_exception(ctx, self," 1255 | " \"not a FILE* backed port\", arg" (type-index a) ");\n"))) 1256 | args) 1257 | (for-each 1258 | (lambda (a) 1259 | (if (eq? 'input-port (type-base a)) 1260 | (cat " sexp_check_block_port(ctx, arg" (type-index a) ", 0);\n"))) 1261 | args)) 1262 | 1263 | (define (scheme-procedure->c name) 1264 | (cond 1265 | ((eq? name 'length) 'sexp_length_unboxed) 1266 | ((eq? name 'string-length) 'sexp_string_length) 1267 | ((eq? name 'string-size) 'sexp_string_size) 1268 | ((memq name '(bytevector-length u8vector-length)) 'sexp_bytes_length) 1269 | ((eq? name 'uvector-length) 'sexp_uvector_length) 1270 | (else name))) 1271 | 1272 | (define (write-value func val) 1273 | (cond 1274 | ((find (lambda (x) 1275 | (and (type-array x) 1276 | (type-auto-expand? x) 1277 | (eq? val (get-array-length func x)))) 1278 | (func-c-args func)) 1279 | => (lambda (x) (cat "len" (type-index x)))) 1280 | ((lookup-type val) 1281 | (cat (or (type-struct-type val) "") " " val)) 1282 | ((and (pair? val) (list? val)) 1283 | (write (scheme-procedure->c (car val))) 1284 | (cat 1285 | "(" 1286 | (lambda () 1287 | (cond 1288 | ((pair? (cdr val)) 1289 | (write-value func (cadr val)) 1290 | (for-each (lambda (x) (display ", ") (write-value func x)) (cddr val))))) 1291 | ")")) 1292 | (else 1293 | (write val)))) 1294 | 1295 | (define (write-actual-parameter func arg) 1296 | (cond 1297 | ((or (type-result? arg) (type-array arg)) 1298 | (cat (if (or (type-free? arg) (type-reference? arg) 1299 | (type-address-of? arg) (basic-type? arg) 1300 | ;; a non-pointer, non-basic result needs indirection 1301 | (and (type-result? arg) (not (type-pointer? arg)) 1302 | (not (type-struct-type arg)) (not (basic-type? arg)) 1303 | (not (type-array arg)))) 1304 | "&" 1305 | "") 1306 | "tmp" (type-index arg))) 1307 | ((and (not (type-default? arg)) (type-value arg)) 1308 | => (lambda (x) (write-value func x))) 1309 | ((and (type-pointer? arg) (basic-type? arg)) 1310 | (cat "&tmp" (type-index arg))) 1311 | (else 1312 | (scheme->c-converter 1313 | arg 1314 | (string-append "arg" (type-index-string arg)))))) 1315 | 1316 | (define (write-temporaries func) 1317 | (for-each 1318 | (lambda (a) 1319 | (let ((len (and (type-array a) (get-array-length func a)))) 1320 | (cond 1321 | ((and (type-array a) (or (vector? len) (type-auto-expand? a))) 1322 | (cat " len" (type-index a) " = " 1323 | (lambda () 1324 | (if (number? len) (cat len) (scheme->c-converter 'int len))) 1325 | ";\n" 1326 | " tmp" (type-index a) " = buf" (type-index a) ";\n"))) 1327 | (cond 1328 | ((and (not (type-result? a)) (type-array a) (not (string-type? a))) 1329 | (if (not (number? (type-array a))) 1330 | (if (and *c++?* (type-new? a)) 1331 | (cat " tmp" (type-index a) 1332 | " = new " (type-c-name-derefed (type-base a)) "();\n") 1333 | (cat " tmp" (type-index a) 1334 | " = (" (if (type-const? a) "const " "") 1335 | (type-c-name (type-base a)) "*) " 1336 | "calloc((sexp_unbox_fixnum(sexp_length(ctx, arg" 1337 | (type-index a) 1338 | "))+1), sizeof(tmp" (type-index a) "[0]));\n"))) 1339 | (cat " for (i=0, res=arg" (type-index a) 1340 | "; sexp_pairp(res); res=sexp_cdr(res), i++) {\n" 1341 | " tmp" (type-index a) "[i] = " 1342 | (lambda () (scheme->c-converter (type-base a) "sexp_car(res)")) 1343 | ";\n" 1344 | " }\n") 1345 | (if (not (number? (type-array a))) 1346 | (cat " tmp" (type-index a) "[i] = 0;\n"))) 1347 | ((and (type-result? a) (not (basic-type? a)) 1348 | (not (type-free? a)) ;;(not (type-pointer? a)) 1349 | (not (type-reference? a)) 1350 | (not (type-auto-expand? a)) 1351 | (or (not (type-array a)) 1352 | (not (integer? len)))) 1353 | (if (and *c++?* (type-new? a)) 1354 | (cat " tmp" (type-index a) 1355 | " = new " (type-c-name-derefed (type-base a)) "();\n") 1356 | (cat " tmp" (type-index a) " = " 1357 | (lambda () (cat "(" (type-c-name (type-base a)) 1358 | (if (or (type-pointer? a) 1359 | (and (not (int-type? a)) 1360 | (not (type-struct-type a)))) 1361 | "*" 1362 | "") 1363 | ")")) 1364 | " calloc(1, 1 + " 1365 | (if (and (symbol? len) (not (eq? len 'null))) 1366 | (lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len)) 1367 | "*sizeof(tmp" (type-index a) "[0])")) 1368 | (lambda () (cat "sizeof(tmp" (type-index a) "[0])"))) 1369 | ");\n" 1370 | ;; (lambda () 1371 | ;; (if (and (symbol? len) (not (eq? len 'null))) 1372 | ;; (cat " tmp" (type-index a) "[" 1373 | ;; (lambda () (scheme->c-converter 'unsigned-int len)) 1374 | ;; "*sizeof(tmp" (type-index a) "[0])] = 0;\n"))) 1375 | ))) 1376 | ((and (type-result? a) (type-value a)) 1377 | (cat " tmp" (type-index a) " = " 1378 | (lambda () (write-value func (type-value a))) ";\n")) 1379 | ((and (type-pointer? a) (basic-type? a)) 1380 | (cat " tmp" (type-index a) " = " 1381 | (lambda () 1382 | (scheme->c-converter 1383 | a 1384 | (string-append "arg" (type-index-string a)))) 1385 | ";\n"))))) 1386 | (func-c-args func))) 1387 | 1388 | (define (write-call func) 1389 | (let ((ret-type (func-ret-type func)) 1390 | (c-name (func-c-name func)) 1391 | (c-args (func-c-args func))) 1392 | (if (any type-auto-expand? (func-c-args func)) 1393 | (cat " loop:\n")) 1394 | (cat (cond ((error-type? ret-type) " err = ") 1395 | ((type-array ret-type) " tmp = ") 1396 | ((type-struct? ret-type) " struct_res = ") 1397 | (else " res = "))) 1398 | ((if (or (type-array ret-type) 1399 | (type-struct? ret-type)) 1400 | (lambda (t f x) (f)) 1401 | c->scheme-converter) 1402 | ret-type 1403 | (lambda () 1404 | (if (and *c++?* (type-new? ret-type)) 1405 | (cat "new ")) 1406 | (if (func-method? func) 1407 | (cat "(" (lambda () (write-actual-parameter func (car c-args))) 1408 | ")->" c-name) 1409 | (cat c-name)) 1410 | (cat "(") 1411 | (for-each 1412 | (lambda (arg) 1413 | (if (> (type-index arg) (if (func-method? func) 1 0)) (cat ", ")) 1414 | (write-actual-parameter func arg)) 1415 | (if (func-method? func) (cdr c-args) c-args)) 1416 | (cat ")")) 1417 | (cond 1418 | ((find type-link? (func-c-args func)) 1419 | => (lambda (a) (string-append "arg" (type-index-string a)))) 1420 | (else #f))) 1421 | (cat ";\n") 1422 | (if (type-array ret-type) 1423 | (write-result ret-type) 1424 | (write-result-adjustment ret-type)))) 1425 | 1426 | (define (write-result-adjustment result) 1427 | (cond 1428 | ;; new port results are automatically made non-blocking 1429 | ((memq (type-base result) '(input-port output-port input-output-port)) 1430 | (let ((res (string-append "res" (type-index-string result)))) 1431 | (cat "#ifdef SEXP_USE_GREEN_THREADS\n" 1432 | " if (sexp_portp(" res "))\n" 1433 | " fcntl(fileno(sexp_port_stream(" res ")), F_SETFL, O_NONBLOCK " 1434 | " | fcntl(fileno(sexp_port_stream(" res ")), F_GETFL));\n" 1435 | "#endif\n"))) 1436 | ;; a file descriptor result can be automatically made non-blocking 1437 | ;; by specifying a result type of fileno-nonblock 1438 | ((memq (type-base result) '(fileno-nonblock)) 1439 | (let ((res (string-append "res" (type-index-string result)))) 1440 | (cat "#ifdef SEXP_USE_GREEN_THREADS\n" 1441 | " if (sexp_filenop(" res "))\n" 1442 | " fcntl(sexp_fileno_fd(" res "), F_SETFL, O_NONBLOCK " 1443 | " | fcntl(sexp_fileno_fd(" res "), F_GETFL));\n" 1444 | "#endif\n"))) 1445 | ;; non-pointer struct return types need to be copied to the heap 1446 | ((type-struct? result) 1447 | (cat 1448 | " ptr_res = (" (type-c-name result) ") malloc(sizeof(" 1449 | (type-c-name-derefed result) "));\n" 1450 | " memcpy(ptr_res, &struct_res, sizeof(" (type-c-name-derefed result) "));\n" 1451 | " res = sexp_make_cpointer(ctx, sexp_unbox_fixnum(sexp_opcode_return_type(self)), ptr_res, SEXP_FALSE, 0);\n")) 1452 | )) 1453 | 1454 | (define (write-result result . o) 1455 | (let ((res (string-append "res" (type-index-string result))) 1456 | (tmp (string-append "tmp" (type-index-string result)))) 1457 | (cond 1458 | ((and (type-array result) (eq? 'char (type-base result))) 1459 | (cat " " res " = " (lambda () (c->scheme-converter result tmp)) ";\n")) 1460 | ((type-array result) 1461 | (cat " " res " = SEXP_NULL;\n") 1462 | (let ((auto-expand? 1463 | (and (pair? (type-array result)) 1464 | (memq 'auto-expand (type-array result)))) 1465 | (len (if (pair? (type-array result)) 1466 | (car (reverse (type-array result))) 1467 | (type-array result)))) 1468 | (cond 1469 | ((eq? 'null len) 1470 | (cat " for (i=0; " tmp "[i]; i++) {\n" 1471 | " sexp_push(ctx, " res ", " 1472 | (if (eq? 'string (type-base result)) 1473 | "str=" 1474 | (lambda () (cat "SEXP_VOID);\n sexp_car(" res ") = "))) 1475 | (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) 1476 | ");\n" 1477 | " }\n" 1478 | " " res " = sexp_nreverse(ctx, " res ");\n")) 1479 | (else 1480 | (cat " for (i=" (if (and (symbol? len) 1481 | (equal? "arg" 1482 | (substring (symbol->string len) 1483 | 0 3))) 1484 | (string-append 1485 | "sexp_unbox_fixnum(" (symbol->string len) ")") 1486 | len) 1487 | "-1; i>=0; i--) {\n" 1488 | " sexp_push(ctx, " res ", SEXP_VOID);\n" 1489 | " sexp_car(" res ") = " 1490 | (lambda () (c->scheme-converter result (lambda () (cat tmp "[i]")))) 1491 | ";\n" 1492 | " }\n"))))) 1493 | (else 1494 | (cat " " res " = ") 1495 | (apply 1496 | c->scheme-converter 1497 | result 1498 | (string-append "tmp" (type-index-string result)) 1499 | o) 1500 | (cat ";\n"))) 1501 | (write-result-adjustment result))) 1502 | 1503 | (define (write-results func) 1504 | (let* ((error-res (cond ((error-type? (func-ret-type func)) 1505 | (func-ret-type func)) 1506 | ((find type-error (func-c-args func))) 1507 | (else #f))) 1508 | (error-return? (eq? error-res (func-ret-type func))) 1509 | (void-res? (eq? 'void (type-base (func-ret-type func)))) 1510 | (results (remove type-error (func-results func)))) 1511 | (if error-res 1512 | (cat " if (" 1513 | (if (memq (type-base error-res) 1514 | '(status-bool non-null-string non-null-pointer)) 1515 | "!" 1516 | "") 1517 | (if error-return? 1518 | "err" 1519 | (string-append "tmp" (type-index-string error-res))) 1520 | ") {\n" 1521 | (cond 1522 | ((find type-auto-expand? (func-c-args func)) 1523 | => (lambda (a) 1524 | (lambda () 1525 | (let ((len (get-array-length func a)) 1526 | (i (type-index a))) 1527 | (cat " if (len" i " > " auto-expand-limit ") {\n" 1528 | " res = sexp_user_exception(ctx, self, " 1529 | "\"exceeded max auto-expand len in " (func-scheme-name func) "\", SEXP_NULL);\n" 1530 | "} else {\n") 1531 | (if (number? len) 1532 | (cat " if (len" i " != " len ")\n" 1533 | " free(tmp" i ");\n")) 1534 | (cat " len" i " *= 2;\n" 1535 | " tmp" i " = " 1536 | (lambda () (cat "(" (type-c-name (type-base a)) 1537 | (if (or (type-pointer? a) 1538 | (and (not *c++?*) 1539 | (string-type? a))) 1540 | "*" 1541 | "") 1542 | ")")) 1543 | " calloc(len" i ", sizeof(tmp" i "[0]));\n" 1544 | " goto loop;\n" 1545 | "}\n"))))) 1546 | (error-return? 1547 | ;; TODO: free other results 1548 | " res = SEXP_FALSE;\n") 1549 | (else 1550 | (lambda () 1551 | (cat " res = sexp_user_exception(ctx, self, " 1552 | (type-error error-res) "(tmp" 1553 | (type-index-string error-res) 1554 | "), SEXP_NULL);\n")))) 1555 | " } else {\n")) 1556 | (if (null? results) 1557 | (if (and error-res error-return?) 1558 | (cat " res = SEXP_TRUE;\n")) 1559 | (let ((first-result-link 1560 | ;; the `link' modifier applies to the first result when 1561 | ;; there are multiple results 1562 | (and 1563 | (not (lookup-type (func-ret-type func))) 1564 | (cond 1565 | ((find type-link? (func-c-args func)) 1566 | => (lambda (a) (string-append "arg" (type-index-string a)))) 1567 | (else #f))))) 1568 | (write-result (car results) first-result-link) 1569 | (for-each write-result (cdr results)))) 1570 | (cond 1571 | ((> (length results) (if (or error-res void-res?) 1 0)) 1572 | (if (or error-res void-res?) 1573 | (cat " res = SEXP_NULL;\n") 1574 | (cat " res = sexp_cons(ctx, res, SEXP_NULL);\n")) 1575 | (for-each 1576 | (lambda (x) 1577 | (if (or error-res void-res?) 1578 | (cat " sexp_push(ctx, res, res" (type-index x) ");\n") 1579 | (cat " sexp_push(ctx, res, sexp_car(res));\n" 1580 | " sexp_cadr(res) = res" (type-index x) ";\n"))) 1581 | (reverse results))) 1582 | ((pair? results) 1583 | (cat " res = res" (type-index (car results)) ";\n"))) 1584 | (if error-res 1585 | (cat " }\n")))) 1586 | 1587 | (define (write-free type) 1588 | (if (and (type-array type) (not (number? (type-array type)))) 1589 | (cat " free(tmp" (type-index-string type) ");\n"))) 1590 | 1591 | (define (write-cleanup func) 1592 | (for-each write-free (func-scheme-args func)) 1593 | (for-each 1594 | (lambda (a) 1595 | (cond 1596 | ((type-auto-expand? a) 1597 | (let ((len (get-array-length func a)) 1598 | (i (type-index a))) 1599 | (if (number? len) 1600 | (cat " if (len" i " != " len ")\n" 1601 | " free(tmp" i ");\n")))) 1602 | ((memq (type-base a) '(input-port input-output-port)) 1603 | (cat " sexp_maybe_unblock_port(ctx, arg" (type-index a) ");\n")) 1604 | ((and (type-result? a) (not (basic-type? a)) 1605 | (not (lookup-type (type-base a))) 1606 | (not (type-free? a)) (not (type-pointer? a)) 1607 | (or (not (type-array a)) 1608 | (not (integer? (get-array-length func a))))) 1609 | ;; the above is hairy - basically this frees temporary strings 1610 | (cat " free(tmp" (type-index a) ");\n")))) 1611 | (func-c-args func)) 1612 | (let* ((results (func-results func)) 1613 | (return-res? (not (error-type? (func-ret-type func)))) 1614 | (preserve-res? (> (+ (length results)) (if return-res? 0 1))) 1615 | (single-res? (and (= 1 (length results)) (not return-res?))) 1616 | (tmp-string? (any (lambda (a) 1617 | (and (type-array a) 1618 | (string-type? (type-base a)))) 1619 | (cons (func-ret-type func) 1620 | (func-results func)))) 1621 | (gc-vars results) 1622 | (gc-vars (if tmp-string? (cons "str" gc-vars) gc-vars)) 1623 | (gc-vars (if preserve-res? (cons "res" gc-vars) gc-vars))) 1624 | (write-gc-release gc-vars))) 1625 | 1626 | (define (write-func-declaration func) 1627 | (cat "sexp " (func-stub-name func) 1628 | " (sexp ctx, sexp self, sexp_sint_t n" 1629 | (write-parameters (func-scheme-args func)) ")")) 1630 | 1631 | (define (write-func func) 1632 | (write-func-declaration func) 1633 | (cat " {\n") 1634 | (write-locals func) 1635 | (write-temporaries func) 1636 | (write-call func) 1637 | (write-results func) 1638 | (write-cleanup func) 1639 | (cat " return res;\n" 1640 | "}\n\n")) 1641 | 1642 | (define (adjust-method-name! func i) 1643 | (func-stub-name-set! 1644 | func 1645 | (string-append (func-stub-name func) "__" (number->string i)))) 1646 | 1647 | (define (write-primitive-call func args) 1648 | (cat (func-stub-name func) 1649 | "(" (lambda () (join (append '(ctx self n) args) ", ")) ")")) 1650 | 1651 | (define (write-fixed-arity-method meth) 1652 | (define (write-dispatch func) 1653 | (write-primitive-call 1654 | func 1655 | (map (lambda (a) (string-append "arg" (type-index-string a))) 1656 | (func-scheme-args func)))) 1657 | (define (write-method-validators func) 1658 | (cond 1659 | ((not (pair? (cdr (func-scheme-args func)))) 1660 | (warn "no arguments to distinguish" func) 1661 | (cat "1")) 1662 | (else 1663 | (let lp ((ls (cdr (func-scheme-args func)))) 1664 | (check-type (string-append "arg" (type-index-string (car ls))) (car ls)) 1665 | (cond 1666 | ((pair? (cdr ls)) 1667 | (cat " && ") 1668 | (lp (cdr ls)))))))) 1669 | (case (length meth) 1670 | ((0 1) 1671 | (error "invalid method" meth)) 1672 | ((2) 1673 | (write-func (cadr meth))) 1674 | (else 1675 | (let ((orig-stub-name (func-stub-name (cadr meth)))) 1676 | (do ((ls (cdr meth) (cdr ls)) (i 0 (+ i 1))) 1677 | ((null? ls)) 1678 | (adjust-method-name! (car ls) i) 1679 | (write-func (car ls))) 1680 | (let ((new-stub-name (func-stub-name (cadr meth)))) 1681 | (func-stub-name-set! (cadr meth) orig-stub-name) 1682 | (write-func-declaration (cadr meth)) 1683 | (func-stub-name-set! (cadr meth) new-stub-name) 1684 | (cat " {\n" 1685 | " sexp orig_self = self;\n") 1686 | (write-validator "arg0" (car (func-scheme-args (cadr meth)))) 1687 | (let lp ((ls (cdr meth)) (i 0)) 1688 | (cat " self = sexp_vector_ref(sexp_opcode_methods(orig_self), " 1689 | (make-integer i) ");\n") 1690 | (cond 1691 | ((null? (cdr ls)) 1692 | (cat " return " (lambda () (write-dispatch (car ls))) ";\n")) 1693 | (else 1694 | (cat " if (" 1695 | (lambda () (write-method-validators (car ls))) ") {\n" 1696 | " return " (lambda () (write-dispatch (car ls))) ";\n" 1697 | " }\n" (lambda () (lp (cdr ls) (+ i 1))))))) 1698 | (cat "}\n\n") 1699 | (func-stub-name-set! (cadr meth) orig-stub-name)))))) 1700 | 1701 | (define (write-method meth) 1702 | (let ((args (map func-scheme-args (cdr meth)))) 1703 | (if (and (> (length args) 1) 1704 | (not (apply = (map length args)))) 1705 | (error "methods must have the same arity"))) 1706 | (write-fixed-arity-method meth)) 1707 | 1708 | (define (parameter-default? x) 1709 | (and (pair? x) 1710 | (member x '((current-input-port) 1711 | (current-output-port) 1712 | (current-error-port))))) 1713 | 1714 | (define (write-default x) ;; this is a hack but very convenient 1715 | (lambda () 1716 | (let ((value (type-value x))) 1717 | (cond 1718 | ((equal? value '(current-input-port)) 1719 | (cat "\"current-input-port\"")) 1720 | ((equal? value '(current-output-port)) 1721 | (cat "\"current-output-port\"")) 1722 | ((equal? value '(current-error-port)) 1723 | (cat "\"current-error-port\"")) 1724 | ((equal? value 'NULL) 1725 | (cat "SEXP_FALSE")) 1726 | (else 1727 | (c->scheme-converter x value)))))) 1728 | 1729 | (define (write-func-creation var func . o) 1730 | (let ((default (and (pair? (func-scheme-args func)) 1731 | (type-default? (car (reverse (func-scheme-args func)))) 1732 | (car (reverse (func-scheme-args func))))) 1733 | (no-bind? (and (pair? o) (car o)))) 1734 | (cat " " var " = " 1735 | (cond 1736 | (no-bind? 1737 | "sexp_make_foreign(ctx, ") 1738 | ((not default) 1739 | "sexp_define_foreign(ctx, env, ") 1740 | ((parameter-default? (type-value default)) 1741 | "sexp_define_foreign_param(ctx, env, ") 1742 | (else 1743 | "sexp_define_foreign_opt(ctx, env, ")) 1744 | (lambda () (write (symbol->string (func-scheme-name func)))) 1745 | ", " (length (func-scheme-args func)) ", " 1746 | (if no-bind? 1747 | (lambda () 1748 | (cat (cond ((not default) 0) 1749 | ((parameter-default? (type-value default)) 3) 1750 | (else 1)) 1751 | ", ")) 1752 | "") 1753 | (func-stub-name func) 1754 | (cond 1755 | (default (lambda () (cat ", " (write-default default)))) 1756 | (no-bind? ", SEXP_VOID") 1757 | (else "")) 1758 | ");\n"))) 1759 | 1760 | (define (write-func-types var func) 1761 | (cond 1762 | ((or (not (eq? 'sexp (type-base (func-ret-type func)))) 1763 | (and (pair? (func-c-args func)) 1764 | (any (lambda (a) (not (eq? 'sexp (type-base a)))) 1765 | (func-c-args func)))) 1766 | (cat 1767 | " if (sexp_opcodep(" var ")) {\n" 1768 | " sexp_opcode_return_type(" var ") = " 1769 | (type-id-init-value (func-ret-type func)) ";\n" 1770 | (lambda () 1771 | (do ((ls (func-c-args func) (cdr ls)) 1772 | (i 1 (+ i 1))) 1773 | ((null? ls)) 1774 | (cond 1775 | ((eq? 'sexp (type-base (car ls)))) 1776 | ((<= i 3) 1777 | (cat " sexp_opcode_arg" i "_type(" var ") = " 1778 | (type-id-init-value (car ls)) ";\n")) 1779 | (else 1780 | (if (= i 4) 1781 | (cat " sexp_opcode_argn_type(" var ") = " 1782 | "sexp_make_vector(ctx, " 1783 | (make-integer (- (length (func-c-args func)) 3)) ", " 1784 | (make-integer "SEXP_OBJECT") ");\n")) 1785 | (cat " sexp_vector_set(sexp_opcode_argn_type(" var "), " 1786 | (make-integer (- i 4)) ", " 1787 | (type-id-init-value (car ls)) ");\n"))))) 1788 | ;; " } else {\n" 1789 | ;; " sexp_warn(ctx, \"couldn't generated opcode\", " var ");\n" 1790 | " }\n"))) 1791 | (cond 1792 | ((assq (func-scheme-name func) *type-getters*) 1793 | => (lambda (x) 1794 | (let ((name (cadr x)) 1795 | (i (car (cddr x)))) 1796 | (cat " if (sexp_vectorp(sexp_type_getters(" (type-id-name name) 1797 | "))) sexp_vector_set(sexp_type_getters(" 1798 | (type-id-name name) "), " 1799 | (make-integer i) ", " var ");\n")))) 1800 | ((assq (func-scheme-name func) *type-setters*) 1801 | => (lambda (x) 1802 | (let ((name (cadr x)) 1803 | (i (car (cddr x)))) 1804 | (cat " if (sexp_vectorp(sexp_type_setters(" (type-id-name name) 1805 | "))) sexp_vector_set(sexp_type_setters(" 1806 | (type-id-name name) "), " 1807 | (make-integer i) ", " var ");\n")))))) 1808 | 1809 | (define (write-func-binding func . o) 1810 | (let ((var (if (pair? o) (car o) "op"))) 1811 | (write-func-creation var func) 1812 | (write-func-types var func))) 1813 | 1814 | (define (write-method-binding meth) 1815 | (write-func-binding (cadr meth)) 1816 | (cat " if (sexp_opcodep(op)) {\n" 1817 | (lambda () 1818 | (cat " sexp_opcode_methods(op) = " 1819 | "sexp_make_vector(ctx, " (make-integer (length (cdr meth))) 1820 | ", SEXP_VOID);\n") 1821 | (do ((ls (cdr meth) (cdr ls)) (i 0 (+ i 1))) 1822 | ((null? ls)) 1823 | (let ((var (string-append 1824 | "sexp_vector_ref(sexp_opcode_methods(op), " 1825 | (make-integer i) ")"))) 1826 | (write-func-creation var (car ls) #t) 1827 | (write-func-types var (car ls))))) 1828 | " }\n")) 1829 | 1830 | (define (write-type orig-type) 1831 | (let* ((name (car orig-type)) 1832 | (scheme-name (strip-namespace (type-name name))) 1833 | (type (cdr orig-type)) 1834 | (imported? (cond ((member 'imported?: type) => cadr) (else #f)))) 1835 | (cond 1836 | (imported? 1837 | (cat " name = sexp_intern(ctx, \"" scheme-name "\", -1);\n" 1838 | " " (type-id-name name) " = sexp_env_ref(ctx, env, name, SEXP_FALSE);\n" 1839 | " if (sexp_not(" (type-id-name name) ")) {\n" 1840 | " sexp_warn(ctx, \"couldn't import declared type: \", name);\n" 1841 | " }\n")) 1842 | (else 1843 | (cat " name = sexp_c_string(ctx, \"" scheme-name "\", -1);\n" 1844 | " " (type-id-name name) 1845 | " = sexp_register_c_type(ctx, name, " 1846 | (cond ((or (memq 'finalizer: type) 1847 | (memq 'finalizer-method: type)) 1848 | => (lambda (x) 1849 | (let ((name (cadr x))) 1850 | (generate-stub-name 1851 | (if (pair? name) (car name) name))))) 1852 | (*c++?* 1853 | (type-finalizer-name name)) 1854 | (else 1855 | "sexp_finalize_c_type")) 1856 | ");\n" 1857 | " tmp = sexp_string_to_symbol(ctx, name);\n" 1858 | " sexp_env_define(ctx, env, tmp, " (type-id-name name) ");\n") 1859 | (if (pair? (struct-fields type)) 1860 | (let ((len (make-integer (length (struct-fields type))))) 1861 | (cat " sexp_type_slots(" (type-id-name name) ") = SEXP_NULL;\n" 1862 | (lambda () 1863 | (do ((ls (reverse (struct-fields type)) (cdr ls))) 1864 | ((not (pair? ls))) 1865 | (cat " sexp_push(ctx, sexp_type_slots(" 1866 | (type-id-name name) "), " 1867 | "sexp_intern(ctx, " 1868 | (lambda () (write (x->string (cadr (car ls))))) 1869 | ", -1));\n"))) 1870 | " sexp_type_getters(" (type-id-name name) ")" 1871 | " = sexp_make_vector(ctx, " len ", SEXP_FALSE);\n" 1872 | " sexp_type_setters(" (type-id-name name) ")" 1873 | " = sexp_make_vector(ctx, " len ", SEXP_FALSE);\n"))) 1874 | (cond 1875 | ((memq 'predicate: type) 1876 | => (lambda (x) 1877 | (let ((pred (cadr x))) 1878 | (cat " tmp = sexp_make_type_predicate(ctx, name, " 1879 | (type-id-name name) ");\n" 1880 | " name = sexp_intern(ctx, \"" pred "\", " 1881 | (string-length (x->string pred)) ");\n" 1882 | " sexp_env_define(ctx, env, name, tmp);\n"))))))))) 1883 | 1884 | (define (type-getter-name type name field) 1885 | (let ((c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field)))) 1886 | (string-replace 1887 | (string-append "sexp_" (x->string (type-name (parse-type name))) 1888 | "_get_" (x->string c-name)) 1889 | #\: "_"))) 1890 | 1891 | (define (verify-accessor field) 1892 | (if (and (pair? field) 1893 | (not (and (= 3 (length field)) 1894 | (memq (cadr field) '(function: method:))))) 1895 | (error "accessor should be a single symbol or (scheme-name function:|method: c-name) but got" field))) 1896 | 1897 | (define (write-type-getter type name field) 1898 | (let* ((get (car (cddr field))) 1899 | (_ (verify-accessor get)) 1900 | (c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field))) 1901 | (ptr (string-append 1902 | "((" (x->string (or (type-struct-type name) "")) 1903 | " " (x->string name) "*)" 1904 | "sexp_cpointer_value(x))"))) 1905 | (cat "sexp " (type-getter-name type name field) 1906 | " (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n" 1907 | (lambda () (write-validator "x" (parse-type name 0))) 1908 | " return " 1909 | (lambda () 1910 | (c->scheme-converter 1911 | (car field) 1912 | (cond 1913 | ((and (pair? get) (eq? 'function: (cadr get))) 1914 | (string-append (car (cddr get)) "(" ptr ")")) 1915 | ((and (pair? get) (eq? 'method: (cadr get))) 1916 | (string-append ptr "->" (car (cddr get)) "()")) 1917 | ((pair? get) 1918 | (error "invalid getter" get)) 1919 | (else 1920 | (string-append 1921 | (if (type-struct? (car field)) "&" "") 1922 | ptr "->" (x->string c-name)))) 1923 | (and (or (type-struct? (car field)) (type-link? (car field))) 1924 | "x"))) 1925 | ";\n" 1926 | "}\n\n"))) 1927 | 1928 | (define (type-setter-name type name field) 1929 | (let ((c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field)))) 1930 | (string-replace 1931 | (string-append "sexp_" (x->string (type-name (parse-type name))) 1932 | "_set_" (x->string c-name)) 1933 | #\: "_"))) 1934 | 1935 | (define (write-type-setter-assignment type name field dst val) 1936 | (let* ((set (cadr (cddr field))) 1937 | (_ (verify-accessor set)) 1938 | (c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field))) 1939 | (ptr (string-append 1940 | "((" (x->string (or (type-struct-type name) "")) 1941 | " " (x->string name) "*)" 1942 | "sexp_cpointer_value(" (x->string dst) "))"))) 1943 | (cond 1944 | ((and (pair? set) (eq? 'function: (cadr set))) 1945 | (lambda () 1946 | (cat (car (cddr set)) "(" ptr ", " 1947 | (lambda () (scheme->c-converter (car field) val)) ");\n"))) 1948 | ((and (pair? set) (eq? 'method: (cadr set))) 1949 | (lambda () 1950 | (cat ptr "->" (car (cddr set)) "(" 1951 | (lambda () (scheme->c-converter (car field) val)) ");\n"))) 1952 | ((pair? set) 1953 | (error "invalid setter" set)) 1954 | ((type-struct? (car field)) 1955 | ;; assign to a nested struct - copy field-by-field 1956 | (let ((field-type 1957 | (cond ((lookup-type (type-name (car field))) 1958 | => (lambda (x) (cddr (cdr x)))) 1959 | (else (cdr field))))) 1960 | (lambda () 1961 | (for-each 1962 | (lambda (subfield) 1963 | (let ((subname (x->string (cadr subfield)))) 1964 | (cat 1965 | " " 1966 | ptr "->" (x->string (cadr field)) 1967 | "." (x->string (cadr subfield)) 1968 | " = " 1969 | (string-append 1970 | "((" (x->string (or (type-struct-type (type-name (car field))) 1971 | "")) 1972 | " " (mangle (type-name (car field))) "*)" 1973 | "sexp_cpointer_value(" val "))" 1974 | "->" (x->string (cadr subfield))) 1975 | ";\n"))) 1976 | (struct-fields field-type))))) 1977 | (else 1978 | (lambda () 1979 | (cat " " ptr "->" c-name " = " 1980 | (lambda () (scheme->c-converter (car field) val)) ";\n")))))) 1981 | 1982 | (define (write-type-setter type name field) 1983 | (cat "sexp " (type-setter-name type name field) 1984 | " (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp v) {\n" 1985 | (lambda () (write-validator "x" (parse-type name 0))) 1986 | (lambda () (write-validator "v" (parse-type (car field) 1))) 1987 | (write-type-setter-assignment type name field "x" "v") 1988 | " return SEXP_VOID;\n" 1989 | "}\n\n")) 1990 | 1991 | (define (write-type-funcs-helper orig-type name type) 1992 | ;; maybe write finalizer 1993 | (cond 1994 | ((or (memq 'finalizer: type) (memq 'finalizer-method: type)) 1995 | => (lambda (x) 1996 | (let* ((y (cadr x)) 1997 | (scheme-name (if (pair? y) (car y) y)) 1998 | (cname (if (pair? y) (cadr y) y)) 1999 | (method? (not (memq 'finalizer: type)))) 2000 | (cat "sexp " (generate-stub-name scheme-name) 2001 | " (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n" 2002 | " if (sexp_cpointer_freep(x)) {\n" 2003 | " " (if method? "" cname) "(" 2004 | (if method? "(" "") 2005 | "\n#ifdef __cplusplus\n" 2006 | "(" (mangle name) "*)" 2007 | "\n#endif\n" 2008 | "sexp_cpointer_value(x)" 2009 | (if method? (string-append ")->" (x->string cname) "()") "") 2010 | ");\n" 2011 | ;; TODO: keep track of open/close separately from ownership 2012 | " sexp_cpointer_freep(x) = 0;\n" 2013 | " }\n" 2014 | " return SEXP_VOID;\n" 2015 | "}\n\n") 2016 | ;; make the finalizer available 2017 | (set! *funcs* 2018 | (cons (parse-func `(void ,y (,name))) *funcs*)))))) 2019 | ;; maybe write constructor 2020 | (cond 2021 | ((memq 'constructor: type) 2022 | => (lambda (x) 2023 | (let ((make (car (cadr x))) 2024 | (args (cdr (cadr x)))) 2025 | (cat "sexp " (generate-stub-name make) 2026 | " (sexp ctx, sexp self, sexp_sint_t n" 2027 | (lambda () 2028 | (let lp ((ls args) (i 0)) 2029 | (cond ((pair? ls) 2030 | (cat ", sexp arg" i) 2031 | (lp (cdr ls) (+ i 1)))))) 2032 | ") {\n" 2033 | " " (type-c-name name) " r;\n" 2034 | " sexp_gc_var1(res);\n" 2035 | " sexp_gc_preserve1(ctx, res);\n" 2036 | ;; TODO: support heap-managed allocations 2037 | ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer)" 2038 | ;; " + sizeof(struct " (type-name name) "), " 2039 | ;; (type-id-name name) 2040 | ;; ");\n" 2041 | ;; " r = sexp_cpointer_value(res) = " 2042 | ;; "sexp_cpointer_body(res);\n" 2043 | ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), sexp_type_tag(" 2044 | ;; (type-id-name name) 2045 | ;; "));\n" 2046 | " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), " 2047 | "sexp_unbox_fixnum(sexp_opcode_return_type(self)));\n" 2048 | " sexp_cpointer_value(res) = calloc(1, sizeof(" 2049 | (type-c-name-derefed name) "));\n" 2050 | " r = (" (type-c-name name) ") sexp_cpointer_value(res);\n" 2051 | " memset(r, 0, sizeof(" 2052 | (type-c-name-derefed name) "));\n" 2053 | " sexp_freep(res) = 1;\n" 2054 | (lambda () 2055 | (let lp ((ls args) (i 0)) 2056 | (cond 2057 | ((pair? ls) 2058 | (let* ((a (car ls)) 2059 | (field 2060 | (find (lambda (f) (and (pair? f) (eq? a (cadr f)))) 2061 | (cddr x))) 2062 | (arg (string-append "arg" (number->string i)))) 2063 | (cond 2064 | ((and field (>= (length field) 4)) 2065 | (cat 2066 | (write-type-setter-assignment 2067 | type name field "res" arg))) 2068 | (field 2069 | (cat " r->" (cadr field) " = " 2070 | (lambda () 2071 | (scheme->c-converter (car field) arg)) 2072 | ";\n"))) 2073 | (lp (cdr ls) (+ i 1))))))) 2074 | " sexp_gc_release1(ctx);\n" 2075 | " return res;\n" 2076 | "}\n\n") 2077 | (set! *funcs* 2078 | (cons (parse-func 2079 | `(,name ,make 2080 | ,(map (lambda (a) 2081 | (cond 2082 | ((find (lambda (x) (eq? a (cadr x))) 2083 | (struct-fields type)) 2084 | => car) 2085 | (else 'sexp))) 2086 | args))) 2087 | *funcs*)))))) 2088 | ;; write field accessors 2089 | (let lp ((ls (struct-fields type)) 2090 | (i 0)) 2091 | (cond 2092 | ((not (pair? ls))) 2093 | ((and (pair? (car ls)) (pair? (cdar ls))) 2094 | (let* ((field (car ls)) 2095 | (get+set (cddr field))) 2096 | (cond 2097 | ((and (pair? get+set) (car get+set)) 2098 | (let ((get-name (if (pair? (car get+set)) 2099 | (caar get+set) 2100 | (car get+set)))) 2101 | (write-type-getter type name field) 2102 | (set! *funcs* 2103 | (cons (parse-func 2104 | `(,(car field) 2105 | (,get-name 2106 | #f 2107 | ,(type-getter-name type name field)) 2108 | (,name))) 2109 | *funcs*)) 2110 | (if (type-struct-type name) 2111 | (set! *type-getters* 2112 | (cons `(,get-name ,name ,i) *type-getters*))))) 2113 | (else "SEXP_FALSE")) 2114 | (cond 2115 | ((and (pair? get+set) 2116 | (pair? (cdr get+set)) 2117 | (cadr get+set)) 2118 | (let ((set-name (if (pair? (cadr get+set)) 2119 | (car (cadr get+set)) 2120 | (cadr get+set)))) 2121 | (write-type-setter type name field) 2122 | (set! *funcs* 2123 | (cons (parse-func 2124 | `(,(car field) 2125 | (,set-name 2126 | #f 2127 | ,(type-setter-name type name field)) 2128 | (,name ,(car field)))) 2129 | *funcs*)) 2130 | (if (type-struct-type name) 2131 | (set! *type-setters* 2132 | (cons `(,set-name ,name ,i) *type-setters*))))))) 2133 | (lp (cdr ls) (+ i 1)))))) 2134 | 2135 | (define (write-type-funcs orig-type) 2136 | (let* ((name (car orig-type)) 2137 | (type (cdr orig-type)) 2138 | (imported? (cond ((member 'imported?: type) => cadr) (else #f)))) 2139 | (if (not imported?) 2140 | (write-type-funcs-helper orig-type name type)))) 2141 | 2142 | (define (write-const const) 2143 | (let ((scheme-name 2144 | (if (pair? (cadr const)) (car (cadr const)) (cadr const))) 2145 | (c-name 2146 | (if (pair? (cadr const)) (cadr (cadr const)) (mangle (cadr const))))) 2147 | (cat " name = sexp_intern(ctx, \"" scheme-name "\", " 2148 | (string-length (x->string scheme-name)) ");\n" 2149 | " sexp_env_define(ctx, env, name, tmp=" 2150 | (lambda () (c->scheme-converter (car const) c-name)) ");\n"))) 2151 | 2152 | (define (write-utilities) 2153 | (define (input-env-string? x) 2154 | (and (eq? 'env-string (type-base x)) (not (type-result? x)))) 2155 | (cond 2156 | (*c++?* 2157 | (for-each 2158 | (lambda (t) 2159 | (cond 2160 | ((and (not (memq 'finalizer: (cdr t))) 2161 | (not (memq 'finalizer-method: (cdr t))) 2162 | (type-struct-type (car t))) 2163 | (let ((name (type-c-name-derefed (car t))) 2164 | (finalizer-name (type-finalizer-name (car t)))) 2165 | (cat 2166 | "sexp " finalizer-name " (" 2167 | "sexp ctx, sexp self, sexp_sint_t n, sexp obj) {\n" 2168 | " if (sexp_cpointer_freep(obj))\n" 2169 | " delete static_cast<" name "*>" 2170 | "(sexp_cpointer_value(obj));\n" 2171 | " sexp_cpointer_value(obj) = NULL;\n" 2172 | " return SEXP_VOID;\n" 2173 | "}\n\n"))))) 2174 | *types*))) 2175 | (cond 2176 | ((any (lambda (f) 2177 | (or (any input-env-string? (func-results f)) 2178 | (any input-env-string? (func-scheme-args f)))) 2179 | *funcs*) 2180 | (cat "static char* sexp_concat_env_string (sexp x) {\n" 2181 | " int klen=sexp_string_size(sexp_car(x)), vlen=sexp_string_size(sexp_cdr(x));\n" 2182 | " char *res = (char*) calloc(1, klen+vlen+2);\n" 2183 | " strncpy(res, sexp_string_data(sexp_car(x)), klen);\n" 2184 | " res[sexp_string_size(sexp_car(x))] = '=';\n" 2185 | " strncpy(res+sexp_string_size(sexp_car(x)), sexp_string_data(sexp_cdr(x)), vlen);\n" 2186 | " res[len-1] = '\\0';\n" 2187 | " return res;\n" 2188 | "}\n\n")))) 2189 | 2190 | (define (write-init) 2191 | (newline) 2192 | (write-utilities) 2193 | (for-each write-func *funcs*) 2194 | (for-each write-method *methods*) 2195 | (for-each write-type-funcs *types*) 2196 | (for-each (lambda (n) (cat "} // " n "\n")) *open-namespaces*) 2197 | (newline) 2198 | (if *c++?* 2199 | (cat "extern \"C\"\n")) 2200 | (cat "sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) {\n" 2201 | (lambda () 2202 | (for-each 2203 | (lambda (t) (cat " sexp " t ";\n")) 2204 | *tags*)) 2205 | " sexp_gc_var3(name, tmp, op);\n" 2206 | " if (!(sexp_version_compatible(ctx, version, sexp_version)\n" 2207 | " && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))\n" 2208 | " return SEXP_ABI_ERROR;\n" 2209 | " sexp_gc_preserve3(ctx, name, tmp, op);\n") 2210 | (for-each write-const *consts*) 2211 | (for-each write-type *types*) 2212 | (for-each write-func-binding *funcs*) 2213 | (for-each write-method-binding *methods*) 2214 | (for-each (lambda (x) (cat " " x "\n")) (reverse *inits*)) 2215 | (for-each *post-init-hook* (lambda (f) (f))) 2216 | (cat " sexp_gc_release3(ctx);\n" 2217 | " return SEXP_VOID;\n" 2218 | "}\n\n")) 2219 | 2220 | (define (generate file) 2221 | (cat "/* Automatically generated by chibi-ffi; version: " 2222 | *ffi-version* " */\n") 2223 | (c-system-include "chibi/eval.h") 2224 | (load file (current-environment)) 2225 | (cat "/*\ntypes: " (map car *types*) "\nenums: " *c-enum-types* "\n*/\n") 2226 | (write-init)) 2227 | 2228 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2229 | ;; main 2230 | 2231 | (let ((args (command-line))) 2232 | (let lp ((args (if (pair? args) (cdr args) args)) 2233 | (compile? #f) 2234 | (cc #f) 2235 | (cflags '()) 2236 | (features '())) 2237 | (cond 2238 | ((and (pair? args) (not (equal? "" (car args))) 2239 | (eqv? #\- (string-ref (car args) 0))) 2240 | (case (string->symbol (car args)) 2241 | ((-c --compile) 2242 | (lp (cdr args) #t cc cflags features)) 2243 | ((-cc --cc) 2244 | (lp (cddr args) compile? (cadr args) cflags features)) 2245 | ((-f --flags) 2246 | (if (null? (cdr args)) 2247 | (error "--flags requires an argument")) 2248 | (lp (cddr args) 2249 | compile? 2250 | cc 2251 | (append cflags (string-split (cadr args) #\space)) 2252 | features)) 2253 | ((--features) 2254 | (if (null? (cdr args)) 2255 | (error "--features requires an argument")) 2256 | (lp (cddr args) 2257 | compile? 2258 | cc 2259 | cflags 2260 | (append features (string-split (cadr args) #\,)))) 2261 | (else 2262 | (error "unknown option" (car args))))) 2263 | (else 2264 | (if (pair? features) 2265 | (set! *features* features)) 2266 | (let* ((src (if (or (not (pair? args)) (equal? "-" (car args))) 2267 | "/dev/stdin" 2268 | (car args))) 2269 | (dest 2270 | (case (length args) 2271 | ((0) "-") 2272 | ((1) (string-append (strip-extension src) ".c")) 2273 | ((2) (cadr args)) 2274 | (else 2275 | (error "usage: chibi-ffi [-c] []"))))) 2276 | (if (not (equal? "/dev/stdin" src)) 2277 | (let ((slash (string-scan-right src #\/))) 2278 | (if (string-cursor>? slash (string-cursor-start src)) 2279 | (set! wdir (substring-cursor src (string-cursor-start src) slash))))) 2280 | (if (equal? "-" dest) 2281 | (generate src) 2282 | (with-output-to-file dest (lambda () (generate src)))) 2283 | (cond 2284 | ((and compile? (not (equal? "-" dest))) 2285 | ;; This has to use `eval' for bootstrapping, since we need 2286 | ;; chibi-ffi to compile to (chibi process) module. 2287 | (let* ((so (string-append (strip-extension src) 2288 | *shared-object-extension*)) 2289 | (execute (begin (eval '(import (chibi process)) 2290 | (current-environment)) 2291 | (eval 'execute (current-environment)))) 2292 | (base-args (append cflags *cflags* 2293 | `("-o" ,so ,dest "-lchibi-scheme") 2294 | (map (lambda (x) (string-append "-l" x)) 2295 | (reverse *clibs*)) 2296 | (apply append 2297 | (map (lambda (x) (list "-framework" x)) 2298 | (reverse *frameworks*))))) 2299 | (args 2300 | (eval 2301 | `(cond-expand 2302 | (macosx (append '("-dynamiclib" "-Oz") ',base-args)) 2303 | (else (append '("-fPIC" "-shared" "-Os") ',base-args))))) 2304 | (cc (or cc (if *c++?* "c++" "cc")))) 2305 | (display ";; " (current-error-port)) 2306 | (write (cons cc args) (current-error-port)) 2307 | (newline (current-error-port)) 2308 | (execute cc (cons cc args)))))))))) 2309 | -------------------------------------------------------------------------------- /hello-3d.scm: -------------------------------------------------------------------------------- 1 | ;; int main(void) 2 | ;; { 3 | ;; // Initialization 4 | ;; //-------------------------------------------------------------------------------------- 5 | ;; const int screenWidth = 800; 6 | ;; const int screenHeight = 450; 7 | 8 | ;; InitWindow(screenWidth, screenHeight, "raylib [core] example - 3d camera mode"); 9 | 10 | ;; // Define the camera to look into our 3d world 11 | ;; Camera3D camera = { 0 }; 12 | ;; camera.position = (Vector3){ 0.0f, 10.0f, 10.0f }; // Camera position 13 | ;; camera.target = (Vector3){ 0.0f, 0.0f, 0.0f }; // Camera looking at point 14 | ;; camera.up = (Vector3){ 0.0f, 1.0f, 0.0f }; // Camera up vector (rotation towards target) 15 | ;; camera.fovy = 45.0f; // Camera field-of-view Y 16 | ;; camera.type = CAMERA_PERSPECTIVE; // Camera mode type 17 | 18 | ;; Vector3 cubePosition = { 0.0f, 0.0f, 0.0f }; 19 | 20 | ;; SetTargetFPS(60); // Set our game to run at 60 frames-per-second 21 | ;; //-------------------------------------------------------------------------------------- 22 | 23 | ;; // Main game loop 24 | ;; while (!WindowShouldClose()) // Detect window close button or ESC key 25 | ;; { 26 | ;; // Update 27 | ;; //---------------------------------------------------------------------------------- 28 | ;; // TODO: Update your variables here 29 | ;; //---------------------------------------------------------------------------------- 30 | 31 | ;; // Draw 32 | ;; //---------------------------------------------------------------------------------- 33 | ;; BeginDrawing(); 34 | 35 | ;; ClearBackground(RAYWHITE); 36 | 37 | ;; BeginMode3D(camera); 38 | 39 | ;; DrawCube(cubePosition, 2.0f, 2.0f, 2.0f, RED); 40 | ;; DrawCubeWires(cubePosition, 2.0f, 2.0f, 2.0f, MAROON); 41 | 42 | ;; DrawGrid(10, 1.0f); 43 | 44 | ;; EndMode3D(); 45 | 46 | ;; DrawText("Welcome to the third dimension!", 10, 40, 20, DARKGRAY); 47 | 48 | ;; DrawFPS(10, 10); 49 | 50 | ;; EndDrawing(); 51 | ;; //---------------------------------------------------------------------------------- 52 | ;; } 53 | 54 | ;; // De-Initialization 55 | ;; //-------------------------------------------------------------------------------------- 56 | ;; CloseWindow(); // Close window and OpenGL context 57 | ;; //-------------------------------------------------------------------------------------- 58 | 59 | ;; return 0; 60 | ;; } 61 | 62 | (define camera #f) 63 | (define cube-position #f) 64 | 65 | (define (init) 66 | (init-window 800 600 "Hello 3d") 67 | (display-nl "About to init camera") 68 | (set! camera (make-camera-3d 69 | (make-vector-3 0.0 10.0 10.0) 70 | (make-vector-3 0.0 0.0 0.0) 71 | (make-vector-3 0.0 1.0 0.0) 72 | 45.0 73 | 0)) 74 | (display-nl "Did it") 75 | (set! cube-position (make-vector-3 0.0 0.0 0.0)) 76 | (set-target-fps 60)) 77 | 78 | (define (draw) 79 | (begin-drawing) 80 | (clear-background (color 255 255 255 255)) 81 | (begin-mode-3d camera) 82 | (draw-cube cube-position 2.0 2.0 2.0 (color 255 0 0 255)) 83 | (draw-grid 10 1.0) 84 | (end-mode-3d) 85 | (draw-text "Hello 3d" 190 200 20 (color 192 192 192 255)) 86 | (end-drawing) 87 | ) 88 | -------------------------------------------------------------------------------- /lib.scm: -------------------------------------------------------------------------------- 1 | (define exact->inexact inexact) 2 | (define inexact->exact exact) 3 | (define (coerce-to-int n) 4 | (inexact->exact (round n))) 5 | (define (coerce-to-unsigned-char n) 6 | (inexact->exact (floor (* n 255)))) 7 | 8 | (define (rectangle x y w h) 9 | (--rectangle (exact->inexact x) 10 | (exact->inexact y) 11 | (exact->inexact w) 12 | (exact->inexact h))) 13 | 14 | (define (color r g b a) 15 | (if (integer? r) 16 | (--color r g b a) 17 | (--color (coerce-to-unsigned-char r) 18 | (coerce-to-unsigned-char g) 19 | (coerce-to-unsigned-char b) 20 | (coerce-to-unsigned-char a)))) 21 | 22 | (define (display-nl x) 23 | (display x) 24 | (newline)) 25 | 26 | (define (get-next-codepoint str) 27 | (get-next-codepoint-- str)) 28 | 29 | (define (load-meshes filename) 30 | (let ((mesh-array (load-meshes-to-mesh-array filename))) 31 | (let loop ((i (- (mesh-array-get-length mesh-array) 1)) 32 | (meshes (list))) 33 | (if (< i 0) meshes 34 | (loop (- i 1) 35 | (cons (mesh-array-get-mesh mesh-array i) 36 | meshes)))))) 37 | 38 | (define (load-materials filename) 39 | (let ((material-array (load-materials-to-material-array filename))) 40 | (let loop ((i (- (material-array-get-length material-array) 1)) 41 | (materials (list))) 42 | (if (< i 0) materials 43 | (loop (- i 1) 44 | (cons (material-array-get-material material-array i) 45 | materials)))))) 46 | 47 | (define (load-model-animations filename) 48 | (let ((model-animation-array (load-model-animations-to-model-animation-array filename))) 49 | (let loop ((i (- (model-animation-array-get-length model-animation-array) 1)) 50 | (model-animations (list))) 51 | (if (< i 0) model-animations 52 | (loop (- i 1) 53 | (cons (model-animation-array-get-model-animation model-animation-array i) 54 | model-animations)))))) 55 | 56 | (define (check-collision-ray-sphere-ex ray position radius) 57 | (let ((result (check-collision-ray-sphere-ex-- ray position radius))) 58 | (list (ray-sphere-collision-info-get-collision result) 59 | (ray-sphere-collision-info-get-point result)))) 60 | 61 | -------------------------------------------------------------------------------- /main.scm: -------------------------------------------------------------------------------- 1 | (define (init) 2 | (init-window 800 450 "Hello World") 3 | (set-target-fps 60) 4 | #f) 5 | 6 | (define (draw) 7 | (begin-drawing) 8 | (clear-background (color 255 255 255 255)) 9 | (draw-text "OMG - Raylib Chibi is Alive!" 190 200 20 (color 192 192 192 255)) 10 | (draw-rectangle 220 220 40 40 (color 192 0 0 255)) 11 | (end-drawing)) 12 | 13 | -------------------------------------------------------------------------------- /raylib-chibi.c: -------------------------------------------------------------------------------- 1 | 2 | 3 | /******************************************************************************************* 4 | * 5 | * raylib [core] example - Basic window 6 | * 7 | * Welcome to raylib! 8 | * 9 | * To test examples, just press F6 and execute raylib_compile_execute script 10 | * Note that compiled executable is placed in the same folder as .c file 11 | * 12 | * You can find all basic examples on C:\raylib\raylib\examples folder or 13 | * raylib official webpage: www.raylib.com 14 | * 15 | * Enjoy using raylib. :) 16 | * 17 | * This example has been created using raylib 1.0 (www.raylib.com) 18 | * raylib is licensed under an unmodified zlib/libpng license (View raylib.h for details) 19 | * 20 | * Copyright (c) 2013-2016 Ramon Santamaria (@raysan5) 21 | * 22 | ********************************************************************************************/ 23 | 24 | #include "raylib.h" 25 | #include "chibi/eval.h" 26 | 27 | Image * LoadImagePr(const char * fn){ 28 | Image r; 29 | Image * im; 30 | r = LoadImage(fn); 31 | im = (Image*)malloc(sizeof(Image)); 32 | im->data = r.data; 33 | im->width = r.width; 34 | im->height = r.height; 35 | im->mipmaps = r.mipmaps; 36 | im->format = r.format; 37 | return im; 38 | } 39 | 40 | void SetWindowIconPr(Image * im){ 41 | SetWindowIcon(*im); 42 | } 43 | 44 | void ClearBackgroundPr(Color * clr){ 45 | ClearBackground(*clr); 46 | } 47 | 48 | void FreeCamera2DPr(Camera2D * c){ 49 | free(c); 50 | } 51 | 52 | void BeginMode2DPr(Camera2D * c){ 53 | BeginMode2D(*c); 54 | } 55 | 56 | #include "raylib.c" 57 | 58 | int main(int argc, char ** argv) 59 | { 60 | // Initialization 61 | //-------------------------------------------------------------------------------------- 62 | char load_str[250]; 63 | char * load_str_format = "(guard (err (#t (display \"Error\") (display \"Error loading main script.\") (newline) (print-exception err) (newline))) (load \"%s\"))"; 64 | const int screenWidth = 800; 65 | const int screenHeight = 450; 66 | sexp ctx; 67 | 68 | if(argc<=1){ 69 | sprintf(load_str, load_str_format, "main.scm"); 70 | } else { 71 | sprintf(load_str, load_str_format, argv[1]); 72 | } 73 | 74 | ctx = sexp_make_eval_context(NULL, NULL, NULL, 0, 0); 75 | sexp_load_standard_env(ctx, NULL, SEXP_SEVEN); 76 | sexp_load_standard_ports(ctx, NULL, stdin, stdout, stderr, 1); 77 | sexp_init_library(ctx, 78 | NULL, 79 | 3, 80 | sexp_context_env(ctx), 81 | sexp_version, 82 | SEXP_ABI_IDENTIFIER); 83 | sexp_eval_string(ctx,"(import (scheme base) (chibi))",-1,NULL); 84 | sexp_eval_string(ctx,"(load \"lib.scm\")",-1,NULL); 85 | sexp_eval_string(ctx,load_str,-1,NULL); 86 | sexp_eval_string(ctx,"(guard (err (#t (display \"Error\") (newline) (print-exception err) (newline))) (init))",-1,NULL); 87 | //sexp_eval_string(ctx,"(init)",-1,NULL); 88 | 89 | 90 | //InitWindow(screenWidth, screenHeight, "raylib [core] example - basic window"); 91 | 92 | //SetTargetFPS(60); // Set our game to run at 60 frames-per-second 93 | //-------------------------------------------------------------------------------------- 94 | 95 | // Main game loop 96 | while (!WindowShouldClose()) // Detect window close button or ESC key 97 | { 98 | // Update 99 | //---------------------------------------------------------------------------------- 100 | // TODO: Update your variables here 101 | //---------------------------------------------------------------------------------- 102 | 103 | // Draw 104 | //---------------------------------------------------------------------------------- 105 | sexp_eval_string(ctx,"(guard (err (#t (display \"Error\") (newline) (print-exception err) (newline))) (draw))",-1,NULL); 106 | /* BeginDrawing(); */ 107 | 108 | /* ClearBackground(RAYWHITE); */ 109 | 110 | /* DrawText("Congrats! You created your first window!", 190, 200, 20, LIGHTGRAY); */ 111 | 112 | /* EndDrawing(); */ 113 | //---------------------------------------------------------------------------------- 114 | } 115 | 116 | // De-Initialization 117 | //-------------------------------------------------------------------------------------- 118 | CloseWindow(); // Close window and OpenGL context 119 | //-------------------------------------------------------------------------------------- 120 | 121 | sexp_destroy_context(ctx); 122 | return 0; 123 | } 124 | 125 | -------------------------------------------------------------------------------- /screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/VincentToups/raylib-chibi/d4f62cb5b90350b1b7e7acd9ad6d5e03b4ddb050/screenshot.png --------------------------------------------------------------------------------