Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Removing unecessary mangling. By default strip namespace prefixes from class names.

Browse source
This commit is contained in:
Alex Shinn 2014-12-26 11:04:13 +09:00
parent 3e25733208
commit 0cce37aaa8
1 changed files with 28 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
tools/chibi-ffi
View file

@ -384,6 +384,21 @@
((8) "SEXP_EIGHT") ((9) "SEXP_NINE") ((10) "SEXP_TEN") ((8) "SEXP_EIGHT") ((9) "SEXP_NINE") ((10) "SEXP_TEN")
(else (string-append "sexp_make_fixnum(" (x->string x) ")")))) (else (string-append "sexp_make_fixnum(" (x->string x) ")"))))
(define (string-scan-right str ch)
(let lp ((i (string-cursor-end str)))
(let ((i2 (string-cursor-prev str i)))
(cond ((string-cursor<? i2 0) 0)
((eqv? ch (string-cursor-ref str i2)) i)
(else (lp i2))))))
(define (strip-namespace x)
(string->symbol
(let* ((x (x->string x))
(i (string-scan-right x #\:)))
(if (> i 0)
(substring-cursor x i)
x))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; .stub file interface ;; .stub file interface
@ -1546,17 +1561,18 @@
(define (write-type orig-type) (define (write-type orig-type)
(let* ((name (car orig-type)) (let* ((name (car orig-type))
(scheme-name (strip-namespace (type-name name)))
(type (cdr orig-type)) (type (cdr orig-type))
(imported? (cond ((member 'imported?: type) => cadr) (else #f)))) (imported? (cond ((member 'imported?: type) => cadr) (else #f))))
(cond (cond
(imported? (imported?
(cat " name = sexp_intern(ctx, \"" (type-name name) "\", -1);\n" (cat " name = sexp_intern(ctx, \"" scheme-name "\", -1);\n"
" " (type-id-name name) " = sexp_env_ref(env, name, SEXP_FALSE);\n" " " (type-id-name name) " = sexp_env_ref(env, name, SEXP_FALSE);\n"
" if (sexp_not(" (type-id-name name) ")) {\n" " if (sexp_not(" (type-id-name name) ")) {\n"
" sexp_warn(ctx, \"couldn't import declared type: \", name);\n" " sexp_warn(ctx, \"couldn't import declared type: \", name);\n"
" }\n")) " }\n"))
(else (else
(cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" (cat " name = sexp_c_string(ctx, \"" scheme-name "\", -1);\n"
" " (type-id-name name) " " (type-id-name name)
" = sexp_register_c_type(ctx, name, " " = sexp_register_c_type(ctx, name, "
(cond ((or (memq 'finalizer: type) (cond ((or (memq 'finalizer: type)
@ -1601,8 +1617,10 @@
(define (type-getter-name type name field) (define (type-getter-name type name field)
(let ((c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field)))) (let ((c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field))))
(string-append "sexp_" (x->string (type-name (parse-type name))) (string-replace
"_get_" (x->string c-name)))) (string-append "sexp_" (x->string (type-name (parse-type name)))
"_get_" (x->string c-name))
#\: "_")))
(define (verify-accessor field) (define (verify-accessor field)
(if (and (pair? field) (if (and (pair? field)
@ -1616,7 +1634,7 @@
(c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field))) (c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field)))
(ptr (string-append (ptr (string-append
"((" (x->string (or (type-struct-type name) "")) "((" (x->string (or (type-struct-type name) ""))
" " (mangle name) "*)" " " (x->string name) "*)"
"sexp_cpointer_value(x))"))) "sexp_cpointer_value(x))")))
(cat "static sexp " (type-getter-name type name field) (cat "static sexp " (type-getter-name type name field)
" (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n" " (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
@ -1643,8 +1661,10 @@
(define (type-setter-name type name field) (define (type-setter-name type name field)
(let ((c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field)))) (let ((c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field))))
(string-append "sexp_" (x->string (type-name (parse-type name))) (string-replace
"_set_" (x->string c-name)))) (string-append "sexp_" (x->string (type-name (parse-type name)))
"_set_" (x->string c-name))
#\: "_")))
(define (write-type-setter-assignment type name field dst val) (define (write-type-setter-assignment type name field dst val)
(let* ((set (cadr (cddr field))) (let* ((set (cadr (cddr field)))
@ -1652,7 +1672,7 @@
(c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field))) (c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field)))
(ptr (string-append (ptr (string-append
"((" (x->string (or (type-struct-type name) "")) "((" (x->string (or (type-struct-type name) ""))
" " (mangle name) "*)" " " (x->string name) "*)"
"sexp_cpointer_value(" (x->string dst) "))"))) "sexp_cpointer_value(" (x->string dst) "))")))
(cond (cond
((and (pair? set) (eq? 'function: (cadr set))) ((and (pair? set) (eq? 'function: (cadr set)))
@ -1937,13 +1957,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; main ;; main
(define (string-scan-right str ch)
(let lp ((i (string-cursor-end str)))
(let ((i2 (string-cursor-prev str i)))
(cond ((string-cursor<? i2 0) 0)
((eqv? ch (string-cursor-ref str i2)) i)
(else (lp i2))))))
(let* ((args (command-line)) (let* ((args (command-line))
(args (if (pair? args) (cdr args) args)) (args (if (pair? args) (cdr args) args))
(compile? (and (pair? args) (member (car args) '("-c" "--compile")))) (compile? (and (pair? args) (member (car args) '("-c" "--compile"))))