129 lines
3.9 KiB
Scheme
129 lines
3.9 KiB
Scheme
(define-record-type constant
|
|
(make-constant c-name scheme-name c-value-name type)
|
|
constant?
|
|
(c-name constant-c-name)
|
|
(scheme-name constant-scheme-name)
|
|
(c-value-name constant-c-value-name)
|
|
(type constant-type))
|
|
|
|
(define constant-type-int 'constant-type-int)
|
|
(define (constant-type-int? thing)
|
|
(equal? (constant-type thing) constant-type-int))
|
|
|
|
(define constant-type-char 'constant-type-char)
|
|
(define (constant-type-char? thing)
|
|
(equal? (constant-type thing) constant-type-char))
|
|
|
|
(define constant-type-string 'constant-type-string)
|
|
(define (constant-type-string? thing)
|
|
(equal? (constant-type thing) constant-type-string))
|
|
|
|
(define (constant-name->scheme-name constant-name)
|
|
(let ((replace-underscore
|
|
(lambda (c) (if (char=? c #\_) #\- c))))
|
|
(string-map replace-underscore (string-downcase constant-name))))
|
|
|
|
(define c-value-name-prefix "scheme_")
|
|
|
|
(define (constant-name->value-name constant-name)
|
|
(string-append c-value-name-prefix constant-name))
|
|
|
|
(define (make-constant-from-c-name c-name type)
|
|
(let ((scheme-name (constant-name->scheme-name c-name)))
|
|
(make-constant c-name scheme-name
|
|
(constant-name->value-name c-name)
|
|
type)))
|
|
|
|
(define (make-constant-from-c-name-integer c-name)
|
|
(make-constant-from-c-name c-name constant-type-int))
|
|
|
|
(define (generate-c-declarations constant-list)
|
|
(string-join
|
|
(map
|
|
(lambda (c)
|
|
(format "static s48_value ~a = S48_FALSE;~%"
|
|
(constant-c-value-name c)))
|
|
constant-list)))
|
|
|
|
(define (generate-c-gc-protect-globals constant-list)
|
|
(string-join
|
|
(map
|
|
(lambda (c)
|
|
(format "S48_GC_PROTECT_GLOBAL(~a);~%"
|
|
(constant-c-value-name c)))
|
|
constant-list)))
|
|
|
|
(define (generate-c-enter-value c)
|
|
(cond
|
|
((constant-type-int? c)
|
|
(format "~a = s48_enter_integer(~a);~%"
|
|
(constant-c-value-name c) (constant-c-name c)))
|
|
((constant-type-string? c)
|
|
(format "~a = s48_enter_integer(~a);~%"
|
|
(constant-c-value-name c) (constant-c-name c)))
|
|
(else
|
|
(error "Don't know how to handle this constant type: "
|
|
(constant-type c)))))
|
|
|
|
(define (generate-c-enter-values constant-list)
|
|
(string-join
|
|
(map generate-c-enter-value constant-list)))
|
|
|
|
(define (wrap-in-c-function fun-name body)
|
|
(format
|
|
(string-append
|
|
"void ~a(void) {~%"
|
|
"~a~%"
|
|
"}~%~%")
|
|
fun-name body))
|
|
|
|
(define (generate-c-enter-values-function c-fun-name constant-list)
|
|
(wrap-in-c-function c-fun-name
|
|
(generate-c-enter-values constant-list)))
|
|
|
|
(define (generate-c-gc-protect-globals-function c-fun-name constant-list)
|
|
(wrap-in-c-function c-fun-name
|
|
(generate-c-gc-protect-globals constant-list)))
|
|
|
|
;;; generating scheme code
|
|
|
|
(define (generate-finite-type-definition ft-name name-converter constants)
|
|
(let ((predicate-name (string-append ft-name "-object?"))
|
|
(elements-name (string-append ft-name "-elments"))
|
|
(name-name (string-append ft-name "-name"))
|
|
(index-name (string-append ft-name "-index"))
|
|
(id-name (string-append ft-name "-id")))
|
|
(format
|
|
(string-append
|
|
"(define-finite-type ~a :~a~%"
|
|
" (id)~%"
|
|
" ~a~% ~a~% ~a~% ~a~%"
|
|
" (~a)~%"
|
|
" ~a)~%~%")
|
|
ft-name ft-name
|
|
predicate-name elements-name name-name index-name
|
|
(string-append "id " id-name)
|
|
(generate-finite-type-items name-converter constants))))
|
|
|
|
(define (generate-finite-type-items name-converter constants)
|
|
(string-join
|
|
(map (lambda (c) (generate-finite-type-item name-converter c))
|
|
constants)))
|
|
|
|
(define (generate-finite-type-item name-converter constant)
|
|
(format " (~a\t(lookup-shared-binding \"~a\"))~%"
|
|
(name-converter constant)
|
|
(constant-c-value-name constant)))
|
|
|
|
(define (make-drop-common-prefix-name-converter prefix)
|
|
(let ((len (string-length prefix)))
|
|
(lambda (constant)
|
|
(let ((name (constant-c-name constant)))
|
|
(constant-name->scheme-name
|
|
(if (string-prefix? prefix name)
|
|
(string-drop name len)
|
|
name))))))
|
|
|
|
|
|
|