Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

553 lines (506 sloc) 23.956 kB
;;;============================================================================
;;; File: "_parms.scm", Time-stamp: <2010-06-10 13:53:05 feeley>
;;; Copyright (c) 1994-2010 by Marc Feeley, All Rights Reserved.
(include "fixnum.scm")
;;;----------------------------------------------------------------------------
;; Compiler parameters module
;; --------------------------
;; This module contains definitions that parameterize the behavior of
;; the compiler.
;;;----------------------------------------------------------------------------
;; Specific symbols needed by the compiler.
(define **quote-sym (string->canonical-symbol "##quote"))
(define **quasiquote-sym (string->canonical-symbol "##quasiquote"))
(define **set!-sym (string->canonical-symbol "##set!"))
(define **lambda-sym (string->canonical-symbol "##lambda"))
(define **if-sym (string->canonical-symbol "##if"))
(define **cond-sym (string->canonical-symbol "##cond"))
(define **and-sym (string->canonical-symbol "##and"))
(define **or-sym (string->canonical-symbol "##or"))
(define **case-sym (string->canonical-symbol "##case"))
(define **let-sym (string->canonical-symbol "##let"))
(define **let*-sym (string->canonical-symbol "##let*"))
(define **letrec-sym (string->canonical-symbol "##letrec"))
(define **do-sym (string->canonical-symbol "##do"))
(define **delay-sym (string->canonical-symbol "##delay"))
(define **future-sym (string->canonical-symbol "##future"))
(define **c-define-type-sym (string->canonical-symbol "##c-define-type"))
(define **c-declare-sym (string->canonical-symbol "##c-declare"))
(define **c-initialize-sym (string->canonical-symbol "##c-initialize"))
(define **c-lambda-sym (string->canonical-symbol "##c-lambda"))
(define **c-define-sym (string->canonical-symbol "##c-define"))
(define **begin-sym (string->canonical-symbol "##begin"))
(define **define-sym (string->canonical-symbol "##define"))
(define **define-macro-sym (string->canonical-symbol "##define-macro"))
(define **define-syntax-sym (string->canonical-symbol "##define-syntax"))
(define **include-sym (string->canonical-symbol "##include"))
(define **declare-sym (string->canonical-symbol "##declare"))
(define **namespace-sym (string->canonical-symbol "##namespace"))
(define **this-source-file-sym (string->canonical-symbol "##this-source-file"))
(define quote-sym (string->canonical-symbol "quote"))
(define set!-sym (string->canonical-symbol "set!"))
(define define-sym (string->canonical-symbol "define"))
(define if-sym (string->canonical-symbol "if"))
(define and-sym (string->canonical-symbol "and"))
(define or-sym (string->canonical-symbol "or"))
(define lambda-sym (string->canonical-symbol "lambda"))
(define let-sym (string->canonical-symbol "let"))
(define letrec-sym (string->canonical-symbol "letrec"))
(define future-sym (string->canonical-symbol "future"))
(define =>-sym (string->canonical-symbol "=>"))
(define else-sym (string->canonical-symbol "else"))
(define not-sym (string->canonical-symbol "not"))
(define quasiquote-sym (string->canonical-symbol "quasiquote"))
(define unquote-sym (string->canonical-symbol "unquote"))
(define unquote-splicing-sym (string->canonical-symbol "unquote-splicing"))
(define **not-sym (string->canonical-symbol "##not"))
(define **eq?-sym (string->canonical-symbol "##eq?"))
(define **eqv?-sym (string->canonical-symbol "##eqv?"))
(define **quasi-append-sym (string->canonical-symbol "##quasi-append"))
(define **quasi-list-sym (string->canonical-symbol "##quasi-list"))
(define **quasi-cons-sym (string->canonical-symbol "##quasi-cons"))
(define **quasi-list->vector-sym (string->canonical-symbol "##quasi-list->vector"))
(define **quasi-vector-sym (string->canonical-symbol "##quasi-vector"))
(define **case-memv-sym (string->canonical-symbol "##case-memv"))
(define **box-sym (string->canonical-symbol "##box"))
(define **unbox-sym (string->canonical-symbol "##unbox"))
(define **set-box!-sym (string->canonical-symbol "##set-box!"))
(define **make-promise-sym (string->canonical-symbol "##make-promise"))
(define ieee-scheme-sym (string->canonical-symbol "ieee-scheme"))
(define r4rs-scheme-sym (string->canonical-symbol "r4rs-scheme"))
(define r5rs-scheme-sym (string->canonical-symbol "r5rs-scheme"))
(define gambit-scheme-sym (string->canonical-symbol "gambit-scheme"))
(define multilisp-sym (string->canonical-symbol "multilisp"))
(define constant-fold-sym (string->canonical-symbol "constant-fold"))
(define lambda-lift-sym (string->canonical-symbol "lambda-lift"))
(define inline-sym (string->canonical-symbol "inline"))
(define inline-primitives-sym (string->canonical-symbol "inline-primitives"))
(define inlining-limit-sym (string->canonical-symbol "inlining-limit"))
(define block-sym (string->canonical-symbol "block"))
(define separate-sym (string->canonical-symbol "separate"))
(define core-sym (string->canonical-symbol "core"))
(define standard-bindings-sym (string->canonical-symbol "standard-bindings"))
(define extended-bindings-sym (string->canonical-symbol "extended-bindings"))
(define run-time-bindings-sym (string->canonical-symbol "run-time-bindings"))
(define safe-sym (string->canonical-symbol "safe"))
(define warnings-sym (string->canonical-symbol "warnings"))
(define interrupts-enabled-sym (string->canonical-symbol "interrupts-enabled"))
(define debug-sym (string->canonical-symbol "debug"))
(define debug-location-sym (string->canonical-symbol "debug-location"))
(define debug-source-sym (string->canonical-symbol "debug-source"))
(define debug-environments-sym (string->canonical-symbol "debug-environments"))
(define environment-map-sym (string->canonical-symbol "environment-map")) ;; deprecated: use debug-environments
(define proper-tail-calls-sym (string->canonical-symbol "proper-tail-calls"))
(define optimize-dead-local-variables-sym (string->canonical-symbol "optimize-dead-local-variables"))
(define generic-sym (string->canonical-symbol "generic"))
(define fixnum-sym (string->canonical-symbol "fixnum"))
(define flonum-sym (string->canonical-symbol "flonum"))
(define mostly-generic-sym (string->canonical-symbol "mostly-generic"))
(define mostly-fixnum-sym (string->canonical-symbol "mostly-fixnum"))
(define mostly-flonum-sym (string->canonical-symbol "mostly-flonum"))
(define mostly-fixnum-flonum-sym (string->canonical-symbol "mostly-fixnum-flonum"))
(define mostly-flonum-fixnum-sym (string->canonical-symbol "mostly-flonum-fixnum"))
(define int8-sym (string->canonical-symbol "int8"))
(define unsigned-int8-sym (string->canonical-symbol "unsigned-int8"))
(define int16-sym (string->canonical-symbol "int16"))
(define unsigned-int16-sym (string->canonical-symbol "unsigned-int16"))
(define int32-sym (string->canonical-symbol "int32"))
(define unsigned-int32-sym (string->canonical-symbol "unsigned-int32"))
(define int64-sym (string->canonical-symbol "int64"))
(define unsigned-int64-sym (string->canonical-symbol "unsigned-int64"))
(define float32-sym (string->canonical-symbol "float32"))
(define float64-sym (string->canonical-symbol "float64"))
(define void-sym (string->canonical-symbol "void"))
(define char-sym (string->canonical-symbol "char"))
(define signed-char-sym (string->canonical-symbol "signed-char"))
(define unsigned-char-sym (string->canonical-symbol "unsigned-char"))
(define ISO-8859-1-sym (string->canonical-symbol "ISO-8859-1"))
(define UCS-2-sym (string->canonical-symbol "UCS-2"))
(define UCS-4-sym (string->canonical-symbol "UCS-4"))
(define wchar_t-sym (string->canonical-symbol "wchar_t"))
(define short-sym (string->canonical-symbol "short"))
(define unsigned-short-sym (string->canonical-symbol "unsigned-short"))
(define int-sym (string->canonical-symbol "int"))
(define unsigned-int-sym (string->canonical-symbol "unsigned-int"))
(define long-sym (string->canonical-symbol "long"))
(define unsigned-long-sym (string->canonical-symbol "unsigned-long"))
(define long-long-sym (string->canonical-symbol "long-long"))
(define unsigned-long-long-sym (string->canonical-symbol "unsigned-long-long"))
(define float-sym (string->canonical-symbol "float"))
(define double-sym (string->canonical-symbol "double"))
(define struct-sym (string->canonical-symbol "struct"))
(define union-sym (string->canonical-symbol "union"))
(define type-sym (string->canonical-symbol "type"))
(define pointer-sym (string->canonical-symbol "pointer"))
(define nonnull-pointer-sym (string->canonical-symbol "nonnull-pointer"))
(define function-sym (string->canonical-symbol "function"))
(define nonnull-function-sym (string->canonical-symbol "nonnull-function"))
(define bool-sym (string->canonical-symbol "bool"))
(define char-string-sym (string->canonical-symbol "char-string"))
(define nonnull-char-string-sym(string->canonical-symbol "nonnull-char-string"))
(define nonnull-char-string-list-sym(string->canonical-symbol "nonnull-char-string-list"))
(define ISO-8859-1-string-sym (string->canonical-symbol "ISO-8859-1-string"))
(define nonnull-ISO-8859-1-string-sym(string->canonical-symbol "nonnull-ISO-8859-1-string"))
(define nonnull-ISO-8859-1-string-list-sym(string->canonical-symbol "nonnull-ISO-8859-1-string-list"))
(define UTF-8-string-sym (string->canonical-symbol "UTF-8-string"))
(define nonnull-UTF-8-string-sym(string->canonical-symbol "nonnull-UTF-8-string"))
(define nonnull-UTF-8-string-list-sym(string->canonical-symbol "nonnull-UTF-8-string-list"))
(define UTF-16-string-sym (string->canonical-symbol "UTF-16-string"))
(define nonnull-UTF-16-string-sym(string->canonical-symbol "nonnull-UTF-16-string"))
(define nonnull-UTF-16-string-list-sym(string->canonical-symbol "nonnull-UTF-16-string-list"))
(define UCS-2-string-sym (string->canonical-symbol "UCS-2-string"))
(define nonnull-UCS-2-string-sym(string->canonical-symbol "nonnull-UCS-2-string"))
(define nonnull-UCS-2-string-list-sym(string->canonical-symbol "nonnull-UCS-2-string-list"))
(define UCS-4-string-sym (string->canonical-symbol "UCS-4-string"))
(define nonnull-UCS-4-string-sym(string->canonical-symbol "nonnull-UCS-4-string"))
(define nonnull-UCS-4-string-list-sym(string->canonical-symbol "nonnull-UCS-4-string-list"))
(define wchar_t-string-sym (string->canonical-symbol "wchar_t-string"))
(define nonnull-wchar_t-string-sym(string->canonical-symbol "nonnull-wchar_t-string"))
(define nonnull-wchar_t-string-list-sym(string->canonical-symbol "nonnull-wchar_t-string-list"))
(define VARIANT-sym (string->symbol "VARIANT"))
(define scheme-object-sym (string->canonical-symbol "scheme-object"))
;;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Note: Module prefix and C id prefix must match the definitions
;; in the "gambit.h" header file.
(define module-prefix " ") ;; Identifier prefix for module names.
(define c-id-prefix "___") ;; Identifier prefix for C identifiers generated by
;; the C-interface and the C back-end.
;;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; C types available to the C-interface.
(define scheme-to-c-notation
(list
(cons void-sym ;; Scheme name
(vector 'c-type
"void" ;; C type
#f ;; C to Scheme converter
#f ;; Scheme to C converter
#f)) ;; cleanup needed on Scheme->C conversion
(cons int8-sym
(vector 'c-type
(string-append c-id-prefix "S8")
"S8_TO_SCMOBJ"
"SCMOBJ_TO_S8"
#f))
(cons unsigned-int8-sym
(vector 'c-type
(string-append c-id-prefix "U8")
"U8_TO_SCMOBJ"
"SCMOBJ_TO_U8"
#f))
(cons int16-sym
(vector 'c-type
(string-append c-id-prefix "S16")
"S16_TO_SCMOBJ"
"SCMOBJ_TO_S16"
#f))
(cons unsigned-int16-sym
(vector 'c-type
(string-append c-id-prefix "U16")
"U16_TO_SCMOBJ"
"SCMOBJ_TO_U16"
#f))
(cons int32-sym
(vector 'c-type
(string-append c-id-prefix "S32")
"S32_TO_SCMOBJ"
"SCMOBJ_TO_S32"
#f))
(cons unsigned-int32-sym
(vector 'c-type
(string-append c-id-prefix "U32")
"U32_TO_SCMOBJ"
"SCMOBJ_TO_U32"
#f))
(cons int64-sym
(vector 'c-type
(string-append c-id-prefix "S64")
"S64_TO_SCMOBJ"
"SCMOBJ_TO_S64"
#f))
(cons unsigned-int64-sym
(vector 'c-type
(string-append c-id-prefix "U64")
"U64_TO_SCMOBJ"
"SCMOBJ_TO_U64"
#f))
(cons float32-sym
(vector 'c-type
(string-append c-id-prefix "F32")
"F32_TO_SCMOBJ"
"SCMOBJ_TO_F32"
#f))
(cons float64-sym
(vector 'c-type
(string-append c-id-prefix "F64")
"F64_TO_SCMOBJ"
"SCMOBJ_TO_F64"
#f))
(cons char-sym
(vector 'c-type
"char"
"CHAR_TO_SCMOBJ"
"SCMOBJ_TO_CHAR"
#f))
(cons signed-char-sym
(vector 'c-type
(string-append c-id-prefix "SCHAR")
"SCHAR_TO_SCMOBJ"
"SCMOBJ_TO_SCHAR"
#f))
(cons unsigned-char-sym
(vector 'c-type
"unsigned char"
"UCHAR_TO_SCMOBJ"
"SCMOBJ_TO_UCHAR"
#f))
(cons ISO-8859-1-sym
(vector 'c-type
(string-append c-id-prefix "ISO_8859_1")
"ISO_8859_1_TO_SCMOBJ"
"SCMOBJ_TO_ISO_8859_1"
#f))
(cons UCS-2-sym
(vector 'c-type
(string-append c-id-prefix "UCS_2")
"UCS_2_TO_SCMOBJ"
"SCMOBJ_TO_UCS_2"
#f))
(cons UCS-4-sym
(vector 'c-type
(string-append c-id-prefix "UCS_4")
"UCS_4_TO_SCMOBJ"
"SCMOBJ_TO_UCS_4"
#f))
(cons wchar_t-sym
(vector 'c-type
(string-append c-id-prefix "WCHAR")
"WCHAR_TO_SCMOBJ"
"SCMOBJ_TO_WCHAR"
#f))
(cons short-sym
(vector 'c-type
"short"
"SHORT_TO_SCMOBJ"
"SCMOBJ_TO_SHORT"
#f))
(cons unsigned-short-sym
(vector 'c-type
"unsigned short"
"USHORT_TO_SCMOBJ"
"SCMOBJ_TO_USHORT"
#f))
(cons int-sym
(vector 'c-type
"int"
"INT_TO_SCMOBJ"
"SCMOBJ_TO_INT"
#f))
(cons unsigned-int-sym
(vector 'c-type
"unsigned int"
"UINT_TO_SCMOBJ"
"SCMOBJ_TO_UINT"
#f))
(cons long-sym
(vector 'c-type
"long"
"LONG_TO_SCMOBJ"
"SCMOBJ_TO_LONG"
#f))
(cons unsigned-long-sym
(vector 'c-type
"unsigned long"
"ULONG_TO_SCMOBJ"
"SCMOBJ_TO_ULONG"
#f))
(cons long-long-sym
(vector 'c-type
(string-append c-id-prefix "LONGLONG")
"LONGLONG_TO_SCMOBJ"
"SCMOBJ_TO_LONGLONG"
#f))
(cons unsigned-long-long-sym
(vector 'c-type
(string-append c-id-prefix "ULONGLONG")
"ULONGLONG_TO_SCMOBJ"
"SCMOBJ_TO_ULONGLONG"
#f))
(cons float-sym
(vector 'c-type
"float"
"FLOAT_TO_SCMOBJ"
"SCMOBJ_TO_FLOAT"
#f))
(cons double-sym
(vector 'c-type
"double"
"DOUBLE_TO_SCMOBJ"
"SCMOBJ_TO_DOUBLE"
#f))
(cons bool-sym
(vector 'c-type
(string-append c-id-prefix "BOOL")
"BOOL_TO_SCMOBJ"
"SCMOBJ_TO_BOOL"
#f))
(cons char-string-sym
(vector 'c-type
"char*"
"CHARSTRING_TO_SCMOBJ"
"SCMOBJ_TO_CHARSTRING"
#t))
(cons nonnull-char-string-sym
(vector 'c-type
"char*"
"NONNULLCHARSTRING_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLCHARSTRING"
#t))
(cons nonnull-char-string-list-sym
(vector 'c-type
"char**"
"NONNULLCHARSTRINGLIST_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLCHARSTRINGLIST"
#t))
(cons ISO-8859-1-string-sym
(vector 'c-type
(string-append c-id-prefix "ISO_8859_1STRING")
"ISO_8859_1STRING_TO_SCMOBJ"
"SCMOBJ_TO_ISO_8859_1STRING"
#t))
(cons nonnull-ISO-8859-1-string-sym
(vector 'c-type
(string-append c-id-prefix "ISO_8859_1STRING")
"NONNULLISO_8859_1STRING_TO_SCMOBJ"
"SCMOBJ_TO_ISO_8859_1STRING"
#t))
(cons nonnull-ISO-8859-1-string-list-sym
(vector 'c-type
(string-append c-id-prefix "ISO_8859_1STRING*")
"NONNULLISO_8859_1STRINGLIST_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLISO_8859_1STRINGLIST"
#t))
(cons UTF-8-string-sym
(vector 'c-type
(string-append c-id-prefix "UTF_8STRING")
"UTF_8STRING_TO_SCMOBJ"
"SCMOBJ_TO_UTF_8STRING"
#t))
(cons nonnull-UTF-8-string-sym
(vector 'c-type
(string-append c-id-prefix "UTF_8STRING")
"NONNULLUTF_8STRING_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLUTF_8STRING"
#t))
(cons nonnull-UTF-8-string-list-sym
(vector 'c-type
(string-append c-id-prefix "UTF_8STRING*")
"NONNULLUTF_8STRINGLIST_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLUTF_8STRINGLIST"
#t))
(cons UTF-16-string-sym
(vector 'c-type
(string-append c-id-prefix "UTF_16STRING")
"UTF_16STRING_TO_SCMOBJ"
"SCMOBJ_TO_UTF_16STRING"
#t))
(cons nonnull-UTF-16-string-sym
(vector 'c-type
(string-append c-id-prefix "UTF_16STRING")
"NONNULLUTF_16STRING_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLUTF_16STRING"
#t))
(cons nonnull-UTF-16-string-list-sym
(vector 'c-type
(string-append c-id-prefix "UTF_16STRING*")
"NONNULLUTF_16STRINGLIST_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLUTF_16STRINGLIST"
#t))
(cons UCS-2-string-sym
(vector 'c-type
(string-append c-id-prefix "UCS_2STRING")
"UCS_2STRING_TO_SCMOBJ"
"SCMOBJ_TO_UCS_2STRING"
#t))
(cons nonnull-UCS-2-string-sym
(vector 'c-type
(string-append c-id-prefix "UCS_2STRING")
"NONNULLUCS_2STRING_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLUCS_2STRING"
#t))
(cons nonnull-UCS-2-string-list-sym
(vector 'c-type
(string-append c-id-prefix "UCS_2STRING*")
"NONNULLUCS_2STRINGLIST_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLUCS_2STRINGLIST"
#t))
(cons UCS-4-string-sym
(vector 'c-type
(string-append c-id-prefix "UCS_4STRING")
"UCS_4STRING_TO_SCMOBJ"
"SCMOBJ_TO_UCS_4STRING"
#t))
(cons nonnull-UCS-4-string-sym
(vector 'c-type
(string-append c-id-prefix "UCS_4STRING")
"NONNULLUCS_4STRING_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLUCS_4STRING"
#t))
(cons nonnull-UCS-4-string-list-sym
(vector 'c-type
(string-append c-id-prefix "UCS_4STRING*")
"NONNULLUCS_4STRINGLIST_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLUCS_4STRINGLIST"
#t))
(cons wchar_t-string-sym
(vector 'c-type
(string-append c-id-prefix "WCHARSTRING")
"WCHARSTRING_TO_SCMOBJ"
"SCMOBJ_TO_WCHARSTRING"
#t))
(cons nonnull-wchar_t-string-sym
(vector 'c-type
(string-append c-id-prefix "WCHARSTRING")
"NONNULLWCHARSTRING_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLWCHARSTRING"
#t))
(cons nonnull-wchar_t-string-list-sym
(vector 'c-type
(string-append c-id-prefix "WCHARSTRING*")
"NONNULLWCHARSTRINGLIST_TO_SCMOBJ"
"SCMOBJ_TO_NONNULLWCHARSTRINGLIST"
#t))
(cons VARIANT-sym
(vector 'c-type
(string-append c-id-prefix "VARIANT")
"VARIANT_TO_SCMOBJ"
"SCMOBJ_TO_VARIANT"
#t))
(cons scheme-object-sym
(vector 'c-type
(string-append c-id-prefix "SCMOBJ")
"SCMOBJ_TO_SCMOBJ"
"SCMOBJ_TO_SCMOBJ"
#f))))
;;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
;; Gambit system version numbers.
(define (compiler-version) 406006) ;; 100000*major + 1000*minor + revision
(define compiler-version-string-prefix "v")
(define compiler-version-string-suffix "")
(define (compiler-version-string)
(let* ((version
(compiler-version))
(major
(quotient version 100000))
(minor
(modulo (quotient version 1000) 100))
(build
(modulo version 1000)))
(string-append
compiler-version-string-prefix
(number->string major)
"."
(number->string minor)
"."
(number->string build)
compiler-version-string-suffix)))
;;;============================================================================
Jump to Line
Something went wrong with that request. Please try again.