Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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) 406002) ;; 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.