source: project/release/3/tcc/tcc.scm @ 33923

Last change on this file since 33923 was 6865, checked in by felix winkelmann, 12 years ago

removed deprecated features

File size: 4.2 KB
Line 
1;;;; tcc.scm
2
3(declare
4  (fixnum)
5  (hide error-list set-error-func tcc:error check)
6  (foreign-declare #<<EOF
7#include <libtcc.h>
8EOF
9) )
10
11(define-foreign-type tcc-state* (nonnull-pointer "TCCState"))
12
13(define-external (error_callback (c-pointer opaque) (c-string msg)) void
14  ;(print msg)
15  (error-list (cons msg (error-list))) )
16
17(define tcc:new
18  (let ([new (foreign-lambda tcc-state* "tcc_new")])
19    (lambda ()
20      (let ([s (new)])
21        (set-error-func s #f (location error_callback))
22        s) ) ) )
23
24(define (tcc:error loc msg args)
25  (signal
26   (make-composite-condition 
27    (make-property-condition 'exn 'message msg 'arguments args 'location loc)
28    (make-property-condition 'tcc) ) ) )
29
30(define (check loc thunk msg)
31  (parameterize ([error-list '()])
32    (let* ([r (thunk)]
33           [el (error-list)] )
34      (if (null? el)
35          r
36          (tcc:error loc msg el) ) ) ) )
37
38(define tcc:delete (foreign-lambda void "tcc_delete" tcc-state*))
39(define tcc:enable-debug (foreign-lambda void "tcc_enable_debug" tcc-state*))
40
41(define error-list (make-parameter '()))
42
43(define set-error-func (foreign-lambda void "tcc_set_error_func" tcc-state* c-pointer nonnull-c-pointer))
44
45(define tcc:set-warning (foreign-lambda bool "tcc_set_warning" tcc-state* c-string bool))
46(define tcc:add-include-path (foreign-lambda void "tcc_add_include_path" tcc-state* c-string))
47(define tcc:add-sysinclude-path (foreign-lambda void "tcc_add_sysinclude_path" tcc-state* c-string))
48(define tcc:define-symbol (foreign-lambda void "tcc_define_symbol" tcc-state* c-string c-string))
49(define tcc:undefine-symbol (foreign-lambda void "tcc_undefine_symbol" tcc-state* c-string))
50(define tcc:add-file (foreign-lambda int "tcc_add_file" tcc-state* c-string))
51
52(define tcc:compile-string
53  (let ([compile (foreign-safe-lambda int "tcc_compile_string" tcc-state* c-string)])
54    (lambda (s str)
55      (check 'tcc:compile-string (cut compile s str) "errors during compilation") ) ) )
56
57(define-foreign-variable tcc_output_memory int "TCC_OUTPUT_MEMORY")
58(define-foreign-variable tcc_output_exe int "TCC_OUTPUT_EXE")
59(define-foreign-variable tcc_output_dll int "TCC_OUTPUT_DLL")
60(define-foreign-variable tcc_output_obj int "TCC_OUTPUT_OBJ")
61(define tcc/output-memory tcc_output_memory)
62(define tcc/output-exe tcc_output_exe)
63(define tcc/output-dll tcc_output_dll)
64(define tcc/output-obj tcc_output_obj)
65
66(define tcc:set-output-type (foreign-lambda void "tcc_set_output_type" tcc-state* int))
67(define tcc:add-library-path (foreign-lambda void "tcc_add_library_path" tcc-state* c-string))
68(define tcc:add-library (foreign-lambda void "tcc_add_library" tcc-state* c-string))
69
70(define tcc:add-symbol
71  (let ([add (foreign-lambda void "tcc_add_symbol" tcc-state* c-string c-pointer)])
72    (lambda (s str ptr)
73      (check 'tcc:add-symbol (cut add s str ptr) "could not add symbol") ) ) )
74
75(define tcc:output-file
76  (let ([output (foreign-lambda int "tcc_output_file" tcc-state* c-string)])
77    (lambda (s fname)
78      (check 'tcc:output-file (cut output s fname) "generation of output file failed") ) ) )
79
80(define tcc:run
81  (foreign-safe-lambda* int ([tcc-state* state] [scheme-object args])
82    "char **argv, *ptr;"
83    "C_word arg;"
84    "int i, n, argc = C_unfix(C_i_length(args));"
85    "argv = (char **)C_malloc(argc * sizeof(char *));"
86    "if(argv == NULL) return(999);"
87    "for(i = 0; i < argc; ++i) {"
88    "  arg = C_block_item(args, 0);"
89    "  ptr = (char *)C_malloc((n = C_header_size(arg)) + 1);"
90    "  if(ptr == NULL) return(998);"
91    "  C_memcpy(ptr, C_data_pointer(arg), n);"
92    "  ptr[ n ] = '\\0';"
93    "  argv[ i ] = ptr;"
94    "  args = C_block_item(args, 1);"
95    "}"
96    "n = tcc_run(state, argc, argv);"
97    "for(i = 0; i < argc; ++i) C_free(argv[ i ]);"
98    "C_free(argv);"
99    "return(n);") )
100
101(define tcc:relocate
102  (let ([rel (foreign-lambda int "tcc_relocate" tcc-state*)])
103    (lambda (s)
104      (unless (zero? (rel s))
105        (tcc:error 'tcc:relocate "relocation failed" '()) ) ) ) )
106
107(define tcc:get-symbol
108  (let ([get (foreign-lambda int "tcc_get_symbol" tcc-state* c-pointer c-string)])
109    (lambda (s str)
110      (let-location ([val c-pointer])
111        (if (zero? (get s (location val) str))
112            val
113            (tcc:error 'tcc:get-symbol "can't get symbol" '()))))))
Note: See TracBrowser for help on using the repository browser.