1(import (yuni util tables scheme) 2 (rnrs) 3 (yuni core) (yuni util files) 4 (srfi :48) 5 (mosh pp) (nmosh ffi pffi) 6 (shorten)) 7 8(define targets '("src/ext" "src/posix" "src/win32" "src/generic" 9 "src/bsd")) 10 11(define (locate-Library) 12 (define libs '()) 13 (define (add-lib! lib) 14 (set! libs (cons lib libs))) 15 (for-each (^e (directory-walk 16 e 17 (^p (when (string=? (path-basename p) "Library.scm") 18 (add-lib! p))))) 19 targets) 20 libs) 21 22(define libs (locate-Library)) 23 24(define* constant (name value type)) 25 26(define (proc pth table*) 27 (define filename) 28 (define internal? #f) 29 (define myname #f) 30 (define libname) 31 (define constants '()) 32 (define exports '()) 33 (define objects '()) 34 (define (add-constant! name value type) 35 (add-export! name) 36 (set! constants 37 (cons (make constant 38 (name name) 39 (value value) 40 (type (if type type 'int))) 41 constants))) 42 (define (add-export! sym) 43 (set! exports (cons sym exports))) 44 (define (add-object! sym) 45 (set! objects (cons sym objects))) 46 (define (for-each-tablesym sym proc) 47 (for-each (^e 48 (when (table-metadata-ref e sym) 49 (proc e)) 50 proc table*) 51 table*)) 52 (define (collect-constants tbl) 53 (table-for-each tbl '(name value type) add-constant!)) 54 55 (define (convtype sym) 56 (define (pointer? str) 57 (char=? #\* (list-ref (reverse (string->list str)) 0))) 58 (let ((str (symbol->string sym))) 59 (case sym 60 ((int char* int* void* void) ;; verbatim output 61 sym) 62 ((fn) 63 ;; callback is not always a callback.. 64 'callback) 65 (else 66 (cond 67 ((pointer? str) 68 'void*) 69 (else 70 (assertion-violation #f "invalid type" sym))))))) 71 72 (define (output p) 73 (define (emit-function tbl) 74 (define (emit ret name args) 75 ;; emit function definition 76 (pp `(define ,name (pffi-c-function 77 %library 78 ,(convtype ret) 79 ,name ,@(if args (map convtype args) '()))) p)) 80 (table-for-each tbl '(ret name args) emit)) 81 ;; emit header 82 (format p ";; generated from ~a DO NOT EDIT!!\n" pth) 83 (format p "(library (nmosh stubs ~a)\n" myname) 84 (pp `(export ,@exports) p) 85 (pp '(import (mosh ffi) (rnrs) (nmosh ffi pffi) (nmosh ffi stublib)) p) 86 87 ;; emit globals (handle for shared-library or pffi) 88 (if internal? 89 (format p "\n\n(define %library (make-pffi-ref '~a))\n" libname) 90 (format p "\n\n(define-ffi-library %library ~a ~a)\n" libname libname)) 91 92 (newline p) 93 94 ;; emit constants 95 (let ((bodies (map (^e (let-with e (name value type) 96 (if (eq? type 'void*) 97 `(define ,name (integer->pointer ,value)) 98 `(define ,name ,value)))) 99 constants))) 100 (for-each (^e (pp e p)) bodies)) 101 102 (newline p) 103 104 ;; collect and emit functions 105 (for-each-tablesym 'c-function-table emit-function) 106 ;; emit footer 107 (display ")\n" p)) 108 109 ;; collect internal? 110 (for-each-tablesym '*internal* (^ _ (set! internal? #t))) 111 112 ;; collect myname 113 (for-each (^e (let ((name (table-metadata-ref e 'libname:))) 114 (when name (set! myname name)))) 115 table*) 116 117 (unless myname 118 (assertion-violation #f "Please specify library name" 119 pth)) 120 121 (set! filename (format "lib/nmosh/stubs/~a.mosh.sls" myname)) 122 123 ;; collect libname 124 (for-each (^e (let ((name (table-metadata-ref e 'libname:))) 125 (when name (set! libname name)))) 126 table*) 127 128 (unless libname 129 (assertion-violation #f "Please specify soname" 130 pth)) 131 132 ;; collect constants 133 (for-each-tablesym 'constant-table collect-constants) 134 ;; collect objects (opaque structures or typedefs) 135 ;; collect functions (pass1: exports) 136 (for-each-tablesym 'c-function-table 137 (^t (table-for-each 138 t 139 '(name) 140 (^[name] 141 (add-export! name))))) 142 143 ;; output 144 (when (file-exists? filename) 145 (delete-file filename)) 146 (call-with-output-file filename output) 147 (display filename)) 148 149(define (gen-lib pth) 150 (format #t "generating library for ~a\n" pth) 151 (proc pth (file->table-list pth)) 152 (display " generated.\n")) 153 154(for-each gen-lib libs) 155 156