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