Changeset 13240 in project


Ignore:
Timestamp:
02/10/09 17:33:27 (11 years ago)
Author:
felix winkelmann
Message:

merged trunk svn rev. 13239 into prerelease

Location:
chicken/branches/prerelease
Files:
22 deleted
103 edited
95 copied

Legend:

Unmodified
Added
Removed
  • chicken/branches/prerelease

  • chicken/branches/prerelease/Makefile

    r11958 r13240  
    22#
    33# Copyright (c) 2007, Felix L. Winkelmann
    4 # Copyright (c) 2008, The Chicken Team
     4# Copyright (c) 2008-2009, The Chicken Team
    55# All rights reserved.
    66#
     
    7979bootstrap:
    8080        $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bootstrap
     81bench:
     82        $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bench
    8183endif
  • chicken/branches/prerelease/Makefile.bsd

    r11958 r13240  
    22#
    33# Copyright (c) 2007, Felix L. Winkelmann
    4 # Copyright (c) 2008, The Chicken Team
     4# Copyright (c) 2008-2009, The Chicken Team
    55# All rights reserved.
    66#
     
    4141endif
    4242LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
    43 LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(LIBDIR)
     43LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -shared -Wl,-R$(RUNTIME_LINKER_PATH) -Wl,-L.
     44LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(RUNTIME_LINKER_PATH)
    4445LIBRARIES = -lm
     46NEEDS_RELINKING = yes
    4547
    4648# special files
  • chicken/branches/prerelease/Makefile.cross-linux-mingw

    r11975 r13240  
    22#
    33# Copyright (c) 2007, Felix L. Winkelmann
    4 # Copyright (c) 2008, The Chicken Team
     4# Copyright (c) 2008-2009, The Chicken Team
    55# All rights reserved.
    66#
     
    7979# main target
    8080
     81ifndef BUILD_SETUP_TOOLS
    8182TARGETS = libchicken$(A) libuchicken$(A) chicken$(EXE) csi$(EXE) \
    8283        chicken-profile$(EXE) csc$(EXE) libchicken$(SO) \
    8384        libuchicken$(SO) chicken-setup$(EXE) chicken.info \
    8485        libchickengui$(SO) chicken-bug$(EXE)
     86else
     87TARGETS = libchicken$(A) libuchicken$(A) chicken$(EXE) csi$(EXE) \
     88        chicken-profile$(EXE) csc$(EXE) libchicken$(SO) \
     89        libuchicken$(SO) chicken-install$(EXE) chicken-uninstall$(EXE) \
     90        chicken-status$(EXE) chicken.info \
     91        libchickengui$(SO) chicken-bug$(EXE)
     92endif
    8593
    8694chicken-config.h: chicken-defaults.h
  • chicken/branches/prerelease/Makefile.cygwin

    r11958 r13240  
    22#
    33# Copyright (c) 2007, Felix L. Winkelmann
    4 # Copyright (c) 2008, The Chicken Team
     4# Copyright (c) 2008-2009, The Chicken Team
    55# All rights reserved.
    66#
     
    131131        echo "/* generated */" >$@
    132132        echo "#define C_BUILD_TAG \"$(BUILD_TAG)\"" >>$@
     133        echo "#define C_CHICKEN_PROGRAM \"$(CHICKEN_PROGRAM)$(EXE)\"" >>$@
     134        echo "#define C_SVN_REVISION $(shell cat buildsvnrevision)" >>$@
    133135        echo "#ifndef C_INSTALL_CC" >>$@
    134136        echo "# define C_INSTALL_CC \"$(C_COMPILER)\"" >>$@
     
    170172        echo "# define C_DEFAULT_TARGET_STACK_SIZE $(NURSERY)" >>$@
    171173        echo "#endif" >>$@
     174        echo "#ifndef C_DEFAULT_TARGET_HEAP_SIZE" >>$@
     175        echo "# define C_DEFAULT_TARGET_HEAP_SIZE 0" >>$@
     176        echo "#endif" >>$@
    172177        echo "#ifndef C_STACK_GROWS_DOWNWARD" >>$@
    173178        echo "# define C_STACK_GROWS_DOWNWARD $(STACKDIRECTION)" >>$@
     
    194199        echo "# define C_CROSS_CHICKEN $(CROSS_CHICKEN)" >>$@
    195200        echo "#endif" >>$@
     201        echo "#ifndef C_TARGET_BIN_HOME" >>$@
     202        echo "# define C_TARGET_BIN_HOME \"$(TARGET_PREFIX)/bin\"" >>$@
     203        echo "#endif" >>$@
    196204        echo "#ifndef C_TARGET_LIB_HOME" >>$@
    197205        echo "# define C_TARGET_LIB_HOME \"$(TARGET_PREFIX)/bin\"" >>$@
     
    218226        echo "# define C_CSI_PROGRAM \"$(CSI_PROGRAM)\"" >>$@
    219227        echo "#endif" >>$@
    220         echo "#ifndef C_CHICKEN_PROFILE_PROGRAM" >>$@
    221         echo "# define C_CHICKEN_PROFILE_PROGRAM \"$(CHICKEN_PROFILE_PROGRAM)\"" >>$@
    222         echo "#endif" >>$@
    223         echo "#ifndef C_CHICKEN_SETUP_PROGRAM" >>$@
    224         echo "# define C_CHICKEN_SETUP_PROGRAM \"$(CHICKEN_SETUP_PROGRAM)\"" >>$@
    225         echo "#endif" >>$@
    226228        echo "#ifndef C_CHICKEN_BUG_PROGRAM" >>$@
    227229        echo "# define C_CHICKEN_BUG_PROGRAM \"$(CHICKEN_BUG_PROGRAM)\"" >>$@
    228230        echo "#endif" >>$@
     231        echo "#ifndef C_WINDOWS_SHELL" >>$@
     232        echo "# define C_WINDOWS_SHELL 0" >>$@
     233        echo "#endif" >>$@
     234        echo "#ifndef C_BINARY_VERSION" >>$@
     235        echo "# define C_BINARY_VERSION $(BINARYVERSION)" >>$@
     236        echo "#endif" >>$@
    229237
    230238include $(SRCDIR)/rules.make
  • chicken/branches/prerelease/Makefile.linux

    r11975 r13240  
    22#
    33# Copyright (c) 2007, Felix L. Winkelmann
    4 # Copyright (c) 2008, The Chicken Team
     4# Copyright (c) 2008-2009, The Chicken Team
    55# All rights reserved.
    66#
     
    4444endif
    4545LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
    46 RUNTIME_LINKER_PATH = $(shell pwd)
     46LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -L. -shared -Wl,-R$(RUNTIME_LINKER_PATH)
    4747LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(RUNTIME_LINKER_PATH)
    4848LIBRARIES = -lm -ldl
     
    9797        echo "#define C_HACKED_APPLY" >>$@
    9898endif
    99 ifneq ($(USE_HOST_PCRE),)
    100         echo "#define C_USE_HOST_PCRE" >>$@
    101 endif
    10299        cat chicken-defaults.h >>$@
    103100
  • chicken/branches/prerelease/Makefile.macosx

    r11958 r13240  
    22#
    33# Copyright (c) 2007, Felix L. Winkelmann
    4 # Copyright (c) 2008, The Chicken Team
     4# Copyright (c) 2008-2009, The Chicken Team
    55# All rights reserved.
    66#
     
    4747POSTINSTALL_PROGRAM_FLAGS = -change libchicken$(SO) $(LIBDIR)/libchicken$(SO)
    4848LIBRARIAN_OPTIONS = scru
     49LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -bundle -L.
    4950
    5051# file extensions
  • chicken/branches/prerelease/Makefile.mingw

    r11958 r13240  
    22#
    33# Copyright (c) 2007, Felix L. Winkelmann
    4 # Copyright (c) 2008, The Chicken Team
     4# Copyright (c) 2008-2009, The Chicken Team
    55# All rights reserved.
    66#
     
    2626
    2727
    28 SRCDIR = .\\
     28SEP = \\
     29SRCDIR =.$(SEP)
    2930
    3031# platform configuration
     
    3435HACKED_APPLY = 1
    3536WINDOWS = 1
    36 NO_UNIX_SHELL = 1
     37WINDOWS_SHELL = 1
     38UNAME_SYS = MinGW
    3739
    3840# file extensions
     
    4345# options
    4446
     47C_COMPILER ?= gcc
    4548C_COMPILER_OPTIONS = -fno-strict-aliasing -DHAVE_CHICKEN_CONFIG_H
    4649ifdef DEBUGBUILD
     
    8083all: libchicken$(A) libuchicken$(A) chicken$(EXE) csi$(EXE) chicken-profile$(EXE) \
    8184        csc$(EXE) libchicken$(SO) \
    82         libuchicken$(SO) libchickengui$(SO) libchickengui$(A) chicken-setup$(EXE) \
    83         chicken.info
     85        libuchicken$(SO) libchickengui$(SO) libchickengui$(A) chicken-install$(EXE) \
     86        chicken-status$(EXE) chicken-uninstall$(EXE) chicken.info
    8487
    8588chicken-config.h: chicken-defaults.h
     
    127130        echo /* generated */ >$@
    128131        echo #define C_BUILD_TAG "$(BUILD_TAG)" >>$@
     132        echo #define C_CHICKEN_PROGRAM "$(CHICKEN_PROGRAM)$(EXE)" >>$@
     133        echo #define C_WINDOWS_SHELL 1 >>$@
    129134        echo #ifndef C_INSTALL_CC >>$@
    130135        echo # define C_INSTALL_CC "$(C_COMPILER)" >>$@
     
    140145        echo #endif >>$@
    141146        echo #ifndef C_INSTALL_SHARE_HOME >>$@
    142         echo # define C_INSTALL_SHARE_HOME "$(IDATADIR)" >>$@
     147        echo # define C_INSTALL_SHARE_HOME "$(DATADIR)" >>$@
    143148        echo #endif >>$@
    144149        echo #ifndef C_INSTALL_BIN_HOME >>$@
    145         echo # define C_INSTALL_BIN_HOME "$(IBINDIR)" >>$@
     150        echo # define C_INSTALL_BIN_HOME "$(BINDIR)" >>$@
    146151        echo #endif >>$@
    147152        echo #ifndef C_INSTALL_EGG_HOME >>$@
    148         echo # define C_INSTALL_EGG_HOME "$(IEGGDIR)" >>$@
     153        echo # define C_INSTALL_EGG_HOME "$(EGGDIR)" >>$@
    149154        echo #endif >>$@
    150155        echo #ifndef C_INSTALL_LIB_HOME >>$@
    151         echo # define C_INSTALL_LIB_HOME "$(ILIBDIR)" >>$@
     156        echo # define C_INSTALL_LIB_HOME "$(LIBDIR)" >>$@
    152157        echo #endif >>$@
    153158        echo #ifndef C_INSTALL_STATIC_LIB_HOME >>$@
    154         echo # define C_INSTALL_STATIC_LIB_HOME "$(ILIBDIR)" >>$@
     159        echo # define C_INSTALL_STATIC_LIB_HOME "$(LIBDIR)" >>$@
    155160        echo #endif >>$@
    156161        echo #ifndef C_INSTALL_INCLUDE_HOME >>$@
    157         echo # define C_INSTALL_INCLUDE_HOME "$(IINCDIR)" >>$@
     162        echo # define C_INSTALL_INCLUDE_HOME "$(INCDIR)" >>$@
    158163        echo #endif >>$@
    159164        echo #ifndef C_INSTALL_MORE_LIBS >>$@
     
    166171        echo # define C_DEFAULT_TARGET_STACK_SIZE $(NURSERY) >>$@
    167172        echo #endif >>$@
     173        echo #ifndef C_DEFAULT_TARGET_HEAP_SIZE >>$@
     174        echo # define C_DEFAULT_TARGET_HEAP_SIZE 0 >>$@
     175        echo #endif >>$@
    168176        echo #ifndef C_STACK_GROWS_DOWNWARD >>$@
    169177        echo # define C_STACK_GROWS_DOWNWARD $(STACKDIRECTION) >>$@
     
    190198        echo # define C_CROSS_CHICKEN $(CROSS_CHICKEN) >>$@
    191199        echo #endif >>$@
     200        echo #ifndef C_TARGET_BIN_HOME >>$@
     201        echo # define C_TARGET_BIN_HOME "$(TARGET_PREFIX)/bin" >>$@
     202        echo #endif >>$@
    192203        echo #ifndef C_TARGET_LIB_HOME >>$@
    193         echo # define C_TARGET_LIB_HOME "$(TARGET_PREFIX)\\lib" >>$@
     204        echo # define C_TARGET_LIB_HOME "$(TARGET_PREFIX)/lib" >>$@
    194205        echo #endif >>$@
    195206        echo #ifndef C_TARGET_RUN_LIB_HOME >>$@
    196         echo # define C_TARGET_RUN_LIB_HOME "$(TARGET_PREFIX)\\lib" >>$@
     207        echo # define C_TARGET_RUN_LIB_HOME "$(TARGET_PREFIX)/lib" >>$@
    197208        echo #endif >>$@
    198209        echo #ifndef C_TARGET_SHARE_HOME >>$@
    199         echo # define C_TARGET_SHARE_HOME "$(TARGET_PREFIX)\\share" >>$@
     210        echo # define C_TARGET_SHARE_HOME "$(TARGET_PREFIX)/share" >>$@
    200211        echo #endif >>$@
    201212        echo #ifndef C_TARGET_INCLUDE_HOME >>$@
    202         echo # define C_TARGET_INCLUDE_HOME "$(TARGET_PREFIX)\\include" >>$@
     213        echo # define C_TARGET_INCLUDE_HOME "$(TARGET_PREFIX)/include" >>$@
    203214        echo #endif >>$@
    204215        echo #ifndef C_TARGET_STATIC_LIB_HOME >>$@
    205         echo # define C_TARGET_STATIC_LIB_HOME "$(TARGET_PREFIX)\\lib" >>$@
    206         echo #endif >>$@
     216        echo # define C_TARGET_STATIC_LIB_HOME "$(TARGET_PREFIX)/lib" >>$@
     217        echo #endif >>$@
     218        echo #ifndef C_CSC_PROGRAM" >>$@
     219        echo # define C_CSC_PROGRAM "$(CSC_PROGRAM)" >>$@
     220        echo #endif" >>$@
     221        echo #ifndef C_CSI_PROGRAM" >>$@
     222        echo # define C_CSI_PROGRAM "$(CSI_PROGRAM)" >>$@
     223        echo #endif" >>$@
     224        echo #ifndef C_CHICKEN_BUG_PROGRAM" >>$@
     225        echo # define C_CHICKEN_BUG_PROGRAM "$(CHICKEN_BUG_PROGRAM)" >>$@
     226        echo #endif" >>$@
    207227        echo #ifndef C_BINARY_VERSION >>$@
    208228        echo # define C_BINARY_VERSION $(BINARYVERSION) >>$@
  • chicken/branches/prerelease/Makefile.mingw-msys

    r11958 r13240  
    1 # Makefile.mingw - configuration for MinGW (no MSYS) -*- Makefile -*-
     1# Makefile.mingw - configuration for MinGW (MSYS) -*- Makefile -*-
    22#
    33# Copyright (c) 2007, Felix L. Winkelmann
    4 # Copyright (c) 2008, The Chicken Team
     4# Copyright (c) 2008-2009, The Chicken Team
    55# All rights reserved.
    66#
     
    7676all: libchicken$(A) libuchicken$(A) chicken$(EXE) csi$(EXE) chicken-profile$(EXE) \
    7777        csc$(EXE) libchicken$(SO) \
    78         libuchicken$(SO) libchickengui$(SO) libchickengui$(A) chicken-setup$(EXE) \
    79         chicken.info
     78        libuchicken$(SO) libchickengui$(SO) libchickengui$(A) chicken-install$(EXE) \
     79        chicken-uninstall$(EXE) chicken-status$(EXE) chicken.info
    8080
    8181chicken-config.h: chicken-defaults.h
     
    107107        echo "#define HAVE_WINSOCK2_H 1" >>$@
    108108        echo "#define HAVE_WS2TCPIP_H 1" >>$@
     109        echo "#define C_WINDOWS_SHELL 1" >>$@
    109110        echo "#define C_STACK_GROWS_DOWNWARD 1" >>$@
    110111ifdef GCHOOKS
  • chicken/branches/prerelease/Makefile.msvc

    r11958 r13240  
    22#
    33# Copyright (c) 2007, Felix L. Winkelmann
     4# Copyright (c) 2008-2009 The Chicken Team
    45# All rights reserved.
    56#
     
    3334# Germany
    3435
    35 PREFIX = c:\\msvc-devtools
    36 SRCDIR = .\\
     36SEP = \\
     37SRCDIR = .$(SEP)
    3738
    3839# platform configuration
     
    4243HACKED_APPLY =
    4344WINDOWS = 1
     45WINDOWS_SHELL = 1
     46UNAME_SYS = win32
    4447
    4548# file extensions
     
    6164# options
    6265
    63 C_COMPILER_OPTIONS = -nologo -MD -wd4142 -DHAVE_CHICKEN_CONFIG_H
     66C_COMPILER_OPTIONS = -nologo -wd4142 -DHAVE_CHICKEN_CONFIG_H
     67C_COMPILER_STATIC_OPTIONS = -MT
     68C_COMPILER_SHARED_OPTIONS = -MD -DPIC
    6469LINKER_OPTIONS = -nologo
    6570C_COMPILER_GUI_RUNTIME_OPTIONS = -DC_WINDOWS_GUI
     
    7075
    7176ifdef DEBUGBUILD
    72 C_COMPILER_OPTIONS = -nologo -MDd -DHAVE_CHICKEN_CONFIG_H
    73 C_COMPILER_OPTIMIZATION_OPTIONS = -Zi
     77C_COMPILER_OPTIONS = -nologo -DHAVE_CHICKEN_CONFIG_H
     78#C_COMPILER_OPTIMIZATION_OPTIONS = -Zi
     79C_COMPILER_SHARED_OPTIONS = -MDd -DPIC
    7480LINKER_OPTIONS += -debug
    7581endif
     
    8086C_COMPILER_OUTPUT_OPTION = -Fo
    8187C_COMPILER_OUTPUT = $(C_COMPILER_OUTPUT_OPTION)$@
    82 
    8388C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS = $(C_COMPILER_BUILD_RUNTIME_OPTIONS) -DC_UNSAFE_RUNTIME
    84 C_COMPILER_SHARED_OPTIONS = -DPIC
    8589
    8690# linker-dependent output options
     
    9498LINKER_LIBRARY_SUFFIX = .lib
    9599LINKER_LINK_SHARED_LIBRARY_OPTIONS = -dll
     100LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -dll
    96101
    97102PROGRAM_IMPORT_LIBRARIES = chicken.lib csi.lib csc.lib chicken-setup.lib chicken-profile.lib chicken-bug.lib
     
    144149CSC_MANIFEST = $(CSC_PROGRAM)$(EXE)$(MANIFEST)
    145150CHICKEN_BUG_MANIFEST = $(CHICKEN_BUG_PROGRAM)$(EXE)$(MANIFEST)
     151ifndef BUILD_SETUP_TOOLS
    146152CHICKEN_SETUP_MANIFEST = $(CHICKEN_SETUP_PROGRAM)$(EXE)$(MANIFEST)
    147 
    148153CLEAN_MANIFESTS = $(CHICKEN_MANIFEST) $(CSI_MANIFEST) $(CHICKEN_PROFILE_MANIFEST) \
    149154                  $(CSC_MANIFEST) $(CHICKEN_BUG_MANIFEST) $(CHICKEN_SETUP_MANIFEST) \
    150155                  $(LIBCHICKEN_SO_FILE)$(MANIFEST) $(LIBUCHICKEN_SO_FILE)$(MANIFEST) \
    151156                  $(LIBCHICKENGUI_SO_FILE)$(MANIFEST)
     157else
     158CHICKEN_INSTALL_MANIFEST = $(CHICKEN_INSTALL_PROGRAM)$(EXE)$(MANIFEST)
     159CHICKEN_UNINSTALL_MANIFEST = $(CHICKEN_UNINSTALL_PROGRAM)$(EXE)$(MANIFEST)
     160CHICKEN_STATUS_MANIFEST = $(CHICKEN_STATUS_PROGRAM)$(EXE)$(MANIFEST)
     161CLEAN_MANIFESTS = $(CHICKEN_MANIFEST) $(CSI_MANIFEST) $(CHICKEN_PROFILE_MANIFEST) \
     162                  $(CSC_MANIFEST) $(CHICKEN_BUG_MANIFEST) $(CHICKEN_INSTALL_MANIFEST) \
     163                  $(CHICKEN_UNINSTALL_MANIFEST) $(CHICKEN_STATUS_MANIFEST) \
     164                  $(LIBCHICKEN_SO_FILE)$(MANIFEST) $(LIBUCHICKEN_SO_FILE)$(MANIFEST) \
     165                  $(LIBCHICKENGUI_SO_FILE)$(MANIFEST)
     166endif
    152167
    153168# special files
     
    158173POSIXFILE = posixwin
    159174
    160 # default settings (the default chicken-defaults.h seems to be fine)
     175CUSTOM_CHICKEN_DEFAULTS=1
     176
     177# default settings
    161178
    162179include defaults.make
     
    170187
    171188chicken-config.h: chicken-defaults.h
    172         echo "#define HAVE_DIRENT_H 0" >>$@
    173         echo "#define HAVE_INTTYPES_H 0" >>$@
    174         echo "#define HAVE_LIMITS_H 1" >>$@
    175         echo "#define HAVE_LONG_LONG 1" >>$@
    176         echo "#define HAVE_MEMMOVE 1" >>$@
    177         echo "#define HAVE_MEMORY_H 1" >>$@
    178         echo "#define HAVE_STDINT_H 0" >>$@
    179         echo "#define HAVE_STDLIB_H 1" >>$@
    180         echo "#define HAVE_STRERROR 1" >>$@
    181         echo "#define HAVE_STRINGS_H 0" >>$@
    182         echo "#define HAVE_STRING_H 1" >>$@
    183         echo "#define HAVE_STRTOLL 0" >>$@
    184         echo "#define HAVE_SYS_STAT_H 1" >>$@
    185         echo "#define HAVE_SYS_TYPES_H 1" >>$@
    186         echo "#define HAVE_UNISTD_H 0" >>$@
    187         echo "#define HAVE_UNSIGNED_LONG_LONG 0" >>$@
    188         echo "#define HAVE_WINDOWS_H 1" >>$@
    189         echo "#define HAVE__STRTOI64 1" >>$@
    190         echo "#define STDC_HEADERS 1" >>$@
    191         echo "#define HAVE_ALLOCA_H 0" >>$@
    192         echo "#define HAVE_DIRECT_H 1" >>$@
    193         echo "#define HAVE_ERRNO_H 1" >>$@
    194         echo "#define HAVE_GCVT 1" >>$@
    195         echo "#define HAVE_LOADLIBRARY 1" >>$@
    196         echo "#define HAVE_GETPROCADDRESS 1" >>$@
    197         echo "#define HAVE_WINSOCK2_H 1" >>$@
    198         echo "#define HAVE_WS2TCPIP_H 1" >>$@
    199         echo "#define C_STACK_GROWS_DOWNWARD 1" >>$@
     189        echo #define HAVE_DIRENT_H 0 >>$@
     190        echo #define HAVE_INTTYPES_H 0 >>$@
     191        echo #define HAVE_LIMITS_H 1 >>$@
     192        echo #define HAVE_LONG_LONG 1 >>$@
     193        echo #define HAVE_MEMMOVE 1 >>$@
     194        echo #define HAVE_MEMORY_H 1 >>$@
     195        echo #define HAVE_STDINT_H 0 >>$@
     196        echo #define HAVE_STDLIB_H 1 >>$@
     197        echo #define HAVE_STRERROR 1 >>$@
     198        echo #define HAVE_STRINGS_H 0 >>$@
     199        echo #define HAVE_STRING_H 1 >>$@
     200        echo #define HAVE_STRTOLL 0 >>$@
     201        echo #define HAVE_SYS_STAT_H 1 >>$@
     202        echo #define HAVE_SYS_TYPES_H 1 >>$@
     203        echo #define HAVE_UNISTD_H 0 >>$@
     204        echo #define HAVE_UNSIGNED_LONG_LONG 0 >>$@
     205        echo #define HAVE_WINDOWS_H 1 >>$@
     206        echo #define HAVE__STRTOI64 1 >>$@
     207        echo #define STDC_HEADERS 1 >>$@
     208        echo #define HAVE_ALLOCA_H 0 >>$@
     209        echo #define HAVE_DIRECT_H 1 >>$@
     210        echo #define HAVE_ERRNO_H 1 >>$@
     211        echo #define HAVE_GCVT 1 >>$@
     212        echo #define HAVE_LOADLIBRARY 1 >>$@
     213        echo #define HAVE_GETPROCADDRESS 1 >>$@
     214        echo #define HAVE_WINSOCK2_H 1 >>$@
     215        echo #define HAVE_WS2TCPIP_H 1 >>$@
     216        echo #define C_STACK_GROWS_DOWNWARD 1 >>$@
    200217ifdef GCHOOKS
    201         echo "#define C_GC_HOOKS" >>$@
     218        echo #define C_GC_HOOKS >>$@
    202219endif
    203220ifdef SYMBOLGC
    204         echo "#define C_COLLECT_ALL_SYMBOLS" >>$@
     221        echo #define C_COLLECT_ALL_SYMBOLS >>$@
    205222endif
    206223ifdef NOAPPLYHOOK
    207         echo "#define C_NO_APPLY_HOOK" >>$@
    208 endif
    209         echo "#define C_HACKED_APPLY" >>$@
     224        echo #define C_NO_APPLY_HOOK >>$@
     225endif
     226        echo #define C_HACKED_APPLY >>$@
    210227        cat chicken-defaults.h >>$@
    211228
    212 include rules.make
     229chicken-defaults.h:
     230        echo /* generated */ >$@
     231        echo #define C_BUILD_TAG "$(BUILD_TAG)" >>$@
     232        echo #define C_CHICKEN_PROGRAM "$(CHICKEN_PROGRAM)$(EXE)" >>$@
     233        echo #define C_WINDOWS_SHELL 1 >>$@
     234        echo #ifndef C_INSTALL_CC >>$@
     235        echo # define C_INSTALL_CC "$(C_COMPILER)" >>$@
     236        echo #endif >>$@
     237        echo #ifndef C_INSTALL_CXX >>$@
     238        echo # define C_INSTALL_CXX "$(CXX_COMPILER)" >>$@
     239        echo #endif >>$@
     240        echo #ifndef C_INSTALL_CFLAGS >>$@
     241        echo # define C_INSTALL_CFLAGS "$(C_COMPILER_OPTIONS) $(C_COMPILER_OPTIMIZATION_OPTIONS)" >>$@
     242        echo #endif >>$@
     243        echo #ifndef C_INSTALL_LDFLAGS >>$@
     244        echo # define C_INSTALL_LDFLAGS "$(LINKER_OPTIONS) $(LINKER_OPTIMIZATION_OPTIONS)" >>$@
     245        echo #endif >>$@
     246        echo #ifndef C_INSTALL_SHARE_HOME >>$@
     247        echo # define C_INSTALL_SHARE_HOME "$(DATADIR)" >>$@
     248        echo #endif >>$@
     249        echo #ifndef C_INSTALL_BIN_HOME >>$@
     250        echo # define C_INSTALL_BIN_HOME "$(BINDIR)" >>$@
     251        echo #endif >>$@
     252        echo #ifndef C_INSTALL_EGG_HOME >>$@
     253        echo # define C_INSTALL_EGG_HOME "$(EGGDIR)" >>$@
     254        echo #endif >>$@
     255        echo #ifndef C_INSTALL_LIB_HOME >>$@
     256        echo # define C_INSTALL_LIB_HOME "$(LIBDIR)" >>$@
     257        echo #endif >>$@
     258        echo #ifndef C_INSTALL_STATIC_LIB_HOME >>$@
     259        echo # define C_INSTALL_STATIC_LIB_HOME "$(LIBDIR)" >>$@
     260        echo #endif >>$@
     261        echo #ifndef C_INSTALL_INCLUDE_HOME >>$@
     262        echo # define C_INSTALL_INCLUDE_HOME "$(INCDIR)" >>$@
     263        echo #endif >>$@
     264        echo #ifndef C_INSTALL_MORE_LIBS >>$@
     265        echo # define C_INSTALL_MORE_LIBS "$(LIBRARIES)" >>$@
     266        echo #endif >>$@
     267        echo #ifndef C_INSTALL_MORE_STATIC_LIBS >>$@
     268        echo # define C_INSTALL_MORE_STATIC_LIBS "$(LIBRARIES)" >>$@
     269        echo #endif >>$@
     270        echo #ifndef C_DEFAULT_TARGET_STACK_SIZE >>$@
     271        echo # define C_DEFAULT_TARGET_STACK_SIZE $(NURSERY) >>$@
     272        echo #endif >>$@
     273        echo #ifndef C_DEFAULT_TARGET_HEAP_SIZE >>$@
     274        echo # define C_DEFAULT_TARGET_HEAP_SIZE 0 >>$@
     275        echo #endif >>$@
     276        echo #ifndef C_STACK_GROWS_DOWNWARD >>$@
     277        echo # define C_STACK_GROWS_DOWNWARD $(STACKDIRECTION) >>$@
     278        echo #endif >>$@
     279        echo #ifndef C_TARGET_MORE_LIBS >>$@
     280        echo # define C_TARGET_MORE_LIBS "$(TARGET_LIBRARIES)" >>$@
     281        echo #endif >>$@
     282        echo #ifndef C_TARGET_MORE_STATIC_LIBS >>$@
     283        echo # define C_TARGET_MORE_STATIC_LIBS "$(TARGET_LIBRARIES)" >>$@
     284        echo #endif >>$@
     285        echo #ifndef C_TARGET_CC >>$@
     286        echo # define C_TARGET_CC "$(TARGET_C_COMPILER)" >>$@
     287        echo #endif >>$@
     288        echo #ifndef C_TARGET_CXX >>$@
     289        echo # define C_TARGET_CXX "$(TARGET_CXX_COMPILER)" >>$@
     290        echo #endif >>$@
     291        echo #ifndef C_TARGET_CFLAGS >>$@
     292        echo # define C_TARGET_CFLAGS "$(TARGET_C_COMPILER_OPTIONS) $(TARGET_C_COMPILER_OPTIMIZATION_OPTIONS)" >>$@
     293        echo #endif >>$@
     294        echo #ifndef C_TARGET_LDFLAGS >>$@
     295        echo # define C_TARGET_LDFLAGS "$(TARGET_LINKER_OPTIONS) $(TARGET_LINKER_OPTIMIZATION_OPTIONS)" >>$@
     296        echo #endif >>$@
     297        echo #ifndef C_CROSS_CHICKEN >>$@
     298        echo # define C_CROSS_CHICKEN $(CROSS_CHICKEN) >>$@
     299        echo #endif >>$@
     300        echo #ifndef C_TARGET_BIN_HOME >>$@
     301        echo # define C_TARGET_BIN_HOME "$(TARGET_PREFIX)/bin" >>$@
     302        echo #endif >>$@
     303        echo #ifndef C_TARGET_LIB_HOME >>$@
     304        echo # define C_TARGET_LIB_HOME "$(TARGET_PREFIX)/lib" >>$@
     305        echo #endif >>$@
     306        echo #ifndef C_TARGET_RUN_LIB_HOME >>$@
     307        echo # define C_TARGET_RUN_LIB_HOME "$(TARGET_PREFIX)/lib" >>$@
     308        echo #endif >>$@
     309        echo #ifndef C_TARGET_SHARE_HOME >>$@
     310        echo # define C_TARGET_SHARE_HOME "$(TARGET_PREFIX)/share" >>$@
     311        echo #endif >>$@
     312        echo #ifndef C_TARGET_INCLUDE_HOME >>$@
     313        echo # define C_TARGET_INCLUDE_HOME "$(TARGET_PREFIX)/include" >>$@
     314        echo #endif >>$@
     315        echo #ifndef C_TARGET_STATIC_LIB_HOME >>$@
     316        echo # define C_TARGET_STATIC_LIB_HOME "$(TARGET_PREFIX)/lib" >>$@
     317        echo #endif >>$@
     318        echo #ifndef C_CSC_PROGRAM" >>$@
     319        echo # define C_CSC_PROGRAM "$(CSC_PROGRAM)" >>$@
     320        echo #endif" >>$@
     321        echo #ifndef C_CSI_PROGRAM" >>$@
     322        echo # define C_CSI_PROGRAM "$(CSI_PROGRAM)" >>$@
     323        echo #endif" >>$@
     324        echo #ifndef C_CHICKEN_BUG_PROGRAM" >>$@
     325        echo # define C_CHICKEN_BUG_PROGRAM "$(CHICKEN_BUG_PROGRAM)" >>$@
     326        echo #endif" >>$@
     327        echo #ifndef C_BINARY_VERSION >>$@
     328        echo # define C_BINARY_VERSION $(BINARYVERSION) >>$@
     329        echo #endif >>$@
     330
     331include $(SRCDIR)rules.make
  • chicken/branches/prerelease/Makefile.solaris

    r11958 r13240  
    22#
    33# Copyright (c) 2007, Felix L. Winkelmann
    4 # Copyright (c) 2008, The Chicken Team
     4# Copyright (c) 2008-2009, The Chicken Team
    55# All rights reserved.
    66#
     
    3030# platform configuration
    3131
    32 ARCH = $(shell sh $SRCDIR/config-arch.sh)
     32ARCH = $(shell sh $(SRCDIR)/config-arch.sh)
    3333
    3434# options
     
    4141endif
    4242LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
    43 LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(LIBDIR)
     43LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -shared -Wl,-R$(RUNTIME_LINKER_PATH) -Wl,-L.
     44LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(RUNTIME_LINKER_PATH)
    4445LIBRARIES = -lrt -lsocket -lnsl -lm -ldl
     46NEEDS_RELINKING = yes
    4547
    4648# special files
  • chicken/branches/prerelease/NEWS

    r11958 r13240  
     14.0.0x5
     2
     3- replaced PCRE regex engine with Alex Shinn's "irregex" regular expression
     4  package
     5- removed `-extension' option
     6- removed `-static-extensions' csc option and added `-static-extension NAME'
     7- `regex' unit: removed `regexp*' and `regex-optimize'
     8- added `CHICKEN_new_finalizable_gc_root()'
     9- `length' checks its argument for being cyclic
     10
     114.0.0x3
     12
     13- removed custom declarations and "link-options" and "c-options" declarations
     14- deprecated "-quiet" option to "chicken" program
     15- added "-update-db" option to chicken-install
     16- the compiler now suggests possibly required module-imports
     17
     184.0.0x2
     19
     20- moved non-standard syntax-definitions into "chicken-syntax" library unit
     21- the pretty-printer prints the end-of-file object readably now
     22- alternative conditional execution paths have separate allocation computation
     23  (previously the allocation of all alternatives was coalesced)
     24- removed unused "%kmp-search" from "srfi-13" library unit
     25- expander handles syntax-reexports and makes unexported syntax available
     26  for exported expanders in import libraries
     27- added checks in some procedures in the the "tcp" library unit.
     28
     294.0.0x1
     30
     31- the macro system has been completely overhauled and converted
     32  to hygienic macros
     33- a macro-aware module system has been added
     34- added "-sx" option to csi
     35- removed the following deprecated functions:
     36   [un]shift!
     37   andmap ormap
     38   byte-vector? byte-vector-fill!
     39   make-byte-vector byte-vector
     40   byte-vector-set! byte-vector-ref
     41   byte-vector->list list->byte-vector
     42   string->byte-vector byte-vector->string
     43   byte-vector-length
     44   make-static-byte-vector static-byte-vector->pointer
     45   byte-vector-move! byte-vector-append!
     46   set-file-position! set-user-id! set-group-id!
     47   set-process-group-id!
     48- the situation-identifiers "run-time" and "compile-time" have
     49  been removed
     50- the compiler options "-check-imports", "-import" and "-emit-exports"
     51  have been removed
     52- new procedures:
     53  strip-syntax
     54  expand
     55- new macros
     56  define-syntax
     57  module
     58  export
     59- the following macros have been removed:
     60    define-foreign-record
     61    define-foreign-enum
     62    define-macro
     63    define-extension
     64- "local" mode, in which locally defined exported toplevel variables can
     65  be inlined
     66- new options and declarations "[-]local", "[-]inline-global" and "-emit-inline-file"
     67- optimization levels changed to use inlining:
     68  -optimize-level 3: enables -inline -local (but *not* -unsafe)
     69  -optimize-level 4: enables -inline -local -unsafe
     70- increased default inlining-limit to 20
     71- support for cross-module inlining
     72- "make <VARIABLES> bench" runs the benchmark suite
     73- "chicken-setup" has been replaced by new command line tools
     74  "chicken-install", "chicken-uninstall" and "chicken-status", which are
     75  more flexible and allow greater freedom when creating local or application-
     76  specific repositories
     77- extension-installation can be done directly from SVN repositories or a local
     78  file tree.
     79- enabled chicken mirror site as alternative download location
     80
    1813.4.0
    282
     
    47127  variables, or by -build-prefix and -download-dir options,
    48128  respectively; -destdir option is replaced with -install-prefix.
     129- unit regex: PCRE 7.6
    49130- unit tcp: use of offset into string rather than substring for faster
    50131  socket write [Jim Ursetto]
  • chicken/branches/prerelease/README

    r11962 r13240  
    11
    22  README file for the CHICKEN compiler
    3   (c)2000-2008 Felix L. Winkelmann
    4 
    5   version 3.4.0
     3  (c) 2000-2007, Felix L. Winkelmann
     4  (c) 2008-2009, The Chicken Team
     5
     6  version 4.0.0x5
     7
    68
    79 1. Introduction:
     
    160162          <http://chicken.wiki.br/cross-compilation>.
    161163
    162         USE_HOST_PCRE=
    163           The PCRE library is included with the CHICKEN
    164           distribution to remove external dependencies and to avoid
    165           incompatibilities with any previously installed version. If
    166           you want to link with an installed libpcre, set this
    167           variable to a non-empty value. Only use this feature if you
    168           know what you are doing.
    169 
    170164        SRCDIR=
    171165          Specifies that CHICKEN should be built outside of its source
     
    288282          absolute path name (i.e. it must include the drive letter).
    289283
     284        - When installing under mingw, with a windows shell ("cmd.exe"),
     285          pass an absolute pathname as PREFIX and use forward slashes.
     286
    290287        - Cygwin will not be able to find the chicken shared libraries
    291288          until Windows is rebooted.
  • chicken/branches/prerelease/apply-hack.ppc.darwin.s

    r9381 r13240  
    22;
    33; Copyright (c) 2007, Felix L. Winkelmann
    4 ; Copyright (c) 2008 The Chicken Team
     4; Copyright (c) 2008-2009 The Chicken Team
    55; All rights reserved.
    66;
  • chicken/branches/prerelease/apply-hack.ppc.sysv.s

    r9381 r13240  
    22;
    33; Copyright (c) 2007, Felix L. Winkelmann
    4 ; Copyright (c) 2008, The Chicken Team
     4; Copyright (c) 2008-2009, The Chicken Team
    55; All rights reserved.         
    66;
  • chicken/branches/prerelease/apply-hack.sparc64.s

    r7829 r13240  
    11/* apply-hack.ppc.s
    22;
    3 ; Copyright (c) 2008, Peter Bex
     3; Copyright (c) 2008-2009, Peter Bex
    44; All rights reserved.
    55;
  • chicken/branches/prerelease/apply-hack.x86-64.s

    r9381 r13240  
    22;
    33; Copyright (c) 2007, Felix L. Winkelmann
    4 ; Copyright (c) 2008, The Chicken Team
     4; Copyright (c) 2008-2009, The Chicken Team
    55; All rights reserved.
    66;
  • chicken/branches/prerelease/apply-hack.x86.s

    r9381 r13240  
    22;
    33; Copyright (c) 2007, Felix L. Winkelmann
    4 ; Copyright (c) 2008, The Chicken Team
     4; Copyright (c) 2008-2009, The Chicken Team
    55; All rights reserved.
    66;
  • chicken/branches/prerelease/banner.scm

    r9381 r13240  
     1;;;; banner.scm
     2
     3
     4(define-constant +product+ "CHICKEN")
     5
    16(define-constant +banner+ #<<EOF
    2 
    3 CHICKEN
    4 (c)2008 The Chicken Team
     7(c)2008-2009 The Chicken Team
    58(c)2000-2007 Felix L. Winkelmann
    69
  • chicken/branches/prerelease/batch-driver.scm

    r11632 r13240  
    22;
    33; Copyright (c) 2000-2007, Felix L. Winkelmann
    4 ; Copyright (c) 2008, The Chicken Team
     4; Copyright (c) 2008-2009, The Chicken Team
    55; All rights reserved.
    66;
     
    3434 compiler
    3535  compiler-arguments process-command-line dump-nodes dump-undefined-globals
    36   default-standard-bindings default-extended-bindings side-effecting-standard-bindings
    37   non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
    38   standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
    39   compiler-cleanup-hook check-global-exports disabled-warnings check-global-imports
     36  default-standard-bindings default-extended-bindings
     37  foldable-bindings
     38  compiler-cleanup-hook disabled-warnings local-definitions inline-output-file
    4039  file-io-only undefine-shadowed-macros profiled-procedures
    41   unit-name insert-timer-checks used-units inline-max-size
     40  unit-name insert-timer-checks used-units inline-max-size inline-locally
    4241  debugging perform-lambda-lifting! disable-stack-overflow-checking
    4342  foreign-declarations emit-trace-info block-compilation line-number-database-size
     
    4645  target-initial-heap-size postponed-initforms
    4746  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
    48   rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants
    49   broken-constant-nodes inline-substitutions-enabled compiler-macros-enabled
     47  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
     48  broken-constant-nodes inline-substitutions-enabled
    5049  emit-profile profile-lambda-list profile-lambda-index profile-info-vector-name
    5150  direct-call-ids foreign-type-table first-analysis emit-closure-info
     
    5453  reorganize-recursive-bindings substitution-table simplify-named-call emit-unsafe-marker
    5554  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda*
    56   transform-direct-lambdas! source-filename
     55  transform-direct-lambdas! source-filename standalone-executable
    5756  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
    5857  string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant?
     
    6564  default-declarations units-used-by-default words-per-flonum default-debugging-declarations
    6665  default-profiling-declarations default-optimization-passes
    67   inline-max-size file-requirements use-import-table lookup-exports-file
     66  file-requirements import-libraries inline-globally
    6867  foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators
    6968  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
    7069  chop-separator chop-extension display-real-name-table display-line-number-database explicit-use-flag
    7170  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
    72   export-list do-lambda-lifting compiler-warning export-file-name
     71  do-lambda-lifting compiler-warning emit-global-inline-file load-inline-file
    7372  foreign-argument-conversion foreign-result-conversion)
    7473
     
    7776
    7877(define-constant default-profile-name "PROFILE")
    79 (define-constant default-inline-max-size 10)
    8078(define-constant funny-message-timeout 60000)
     79
     80(define user-options-pass (make-parameter #f))
     81(define user-read-pass (make-parameter #f))
     82(define user-preprocessor-pass (make-parameter #f))
     83(define user-pass (make-parameter #f))
     84(define user-pass-2 (make-parameter #f))
     85(define user-post-analysis-pass (make-parameter #f))
    8186
    8287
     
    9499  (set! explicit-use-flag (memq 'explicit-use options))
    95100  (let ([initforms `((##core#declare
    96                       ,@(map (lambda (x) `(quote ,x))
    97                              (append
    98                               default-declarations
    99                               (if explicit-use-flag
    100                                   '()
    101                                   `((uses ,@units-used-by-default)) ) ) ) ) ) ]
     101                      ,@(append
     102                         default-declarations
     103                         (if explicit-use-flag
     104                             '()
     105                             `((uses ,@units-used-by-default)) ) ) ) ) ]
    102106        [verbose (memq 'verbose options)]
    103107        [outfile (cond [(memq 'output-file options)
     
    127131        [dynamic (memq 'dynamic options)]
    128132        [dumpnodes #f]
    129         [quiet (memq 'quiet options)]
    130133        [start-time #f]
    131134        (upap #f)
     
    134137    (define (cputime) (##sys#fudge 6))
    135138
     139    (define (dribble fstr . args)
     140      (when verbose (printf "~?~%~!" fstr args)))
     141
    136142    (define (print-header mode dbgmode)
    137       (when verbose (printf "pass: ~a~%~!" mode))
     143      (dribble "pass: ~a" mode)
    138144      (and (memq dbgmode debugging-chicken)
    139145           (begin
     
    205211    (when uunit
    206212      (set! unit-name (string->c-identifier (stringify (option-arg uunit)))) )
     213    (when (or unit-name dynamic)
     214      (set! standalone-executable #f))
     215    (when (memq 'ignore-repository options)
     216      (set! ##sys#dload-disabled #t)
     217      (repository-path #f))
    207218    (set! debugging-chicken
    208219      (append-map
     
    212223       (collect-options 'debug) ) )
    213224    (set! dumpnodes (memq '|D| debugging-chicken))
     225    (set! import-libraries
     226      (map (lambda (il)
     227             (cons (string->symbol il)
     228                   (string-append il ".import.scm")))
     229           (collect-options 'emit-import-library)))
    214230    (when (memq 'lambda-lift options) (set! do-lambda-lifting #t))
    215     (when (memq 'disable-compiler-macros options) (set! compiler-macros-enabled #f))
    216231    (when (memq 't debugging-chicken) (##sys#start-timer))
    217232    (when (memq 'b debugging-chicken) (set! time-breakdown #t))
    218     (and-let* ((xfile (memq 'emit-exports options)))
    219       (set! export-file-name (cadr xfile)) )
     233    (when (memq 'emit-exports options)
     234      (warning "deprecated compiler option: emit-exports") )
    220235    (when (memq 'raw options)
    221236      (set! explicit-use-flag #t)
     
    224239    (when (memq 'no-lambda-info options)
    225240      (set! emit-closure-info #f) )
    226     (set! use-import-table (memq 'check-imports options))
    227     (let ((imps (collect-options 'import)))
    228       (when (pair? imps)
    229         (set! use-import-table #t)
    230         (for-each lookup-exports-file imps) ) )
     241    (when (memq 'local options)
     242      (set! local-definitions #t))
     243    (when (memq 'inline-global options)
     244      (set! inline-locally #t)
     245      (set! inline-globally #t))
    231246    (set! disabled-warnings (map string->symbol (collect-options 'disable-warning)))
    232247    (when (memq 'no-warnings options)
    233       (when verbose (printf "Warnings are disabled~%~!"))
     248      (dribble "Warnings are disabled")
    234249      (set! ##sys#warnings-enabled #f) )
    235250    (when (memq 'optimize-leaf-routines options) (set! optimize-leaf-routines #t))
    236251    (when (memq 'unsafe options)
    237       (set! unsafe #t)
    238       (##match#set-error-control #:fail) )
     252      (set! unsafe #t) )
    239253    (when (and dynamic (memq 'unsafe-libraries options))
    240254      (set! emit-unsafe-marker #t) )
     
    242256    (when (memq 'fixnum-arithmetic options) (set! number-type 'fixnum))
    243257    (when (memq 'block options) (set! block-compilation #t))
    244     (when (memq 'emit-external-prototypes-first options) (set! external-protos-first #t))
    245     (when (memq 'inline options) (set! inline-max-size default-inline-max-size))
     258    (when (memq 'emit-external-prototypes-first options)
     259      (set! external-protos-first #t))
     260    (when (memq 'inline options) (set! inline-locally #t))
     261    (and-let* ((ifile (memq 'emit-inline-file options)))
     262      (set! inline-locally #t)          ; otherwise this option makes no sense
     263      (set! local-definitions #t)
     264      (set! inline-output-file (option-arg ifile)))
    246265    (and-let* ([inlimit (memq 'inline-limit options)])
    247266      (set! inline-max-size
     
    250269              (quit "invalid argument to `-inline-limit' option: `~A'" arg) ) ) ) )
    251270    (when (memq 'case-insensitive options)
    252       (when verbose (printf "Identifiers and symbols are case insensitive~%~!"))
     271      (dribble "Identifiers and symbols are case insensitive")
    253272      (register-feature! 'case-insensitive)
    254273      (case-sensitive #f) )
     
    269288    (when (and outfile filename (string=? outfile filename))
    270289      (quit "source- and output-filename are the same") )
    271     (set! uses-units
    272       (map string->symbol
    273            (append-map
    274             (cut string-split <> ",")
    275             (collect-options 'uses))))
     290    (set! uses-units (map string->symbol (collect-options 'uses)))
    276291    (when (memq 'keep-shadowed-macros options)
    277292      (set! undefine-shadowed-macros #f) )
     
    285300    (set! ##sys#features (cons #:compiler-extension ##sys#features))
    286301    (let ([extends (collect-options 'extend)])
    287       (when verbose
    288         (printf "Loading compiler extensions...~%~!")
    289         (load-verbose #t) )
    290       (for-each (lambda (f) (load (##sys#resolve-include-filename f #f #t))) extends) )
     302      (dribble "Loading compiler extensions...")
     303      (when verbose (load-verbose #t))
     304      (for-each
     305       (lambda (f) (load (##sys#resolve-include-filename f #f #t)))
     306       extends) )
    291307    (set! ##sys#features (delete #:compiler-extension ##sys#features eq?))
    292308
    293309    (set! ##sys#features (cons '#:compiling ##sys#features))
    294     (set! ##sys#features (cons #:match ##sys#features))
    295     (##sys#provide 'match)
    296310    (set! upap (user-post-analysis-pass))
    297311
     
    299313    (set! initforms (append initforms postponed-initforms))
    300314
    301     ;; Handle `-extension' options:
    302     (when (memq 'extension options)
    303       (set! initforms 
     315    (let ((se (map string->symbol (collect-options 'static-extension))))
     316      ;; Append required extensions to initforms:
     317      (set! initforms
    304318        (append
    305          initforms
    306          `((define-extension
    307              ,(string->symbol
    308                (cond (outfile (pathname-file outfile))
    309                      (filename (pathname-file filename))
    310                      (else (quit "no filename available for `-extension' option")) ) ) ) ) ) ) )
    311 
    312     ;; Append required extensions to initforms:
    313     (let ([ids (lset-difference
    314                 eq?
    315                 (map string->symbol
    316                      (append-map
    317                       (cut string-split <> ",")
    318                       (collect-options 'require-extension)))
    319                 uses-units)])
    320       (set! initforms
    321         (append initforms (map (lambda (r) `(##core#require-extension ',r)) ids)) ) )
    322 
    323     (when (memq 'run-time-macros options)
     319         initforms
     320         (map (lambda (r) `(##core#require-extension (,r) #t))
     321              (append se (collect-options 'require-extension)))))
     322
     323      ;; add static-extensions as used units:
     324      (set! ##sys#explicit-library-modules
     325        (append ##sys#explicit-library-modules se)))
     326
     327    (when (memq 'compile-syntax options)
    324328      (set! ##sys#enable-runtime-macros #t) )
    325329    (set! target-heap-size
     
    344348      (set! standard-bindings default-standard-bindings)
    345349      (set! extended-bindings default-extended-bindings) )
    346     (when verbose
    347       (printf "debugging info: ~A~%~!"
    348               (if emit-trace-info
    349                   "stacktrace"
    350                   "none") ) )
     350    (dribble "debugging info: ~A"
     351             (if emit-trace-info
     352                 "calltrace"
     353                 "none") )
    351354    (when profile
    352355      (let ([acc (eq? 'accumulate-profile (car profile))])
    353356        (set! emit-profile #t)
    354         (set! profiled-procedures #f)
     357        (set! profiled-procedures 'all)
    355358        (set! initforms
    356359          (append
     
    360363               '((set! ##sys#profile-append-mode #t))
    361364               '() ) ) )
    362         (when verbose
    363           (printf "Generating ~aprofile~%~!" (if acc "accumulated " "")) ) ) )
     365        (dribble "Generating ~aprofile" (if acc "accumulated " "")) ) )
     366
     367    ;;*** hardcoded "modules.db" is bad (also used in chicken-install.scm)
     368    (and-let* ((rp (repository-path))
     369               (dbfile (file-exists? (make-pathname rp "modules.db"))))
     370      (dribble "loading database ~a ..." dbfile)
     371      (for-each
     372       (lambda (e)
     373         (##sys#put!
     374          (car e) '##core#db
     375          (append (or (##sys#get (car e) '##core#db) '()) (list (cdr e))) ))
     376       (read-file dbfile)))
    364377
    365378    (cond ((memq 'version options)
     
    372385           (newline) )
    373386          ((not filename)
    374            (unless quiet
    375              (print-version #t)
    376              (display "\nEnter \"chicken -help\" for information on how to use it.\n") ) )
     387           (print-version #t)
     388           (display "\nEnter \"chicken -help\" for information on how to use it.\n") )
    377389          (else
    378390
    379391           ;; Display header:
    380            (unless quiet
    381              (printf "compiling `~a' ...~%" filename) )
     392           (dribble "compiling `~a' ..." filename)
    382393           (set! source-filename filename)
    383394           (debugging 'r "options" options)
     
    398409             (let ([proc (user-read-pass)])
    399410               (cond [proc
    400                       (when verbose (printf "User read pass...~%~!"))
     411                      (dribble "User read pass...")
    401412                      (set! forms (proc prelude files postlude)) ]
    402413                     [else
     
    419430           (let ([proc (user-preprocessor-pass)])
    420431             (when proc
    421                (when verbose (printf "User preprocessing pass...~%~!"))
     432               (dribble "User preprocessing pass...")
    422433               (set! forms (map proc forms))))
    423434
     
    456467               (display-line-number-database) )
    457468
    458              (when (and block-compilation unit-name)
    459                (compiler-warning
    460                 'usage
    461                 "compilation of library unit `~a' in block-mode - globals may not be accessible outside this unit"
    462                 unit-name) )
    463 
    464469             (when (and unit-name dynamic)
    465470               (compiler-warning 'usage "library unit `~a' compiled in dynamic mode" unit-name) )
     
    480485             (let ([proc (user-pass)])
    481486               (when proc
    482                  (when verbose (printf "User pass...~%~!"))
     487                 (dribble "User pass...")
    483488                 (begin-time)
    484489                 (set! exps (map proc exps))
    485490                 (end-time "user pass") ) )
     491
     492             (let ((req (concatenate (vector->list file-requirements))))
     493               (when (debugging 'M "; requirements:")
     494                 (pp req))
     495               (when inline-globally
     496                 (for-each
     497                  (lambda (id)
     498                    (and-let* ((ifile (##sys#resolve-include-filename
     499                                       (make-pathname #f (symbol->string id) "inline")
     500                                       #f #t))
     501                               ((file-exists? ifile)))
     502                      (dribble "Loading inline file ~a ..." ifile)
     503                      (load-inline-file ifile)))
     504                  (concatenate (map cdr req)))))
    486505
    487506             (let* ([node0 (make-node
     
    490509                                   (canonicalize-begin-body exps) ) ) ) ]
    491510                    [proc (user-pass-2)] )
    492                (when (debugging 'M "; requirements:")
    493                  (pretty-print (##sys#hash-table->alist file-requirements)))
    494511               (when proc
    495                  (when verbose (printf "Secondary user pass...~%"))
     512                 (dribble "Secondary user pass...")
    496513                 (begin-time)
    497514                 (set! first-analysis #f)
     
    534551                   (let ([db (analyze 'opt node2 i progress)])
    535552                     (when first-analysis
    536                        (when use-import-table (check-global-imports db))
    537                        (check-global-exports db)
    538553                       (when (memq 'u debugging-chicken)
    539554                         (dump-undefined-globals db)) )
     
    548563
    549564                            (begin-time)
    550                             (receive (node2 progress-flag) (perform-high-level-optimizations node2 db)
     565                            (receive (node2 progress-flag)
     566                                (perform-high-level-optimizations node2 db)
    551567                              (end-time "optimization")
    552568                              (print-node "optimized-iteration" '|5| node2)
     
    570586                            (print-node "optimized" '|7| node2)
    571587
     588                            (when inline-output-file
     589                              (let ((f inline-output-file))
     590                                (dribble "Generating global inline file `~a' ..." f)
     591                                (emit-global-inline-file f db) ) )
     592
    572593                            (begin-time)
    573594                            (let ([node3 (perform-closure-conversion node2 db)])
     
    575596                              (print-db "final-analysis" '|8| db i)
    576597                              (when (and ##sys#warnings-enabled (> (- (cputime) start-time) funny-message-timeout))
    577                                 (display "(do not worry - still compiling...)\n") )
    578                               (when export-file-name
    579                                 (dump-exported-globals db export-file-name) )
     598                                (display "(don't worry - still compiling...)\n") )
    580599                              (when a-only (exit 0))
    581600                              (print-node "closure-converted" '|9| node3)
     
    588607                                (begin-time)
    589608                                (let ((out (if outfile (open-output-file outfile) (current-output-port))) )
    590                                   (unless quiet
    591                                     (printf "generating `~A' ...~%" outfile) )
     609                                  (dribble "generating `~A' ..." outfile)
    592610                                  (generate-code literals lliterals lambdas out filename dynamic db)
    593611                                  (when outfile (close-output-port out)))
     
    595613                                (when (memq 't debugging-chicken) (##sys#display-times (##sys#stop-timer)))
    596614                                (compiler-cleanup-hook)
    597                                 (when verbose
    598                                   (printf "compilation finished.~%~!") ) ) ) ] ) ) ) ) ) ) ) ) ) )
     615                                (dribble "compilation finished.") ) ) ] ) ) ) ) ) ) ) ) ) )
  • chicken/branches/prerelease/benchmarks/scheme.scm

    r1016 r13240  
    8787    (scheme-error "Identifier expected" x))
    8888  (if (memq x scheme-syntactic-keywords)
    89     (scheme-error "Variable name can not be a syntactic keyword" x)))
     89    (scheme-error "Variable name cannot be a syntactic keyword" x)))
    9090
    9191(define (shape form n)
  • chicken/branches/prerelease/buildversion

    r11975 r13240  
    1 3.4.0
    2 
     14.0.0x5
  • chicken/branches/prerelease/c-backend.scm

    r9381 r13240  
    22;
    33; Copyright (c) 2000-2007, Felix L. Winkelmann
    4 ; Copyright (c) 2008, The Chicken Team
     4; Copyright (c) 2008-2009, The Chicken Team
    55; All rights reserved.
    66;
     
    3131(private compiler
    3232  compiler-arguments process-command-line find-early-refs
    33   default-standard-bindings default-extended-bindings side-effecting-standard-bindings
    34   non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings
    35   foldable-extended-bindings
    36   standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
     33  default-standard-bindings default-extended-bindings
     34  foldable-bindings
    3735  installation-home optimization-iterations debugging cleanup
    3836  file-io-only
     
    4442  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants
    4543  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    46   mutable-constants encode-literal
     44  encode-literal
    4745  broken-constant-nodes inline-substitutions-enabled
    4846  direct-call-ids foreign-type-table first-analysis block-variable-literal?
     
    220218
    221219            ((##core#global)
    222              (let ([index (first params)]
    223                    [safe (second params)]
    224                    [block (third params)] )
     220             (let ((index (first params))
     221                   (safe (second params))
     222                   (block (third params)) )
    225223               (cond [block
    226224                      (if safe
     
    231229
    232230            ((##core#setglobal)
    233              (let ([index (first params)]
    234                    [block (second params)] )
     231             (let ((index (first params))
     232                   (block (second params))
     233                   (var (third params)))
    235234               (if block
    236                    (gen "C_mutate(&lf[" index "],")
    237                    (gen "C_mutate((C_word*)lf[" index "]+1,") )
     235                   (gen "C_mutate(&lf[" index "]")
     236                   (gen "C_mutate((C_word*)lf[" index "]+1") )
     237               (gen " /* (set! " (uncommentify (symbol->string var)) " ...) */,")
    238238               (expr (car subs) i)
    239239               (gen #\)) ) )
    240240
    241241            ((##core#setglobal_i)
    242              (let ([index (first params)]
    243                    [block (second params)] )
     242             (let ((index (first params))
     243                   (block (second params))
     244                   (var (third params)) )
    244245               (cond [block
    245                       (gen "lf[" index "]=")
     246                      (gen "lf[" index "] /* "
     247                           (uncommentify (symbol->string var)) " */ =")
    246248                      (expr (car subs) i)
    247249                      (gen #\;) ]
    248250                     [else
    249                       (gen "C_set_block_item(lf[" index "],0,")
     251                      (gen "C_set_block_item(lf[" index "] /* "
     252                           (uncommentify (symbol->string var)) " */,0,")
    250253                      (expr (car subs) i)
    251254                      (gen #\)) ] ) ) )
     
    300303                             (expr-args args i)
    301304                             (gen ");") ) ) )
     305                     ((and (eq? '##core#global (node-class fn))
     306                           (not unsafe)
     307                           (not no-procedure-checks)
     308                           (not (first params)))
     309                      (let* ((gparams (node-parameters fn))
     310                             (index (first gparams))
     311                             (safe (second gparams))
     312                             (block (third gparams))
     313                             (carg #f))
     314                        (gen #t "((C_proc" nf ")")
     315                        (cond (block
     316                               (set! carg (string-append "lf[" (number->string index) "]"))
     317                               (if safe
     318                                   (gen "C_retrieve_proc(" carg ")")
     319                                   (gen "C_retrieve2_symbol_proc(" carg ","
     320                                        (c-ify-string (symbol->string (fourth gparams))) #\)) ) )
     321                              (safe
     322                               (set! carg
     323                                 (string-append "*((C_word*)lf[" (number->string index) "]+1)"))
     324                               (gen "C_retrieve_proc(" carg ")"))
     325                              (else
     326                               (set! carg
     327                                 (string-append "*((C_word*)lf[" (number->string index) "]+1)"))
     328                               (gen "C_retrieve_symbol_proc(lf[" index "])") ))
     329                        (gen ")(" nf #\, carg #\,)
     330                        (expr-args args i)
     331                        (gen ");") ) )
    302332                     (else
    303333                      (gen #t #\t nc #\=)
     
    447477            (string-append "0" (number->string n))
    448478            n) )
    449       (match (##sys#decode-seconds (current-seconds) #f)
    450         [#(_ min hour mday mon year _ _ _ _)
    451           (gen "/* Generated from " source-file " by the CHICKEN compiler" #t
    452                "   http://www.call-with-current-continuation.org" #t
    453                "   " (+ 1900 year) #\- (pad0 (add1 mon)) #\- (pad0 mday) #\space (pad0 hour) #\: (pad0 min) #t
    454                (string-intersperse
    455                 (map (cut string-append "   " <> "\n")
    456                      (string-split (chicken-version #t) "\n") )
    457                 "")
    458                "   command line: ")
    459           (gen-list compiler-arguments)
     479      (let* ((tm (##sys#decode-seconds (current-seconds) #f))
     480             (min (vector-ref tm 1))
     481             (hour (vector-ref tm 2))
     482             (mday (vector-ref tm 3))
     483             (mon (vector-ref tm 4))
     484             (year (vector-ref tm 5)) )
     485        (gen "/* Generated from " source-file " by the CHICKEN compiler" #t
     486             "   http://www.call-with-current-continuation.org" #t
     487             "   " (+ 1900 year) #\- (pad0 (add1 mon)) #\- (pad0 mday) #\space (pad0 hour) #\: (pad0 min) #t
     488             (string-intersperse
     489              (map (cut string-append "   " <> "\n")
     490                   (string-split (chicken-version #t) "\n") )
     491              "")
     492             "   command line: ")
     493        (gen-list compiler-arguments)
     494        (gen #t)
     495        (cond [unit-name (gen "   unit: " unit-name)]
     496              [else
     497               (gen "   used units: ")
     498               (gen-list used-units) ] )
     499        (gen #t "*/" #t #t "#include \"" target-include-file "\"")
     500        (when external-protos-first
     501          (generate-foreign-callback-stub-prototypes foreign-callback-stubs) )
     502        (when (pair? foreign-declarations)
    460503          (gen #t)
    461           (cond [unit-name (gen "   unit: " unit-name)]
    462                 [else
    463                  (gen "   used units: ")
    464                  (gen-list used-units) ] )
    465           (gen #t "*/" #t #t "#include \"" target-include-file "\"")
    466           (when external-protos-first
    467             (generate-foreign-callback-stub-prototypes foreign-callback-stubs) )
    468           (when (pair? foreign-declarations)
    469             (gen #t)
    470             (for-each (lambda (decl) (gen #t decl)) foreign-declarations) )
    471           (unless external-protos-first
    472             (generate-foreign-callback-stub-prototypes foreign-callback-stubs) ) ] ) )
     504          (for-each (lambda (decl) (gen #t decl)) foreign-declarations) )
     505        (unless external-protos-first
     506          (generate-foreign-callback-stub-prototypes foreign-callback-stubs) ) ) )
    473507 
    474508    (define (trailer)
     
    915949       (gen #t "{NULL,NULL}};") )
    916950    (let ((id (lambda-literal-id (car ll))))
    917       (gen #t "{\"" id sf "\",(void*)")
     951      (gen #t "{\"" id #\: (string->c-identifier sf) "\",(void*)")
    918952      (if (eq? 'toplevel id)
    919953          (if unit-name
     
    9681002  (gen #t)
    9691003  (for-each
    970    (match-lambda
    971      [#(name type exported)
    972       (gen #t (if exported "" "static ") (foreign-type-declaration type name) #\;) ] )
     1004   (lambda (v)
     1005     (let ((name (vector-ref v 0))
     1006           (type (vector-ref v 1))
     1007           (exported (vector-ref v 2)) )
     1008       (gen #t (if exported "" "static ") (foreign-type-declaration type name) #\;) ) )
    9731009   vars) )
    9741010
     
    11651201                   (foreign-type-declaration (if (vector? t) (vector-ref t 0) t) target)) ]
    11661202             [(string? type) (str type)]
    1167              [(pair? type)
    1168               (match type
    1169                 [((or 'pointer 'nonnull-pointer 'c-pointer 'nonnull-c-pointer) ptype)
    1170                  (foreign-type-declaration ptype (string-append "*" target)) ]
    1171                 [('ref rtype)
    1172                  (foreign-type-declaration rtype (string-append "&" target)) ]
    1173                 [`(template ,t0 ,ts ...)
    1174                  (str
    1175                   (string-append
    1176                    (foreign-type-declaration t0 "")
    1177                    "<"
    1178                    (string-intersperse (map (cut foreign-type-declaration <> "") ts) ",")
    1179                    "> ") ) ]
    1180                 [`(const ,t) (string-append "const " (foreign-type-declaration t target))]
    1181                 [`(struct ,sname) (string-append "struct " (->string sname) " " target)]
    1182                 [`(union ,uname) (string-append "union " (->string uname) " " target)]
    1183                 [`(enum ,ename) (string-append "enum " (->string ename) " " target)]
    1184                 [((or 'instance 'nonnull-instance) cname sname) (string-append (->string cname) "*" target)]
    1185                 [('instance-ref cname sname) (string-append (->string cname) "&" target)]
    1186                 [`(function ,rtype ,argtypes . ,callconv)
    1187                  (string-append
    1188                   (foreign-type-declaration rtype "")
    1189                   (or (and-let* ([(pair? callconv)]
    1190                                  [cc (car callconv)]
    1191                                  [(string? cc)] )
    1192                         cc)
    1193                       "")
    1194                   " (*" target ")("
    1195                   (string-intersperse
    1196                    (map (lambda (at)
    1197                           (if (eq? '... at)
    1198                               "..."
    1199                               (foreign-type-declaration at "") ) )
    1200                         argtypes)
    1201                    ",")
    1202                   ")" ) ]
    1203                 [_ (err)] ) ]
     1203             [(list? type)
     1204              (let ((len (length type)))
     1205                (cond
     1206                 ((and (= 2 len)
     1207                       (memq (car type) '(pointer nonnull-pointer c-pointer
     1208                                                  nonnull-c-pointer) ) )
     1209                  (foreign-type-declaration (cadr type) (string-append "*" target)) )
     1210                 ((and (= 2 len)
     1211                       (eq? 'ref (car type)))
     1212                  (foreign-type-declaration (cadr type) (string-append "&" target)) )
     1213                 ((and (> len 2)
     1214                       (eq? 'template (car type)))
     1215                  (str
     1216                   (string-append
     1217                    (foreign-type-declaration (cadr type) "")
     1218                    "<"
     1219                    (string-intersperse
     1220                     (map (cut foreign-type-declaration <> "") (cddr type))
     1221                     ",")
     1222                    "> ") ) )
     1223                 ((and (= len 2) (eq? 'const (car type)))
     1224                  (string-append "const " (foreign-type-declaration (cadr type) target)))
     1225                 ((and (= len 2) (eq? 'struct (car type)))
     1226                  (string-append "struct " (->string (cadr type)) " " target))
     1227                 ((and (= len 2) (eq? 'union (car type)))
     1228                  (string-append "union " (->string (cadr type)) " " target))
     1229                 ((and (= len 2) (eq? 'enum (car type)))
     1230                  (string-append "enum " (->string (cadr type)) " " target))
     1231                 ((and (= len 3) (memq (car type) '(instance nonnull-instance)))
     1232                  (string-append (->string (cadr type)) "*" target))
     1233                 ((and (= len 3) (eq? 'instance-ref (car type)))
     1234                  (string-append (->string (cadr type)) "&" target))
     1235                 ((and (>= len 3) (eq? 'function (car type)))
     1236                  (let ((rtype (cadr type))
     1237                        (argtypes (caddr type))
     1238                        (callconv (optional (cdddr type) "")))
     1239                    (string-append
     1240                     (foreign-type-declaration rtype "")
     1241                     callconv
     1242                     " (*" target ")("
     1243                     (string-intersperse
     1244                      (map (lambda (at)
     1245                             (if (eq? '... at)
     1246                                 "..."
     1247                                 (foreign-type-declaration at "") ) )
     1248                           argtypes)
     1249                      ",")
     1250                     ")" ) ) )
     1251                 (else (err)) ) ) ]
    12041252             [else (err)] ) ] ) ) )
    12051253
     
    12571305              => (lambda (t)
    12581306                   (foreign-argument-conversion (if (vector? t) (vector-ref t 0) t)) ) ]
    1259              [(pair? type)
    1260               (match type
    1261                 ;; pointer and nonnull-pointer are DEPRECATED
    1262                 [('pointer ptype) "C_c_pointer_or_null("]
    1263                 [('nonnull-pointer ptype) "C_c_pointer_nn("]
    1264                 [('c-pointer ptype) "C_c_pointer_or_null("]
    1265                 [('nonnull-c-pointer ptype) "C_c_pointer_nn("]
    1266                 [`(instance ,cname ,sname) "C_c_pointer_or_null("]
    1267                 [`(nonnull-instance ,cname ,sname) "C_c_pointer_nn("]
    1268                 [`(function ,rtype ,@argtypes) "C_c_pointer_or_null("]
    1269                 [`(const ,ctype) (foreign-argument-conversion ctype)]
    1270                 [`(enum ,etype) "C_num_to_int("]
    1271                 [`(ref ,rtype) (string-append "*(" (foreign-type-declaration rtype "*") ")C_c_pointer_nn(")]
    1272                 [`(instance-ref ,cname ,sname) (string-append "*(" cname "*)C_c_pointer_nn(")]
    1273                 [else (err)] ) ]
     1307             [(and (list? type) (>= (length type) 2))
     1308              (case (car type)
     1309               ;; pointer and nonnull-pointer are DEPRECATED
     1310               ((pointer) "C_c_pointer_or_null(")
     1311               ((nonnull-pointer) "C_c_pointer_nn(")
     1312               ((c-pointer) "C_c_pointer_or_null(")
     1313               ((nonnull-c-pointer) "C_c_pointer_nn(")
     1314               ((instance) "C_c_pointer_or_null(")
     1315               ((nonnull-instance) "C_c_pointer_nn(")
     1316               ((function) "C_c_pointer_or_null(")
     1317               ((const) (foreign-argument-conversion (cadr type)))
     1318               ((enum) "C_num_to_int(")
     1319               ((ref)
     1320                (string-append "*(" (foreign-type-declaration (car type) "*")
     1321                               ")C_c_pointer_nn("))
     1322               ((instance-ref)
     1323                (string-append "*(" (cadr type) "*)C_c_pointer_nn("))
     1324               (else (err)) ) ]
    12741325             [else (err)] ) ) ) ) )
    12751326
     
    13051356              => (lambda (x)
    13061357                   (foreign-result-conversion (if (vector? x) (vector-ref x 0) x) dest)) ]
    1307              [(pair? type)
    1308               (match type
    1309                 [((or 'nonnull-pointer 'nonnull-c-pointer) ptype)
    1310                  (sprintf "C_mpointer(&~A,(void*)" dest) ]
    1311                 [('ref rtype)
    1312                  (sprintf "C_mpointer(&~A,(void*)&" dest) ]
    1313                 [('instance cname sname)
    1314                  (sprintf "C_mpointer_or_false(&~A,(void*)" dest) ]
    1315                 [('nonnull-instance cname sname)
    1316                  (sprintf "C_mpointer(&~A,(void*)" dest) ]
    1317                 [('instance-ref cname sname)
    1318                  (sprintf "C_mpointer(&~A,(void*)&" dest) ]
    1319                 [('const ctype) (foreign-result-conversion ctype dest)]
    1320                 [((or 'pointer 'c-pointer) ptype)
    1321                  (sprintf "C_mpointer_or_false(&~a,(void*)" dest) ]
    1322                 [`(function ,rtype ,@argtypes) (sprintf "C_mpointer(&~a,(void*)" dest)]
    1323                 [`(enum ,etype) (sprintf "C_int_to_num(&~a," dest)]
    1324                 [else (err)] ) ]
     1358             [(and (list? type) (>= (length type) 2))
     1359              (case (car type)
     1360                ((nonnull-pointer nonnull-c-pointer)
     1361                 (sprintf "C_mpointer(&~A,(void*)" dest) )
     1362                ((ref)
     1363                 (sprintf "C_mpointer(&~A,(void*)&" dest) )
     1364                ((instance)
     1365                 (sprintf "C_mpointer_or_false(&~A,(void*)" dest) )
     1366                ((nonnull-instance)
     1367                 (sprintf "C_mpointer(&~A,(void*)" dest) )
     1368                ((instance-ref)
     1369                 (sprintf "C_mpointer(&~A,(void*)&" dest) )
     1370                ((const) (foreign-result-conversion (cadr type) dest))
     1371                ((pointer c-pointer)
     1372                 (sprintf "C_mpointer_or_false(&~a,(void*)" dest) )
     1373                ((function) (sprintf "C_mpointer(&~a,(void*)" dest))
     1374                ((enum) (sprintf "C_int_to_num(&~a," dest))
     1375                (else (err)) ) ]
    13251376             [else (err)] ) ) ) ) )
    13261377
     
    13751426             str) ) )
    13761427         ((##sys#immediate? lit)
    1377           (bomb "invalid literal - can not encode" lit))
     1428          (bomb "invalid literal - cannot encode" lit))
    13781429         ((##core#inline "C_byteblockp" lit)
    13791430          (##sys#string-append ; relies on the fact that ##sys#string-append doesn't check
  • chicken/branches/prerelease/c-platform.scm

    r10911 r13240  
    22;
    33; Copyright (c) 2000-2007, Felix L. Winkelmann
    4 ; Copyright (c) 2008, The Chicken Team
     4; Copyright (c) 2008-2009, The Chicken Team
    55; All rights reserved.
    66;
     
    3131(private compiler
    3232  compiler-arguments process-command-line
    33   default-standard-bindings default-extended-bindings side-effecting-standard-bindings
    34   non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
    35   standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
    36   installation-home debugging
    37   dump-nodes
     33  default-standard-bindings default-extended-bindings
     34  foldable-bindings non-foldable-bindings
     35  installation-home debugging intrinsic?
     36  dump-nodes unlikely-variables
    3837  unit-name insert-timer-checks used-units inlining
    3938  foreign-declarations block-compilation line-number-database-size
     
    4140  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
    4241  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
    43   rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants
     42  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    4443  broken-constant-nodes inline-substitutions-enabled
    4544  direct-call-ids foreign-type-table first-analysis
     
    7877    (bound-to-procedure
    7978     ##sys#for-each ##sys#map ##sys#print ##sys#setter
    80      ##sys#setslot ##sys#dynamic-wind ##sys#call-with-values ##sys#match-error
     79     ##sys#setslot ##sys#dynamic-wind ##sys#call-with-values
    8180     ##sys#start-timer ##sys#stop-timer ##sys#gcd ##sys#lcm ##sys#make-promise ##sys#structure? ##sys#slot
    8281     ##sys#allocate-vector ##sys#list->vector ##sys#block-ref ##sys#block-set!
     
    9695(define default-profiling-declarations
    9796  '((##core#declare
    98      '(uses profiler)
    99      '(bound-to-procedure
     97     (uses profiler)
     98     (bound-to-procedure
    10099       ##sys#profile-entry ##sys#profile-exit) ) ) )
    101100
     
    104103(define parameter-limit 1024)
    105104(define small-parameter-limit 128)
     105(define unlikely-variables '(unquote unquote-splicing))
    106106
    107107(define eq-inline-operator "C_eqp")
     
    114114
    115115(define valid-compiler-options
    116   '(-help h help version verbose explicit-use quiet no-trace no-warnings unsafe block
     116  '(-help h help version verbose explicit-use
     117          quiet                         ; DEPRECATED
     118          no-trace no-warnings unsafe block
    117119    check-syntax to-stdout no-usual-integrations case-insensitive no-lambda-info
    118     profile inline keep-shadowed-macros
    119     fixnum-arithmetic disable-interrupts optimize-leaf-routines check-imports
    120     lambda-lift run-time-macros tag-pointers accumulate-profile
     120    profile inline keep-shadowed-macros ignore-repository
     121    fixnum-arithmetic disable-interrupts optimize-leaf-routines
     122    lambda-lift compile-syntax tag-pointers accumulate-profile
    121123    disable-stack-overflow-checks disable-c-syntax-checks unsafe-libraries raw
    122     emit-external-prototypes-first release disable-compiler-macros
    123     analyze-only dynamic extension) )
     124    emit-external-prototypes-first release local inline-global
     125    analyze-only dynamic) )
    124126
    125127(define valid-compiler-options-with-argument
    126128  '(debug output-file include-path heap-size stack-size unit uses keyword-style require-extension
    127           inline-limit profile-name disable-warning emit-exports import
     129          inline-limit profile-name disable-warning
    128130    prelude postlude prologue epilogue nursery extend feature
    129     compress-literals                   ; DEPRECATED
     131    emit-import-library emit-inline-file static-extension
    130132    heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path) )
    131133
     
    159161    arithmetic-shift void flush-output thread-specific thread-specific-set!
    160162    not-pair? atom? null-list? print print* error cpu-time proper-list? call/cc
    161     u8vector->byte-vector s8vector->byte-vector u16vector->byte-vector s16vector->byte-vector ; DEPRECATED
    162     u32vector->byte-vector s32vector->byte-vector byte-vector-length ; DEPRECATED
    163     f32vector->byte-vector f64vector->byte-vector byte-vector-ref byte-vector-set! ; DEPRECATED
    164163    blob-size u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared
    165164    s16vector->blob/shared u32vector->blob/shared s32vector->blob/shared
     
    188187    ##sys#fudge ##sys#immediate? ##sys#direct-return ##sys#context-switch
    189188    ##sys#make-structure ##sys#apply ##sys#apply-values ##sys#continuation-graft
    190     ##sys#bytevector? ##sys#make-vector ##sys#setter
     189    ##sys#bytevector? ##sys#make-vector ##sys#setter ##sys#car ##sys#cdr ##sys#pair?
     190    ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv?
    191191    ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument
    192192    ##sys#foreign-block-argument ##sys#foreign-number-vector-argument
     
    196196    ##sys#intern-symbol ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte) )
    197197
    198 (define side-effecting-standard-bindings
    199   '(apply call-with-current-continuation set-car! set-cdr! write-char newline write display
     198(define non-foldable-bindings
     199  '(vector
     200    cons list string make-vector make-string string->symbol values current-input-port current-output-port
     201    read-char write-char
     202    apply call-with-current-continuation set-car! set-cdr! write-char newline write display
    200203    peek-char char-ready?
    201204    read read-char for-each map string-set! vector-set! string-fill! vector-fill! open-input-file
    202205    open-output-file close-input-port close-output-port call-with-input-port call-with-output-port
    203     call-with-values eval) )
    204 
    205 (define non-foldable-standard-bindings
    206   '(vector cons list string make-vector make-string string->symbol values current-input-port current-output-port
    207            read-char write-char) )
    208 
    209 (define foldable-standard-bindings
    210   (lset-difference
    211    eq? default-standard-bindings
    212    side-effecting-standard-bindings non-foldable-standard-bindings) )
    213 
    214 (define non-foldable-extended-bindings
    215   '(##sys#slot ##sys#setslot ##sys#call-with-current-continuation ##sys#fudge flush-output print void
    216     u8vector->byte-vector s8vector->byte-vector u16vector->byte-vector s16vector->byte-vector u32vector->byte-vector ; DEPRECATED
    217     f32vector->byte-vector f64vector->byte-vector s32vector->byte-vector ;DEPRECATED
     206    call-with-values eval
     207    ##sys#slot ##sys#setslot ##sys#call-with-current-continuation ##sys#fudge flush-output print void
    218208    u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared s16vector->blob/shared u32vector->blob/shared
    219209    f32vector->blob/shared f64vector->blob/shared
     
    221211    ##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot ##sys#block-ref
    222212    ##sys#byte ##sys#setbyte
    223     byte-vector-ref byte-vector-set!    ; DEPRECATED
    224213    u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
    225214    f32vector-length f64vector-length ##sys#apply-values ##sys#setter setter
     
    228217    ##sys#intern-symbol ##sys#make-symbol make-record-instance error cpu-time ##sys#block-set!) )
    229218
    230 (define foldable-extended-bindings
    231   (lset-difference
    232    eq? default-extended-bindings non-foldable-extended-bindings) )
    233 
    234 (define standard-bindings-that-never-return-false
    235   '(cons list length * - + / current-output-port current-input-port append symbol->string char->integer
    236     integer->char vector-length string-length string-ref gcd lcm reverse string->symbol max min
    237     quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact exp log sin
    238     cons tan atan expt sqrt asin acos number->string char-upcase char-downcase string-append string
    239     string->list list->string vector->list list->vector read-char substring make-string make-vector
    240     open-input-file open-output-file vector write-char) )
    241 
    242 (define side-effect-free-standard-bindings-that-never-return-false
    243   (lset-difference
    244    eq? standard-bindings-that-never-return-false
    245    side-effecting-standard-bindings) )
     219(define foldable-bindings
     220  (lset-difference
     221   eq?
     222   (lset-union eq? default-standard-bindings default-extended-bindings)
     223   non-foldable-bindings) )
    246224
    247225
     
    367345             (cons* (make-node '##core#proc '("C_quotient" #t) '()) cont callargs) ) ) ) ) )
    368346
    369 (rewrite
    370  'eqv? 8
    371  (lambda (db classargs cont callargs)
    372    ;; (eqv? <var> <var>) -> (quote #t)
    373    ;; (eqv? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and not a flonum]
    374    (and (= (length callargs) 2)
    375         (let ([arg1 (first callargs)]
    376               [arg2 (second callargs)] )
    377           (or (and (eq? '##core#variable (node-class arg1))
    378                    (eq? '##core#variable (node-class arg2))
    379                    (equal? (node-parameters arg1) (node-parameters arg2))
    380                    (make-node '##core#call '(#t) (list cont (qnode #t))) )
    381               (and (or (and (eq? 'quote (node-class arg1))
    382                             (not (flonum? (first (node-parameters arg1)))) )
    383                        (and (eq? 'quote (node-class arg2))
    384                             (not (flonum? (first (node-parameters arg2)))) ) )
    385                    (make-node
    386                     '##core#call '(#t)
    387                     (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) ) ) ) ) )
     347(let ()
     348  (define (eqv?-id db classargs cont callargs)
     349    ;; (eqv? <var> <var>) -> (quote #t)
     350    ;; (eqv? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and not a flonum]
     351    (and (= (length callargs) 2)
     352         (let ([arg1 (first callargs)]
     353               [arg2 (second callargs)] )
     354           (or (and (eq? '##core#variable (node-class arg1))
     355                    (eq? '##core#variable (node-class arg2))
     356                    (equal? (node-parameters arg1) (node-parameters arg2))
     357                    (make-node '##core#call '(#t) (list cont (qnode #t))) )
     358               (and (or (and (eq? 'quote (node-class arg1))
     359                             (not (flonum? (first (node-parameters arg1)))) )
     360                        (and (eq? 'quote (node-class arg2))
     361                             (not (flonum? (first (node-parameters arg2)))) ) )
     362                    (make-node
     363                     '##core#call '(#t)
     364                     (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) ) ) ) )
     365  (rewrite 'eqv? 8 eqv?-id)
     366  (rewrite '##sys#eqv? 8 eqv?-id))
    388367
    389368(rewrite
     
    432411                        (let ([name (car (node-parameters proc))])
    433412                          (and (memq name '(values ##sys#values))
    434                                (or (get db name 'standard-binding)
    435                                    (get db name 'extended-binding) )
     413                               (intrinsic? name)
    436414                               (make-node
    437415                                '##core#call '(#t)
     
    475453
    476454  (rewrite-c..r 'car "C_i_car" "C_u_i_car" 0)
     455  (rewrite-c..r '##sys#car "C_i_car" "C_u_i_car" 0)
     456  (rewrite-c..r '##sys#cdr "C_i_cdr" "C_u_i_cdr" 0)
    477457  (rewrite-c..r 'cadr "C_i_cadr" "C_u_i_cadr" 1)
    478458  (rewrite-c..r 'caddr "C_i_caddr" "C_u_i_caddr" 2)
     
    567547
    568548(rewrite 'eq? 1 2 "C_eqp")
     549(rewrite '##sys#eq? 1 2 "C_eqp")
    569550(rewrite 'eqv? 1 2 "C_i_eqvp")
     551(rewrite '##sys#eqv? 1 2 "C_i_eqvp")
    570552
    571553(rewrite 'list-ref 2 2 "C_u_i_list_ref" #f "C_slot")
    572554(rewrite 'list-ref 2 2 "C_i_list_ref" #t "C_i_vector_ref")
    573555(rewrite 'null? 2 1 "C_i_nullp" #t "C_vemptyp")
     556(rewrite '##sys#null? 2 1 "C_i_nullp" #t "C_vemptyp")
    574557(rewrite 'length 2 1 "C_i_length" #t "C_block_size")
    575558(rewrite 'not 2 1 "C_i_not" #t #f)
     
    579562(rewrite 'symbol? 2 1 "C_i_symbolp" #t #f)
    580563(rewrite 'vector? 2 1 "C_i_vectorp" #t #f)
     564(rewrite '##sys#vector? 2 1 "C_i_vectorp" #t #f)
    581565(rewrite 'pair? 2 1 "C_i_pairp" #t "C_notvemptyp")
     566(rewrite '##sys#pair? 2 1 "C_i_pairp" #t "C_notvemptyp")
    582567(rewrite 'procedure? 2 1 "C_i_closurep" #t #f)
    583568(rewrite 'port? 2 1 "C_i_portp" #t #f)
     
    591576(rewrite 'fixnum? 2 1 "C_fixnump" #t #f)
    592577(rewrite 'finite? 2 1 "C_i_finitep" #f #f)
    593 (rewrite '##sys#pointer? 2 1 "C_pointerp" #t #f)
     578(rewrite '##sys#pointer? 2 1 "C_anypointerp" #t #f)
    594579(rewrite '##sys#generic-structure? 2 1 "C_structurep" #t #f)
    595580(rewrite 'exact? 2 1 "C_fixnump" #f #f)
     
    614599(rewrite 'char<=? 2 2 "C_fixnum_less_or_equal_p" #t #f)
    615600(rewrite '##sys#slot 2 2 "C_slot" #t #f)                ; consider as safe, the primitive is unsafe anyway.
    616 (rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t #f) ; must be safe for pattern matcher
     601(rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t #f) ;*** must be safe for pattern matcher (anymore?)
    617602(rewrite '##sys#size 2 1 "C_block_size" #t #f)
    618603(rewrite 'fxnot 2 1 "C_fixnum_not" #t #f)
     
    705690
    706691(rewrite 'vector-length 2 1 "C_i_vector_length" #t #f)
     692(rewrite '##sys#vector-length 2 1 "C_i_vector_length" #t #f)
    707693(rewrite 'string-length 2 1 "C_i_string_length" #t #f)
    708694(rewrite 'inexact->exact 2 1 "C_i_inexact_to_exact" #t #f)
     
    748734(rewrite 'vector-set! 11 3 '##sys#setslot #f)
    749735(rewrite 'vector-set! 2 3 "C_i_vector_set" #t #f)
     736
     737(rewrite '##sys#vector->list 11 1 'vector->list #t)
     738(rewrite '##sys#list->vector 11 1 'list->vector #t)
     739(rewrite '##sys#>= 11 2 '>= #t)
     740(rewrite '##sys#= 11 2 '= #t)
    750741
    751742(rewrite 'gcd 12 '##sys#gcd #t 2)
     
    906897(rewrite '##sys#direct-return 17 2 "C_direct_return")
    907898
    908 (rewrite 'byte-vector-ref 2 2 "C_subbyte" #f #f) ; DEPRECATED
    909 (rewrite 'byte-vector-set! 2 3 "C_setbyte" #f #f) ; DEPRECATED
    910 (rewrite 'byte-vector-length 2 1 "C_block_size" #f #f) ; DEPRECATED
    911 (rewrite 'blob-size 2 1 "C_block_size" #f #f) ; DEPRECATED
     899(rewrite 'blob-size 2 1 "C_block_size" #f #f)
    912900
    913901(rewrite 'u8vector-ref 2 2 "C_u_i_u8vector_ref" #f #f)
     
    938926(rewrite 'atom? 17 1 "C_i_not_pair_p")
    939927(rewrite 'null-list? 17 1 "C_i_null_list_p" "C_i_nullp")
    940 
    941 (rewrite 'u8vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
    942 (rewrite 's8vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
    943 (rewrite 'u16vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
    944 (rewrite 's16vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
    945 (rewrite 'u32vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
    946 (rewrite 's32vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
    947 (rewrite 'f32vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
    948 (rewrite 'f64vector->byte-vector 7 1 "C_slot" 1 #f) ; DEPRECATED
    949928
    950929(rewrite 'u8vector->blob/shared 7 1 "C_slot" 1 #f)
     
    1018997    (hash-table-ref . hash-table-set!)
    1019998    (block-ref . block-set!)
    1020     (byte-vector-ref . byte-vector-set!) ; DEPRECATED
    1021999    (locative-ref . locative-set!)
    10221000    (u8vector-ref . u8vector-set!)
     
    10481026          (and (eq? '##core#variable (node-class arg))
    10491027               (let ((sym (car (node-parameters arg))))
    1050                  (and (or (get db sym 'standard-binding)
    1051                           (get db sym 'extended-binding))
     1028                 (and (intrinsic? sym)
    10521029                      (and-let* ((a (assq sym setter-map)))
    10531030                        (make-node
  • chicken/branches/prerelease/chicken-bug.scm

    r10641 r13240  
    11;;;; chicken-bug.scm - Bug report-generator
    22;
    3 ; Copyright (c) 2008, The Chicken Team
     3; Copyright (c) 2008-2009, The Chicken Team
    44; All rights reserved.
    55;
     
    2525
    2626
    27 (use srfi-13 posix tcp data-structures utils extras)
    28 
    29 
    30 #>
    31 #ifndef C_TARGET_CC
    32 # define C_TARGET_CC  C_INSTALL_CC
    33 #endif
    34 
    35 #ifndef C_TARGET_CXX
    36 # define C_TARGET_CXX  C_INSTALL_CXX
    37 #endif
    38 <#
     27(require-extension srfi-13 posix tcp data-structures utils extras)
    3928
    4029
     
    144133      (set! msg (string-append msg "\n\n" (user-input))))
    145134    (newline)
    146     (match-let ((#(_ _ _ day mon yr _ _ _ _) (seconds->local-time (current-seconds))))
    147         (if stdout
    148             (begin
    149                 (print msg)
    150                 (collect-info))
    151             (try-mail
    152                 +mxservers+
    153                 (sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day))
    154                 (mail-headers)
    155                 (with-output-to-string
    156                     (lambda ()
    157                         (print msg)
    158                         (collect-info))))))))
     135    (let* ((lt (seconds->local-time (current-seconds)))
     136           (day (vector-ref lt 3))
     137           (mon (vector-ref lt 4))
     138           (yr (vector-ref lt 5)) )
     139      (if stdout
     140          (begin
     141            (print msg)
     142            (collect-info))
     143          (try-mail
     144           +mxservers+
     145           (sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day))
     146           (mail-headers)
     147           (with-output-to-string
     148             (lambda ()
     149               (print msg)
     150               (collect-info))))))))
    159151      ;(let* ((file (sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day)))
    160152        ;     (port (if stdout (current-output-port) (open-output-file file))))
  • chicken/branches/prerelease/chicken-profile.scm

    r10643 r13240  
    22;
    33; Copyright (c) 2000-2007, Felix L. Winkelmann
    4 ; Copyright (c) 2008, The Chicken Team
     4; Copyright (c) 2008-2009, The Chicken Team
    55; All rights reserved.
    66;
     
    9090            (let ((n (string->number (next-arg))))
    9191              (if (and n (> n 0)) n (error "invalid argument to option" arg))))
    92           (match arg
    93             [(or "-h" "-help" "--help") (print-usage)]
    94             [(or "-v" "-version")
    95              (print "chicken-profile - Version " (chicken-version))
    96              (exit) ]
    97             ["-release"
    98              (print (chicken-version))
    99              (exit) ]
    100             ["-no-unused" (set! no-unused #t)]
    101             ["-top" (set! top (next-number))]
    102             ["-sort-by-calls" (set! sort-by sort-by-calls)]
    103             ["-sort-by-time" (set! sort-by sort-by-time)]
    104             ["-sort-by-avg" (set! sort-by sort-by-avg)]
    105             ["-sort-by-name" (set! sort-by sort-by-name)]
    106             ["-decimals" (set-decimals (next-arg))]
    107             [_ (cond [(and (> (string-length arg) 1) (char=? #\- (string-ref arg 0)))
    108                       (error "invalid option" arg) ]
    109                      [file (print-usage)]
    110                      [else (set! file arg)] ) ] )
     92          (cond
     93           [(member arg '("-h" "-help" "--help")) (print-usage)]
     94           [(member arg '("-v" "-version"))
     95            (print "chicken-profile - Version " (chicken-version))
     96            (exit) ]
     97           [(string=? arg "-release")
     98            (print (chicken-version))
     99            (exit) ]
     100           [(string=? arg "-no-unused") (set! no-unused #t)]
     101           [(string=? arg "-top") (set! top (next-number))]
     102           [(string=? arg "-sort-by-calls") (set! sort-by sort-by-calls)]
     103           [(string=? arg "-sort-by-time") (set! sort-by sort-by-time)]
     104           [(string=? arg "-sort-by-avg") (set! sort-by sort-by-avg)]
     105           [(string=? arg "-sort-by-name") (set! sort-by sort-by-name)]
     106           [(string=? arg "-decimals") (set-decimals (next-arg))]
     107           [(and (> (string-length arg) 1) (char=? #\- (string-ref arg 0)))
     108            (error "invalid option" arg) ]
     109           [file (print-usage)]
     110           [else (set! file arg)] )
    111111          (loop rest) ) ) ) )
    112112
  • chicken/branches/prerelease/chicken.1

    r10911 r13240  
    3737.TP
    3838.B \-block
    39 Enable block-compilation. When this option is specified, the compiler assumes that global variables are not modified outside this compilation-unit.
     39Enable block-compilation. When this option is specified, the compiler assumes
     40that global variables are not modified outside this compilation-unit.
    4041
    4142.TP
    4243.B \-case\-insensitive
    43 Enables the reader to read symbols case-insensitive. The default is to read case-sensitive (in violation of R5RS).
     44Enables the reader to read symbols case-insensitive. The default is to read
     45case-sensitive (in violation of R5RS).
    4446This option registers the
    4547.B case\-insensitive
     
    5658.TP
    5759.BI \-database\-size \ number
    58 Specifies the initial size of the analysis-database. Should only be used if extremely large files are to be compiled.
     60Specifies the initial size of the analysis-database. Should only be used if
     61extremely large files are to be compiled.
    5962
    6063.TP
     
    8992.B \-disable\-interrupts
    9093Equivalent to
    91 .B \-prelude\ "(declare\ (interrupts-disabled))"
     94.B \-prelude\ \'(declare\ (interrupts-disabled))\'
     95\.
    9296
    9397.TP
     
    96100
    97101.TP
    98 .B \-disable\-warning\ class
    99 Disables specific class of warnings, may be given multiple times.
     102.BI \-disable\-warning \ class
     103Disables specific
     104.I class
     105of warnings, may be given multiple times.
     106.P
     107.br
     108.B \ \ \ \ ext\ \ \
     109Suspect extension use.
     110.br
     111.B \ \ \ \ type\ \
     112Suspect type/literal use.
     113.br
     114.B \ \ \ \ usage\
     115Suspect feature use.
     116.br
     117.B \ \ \ \ style\
     118Suspect feature use.
     119.br
     120.B \ \ \ \ syntax
     121Suspect sytax form.
     122.br
     123.B \ \ \ \ redef\
     124Redefinition of builtin binding.
     125.br
     126.B \ \ \ \ var\ \ \
     127Suspect variable use.
    100128
    101129.TP
     
    112140
    113141.TP
    114 .I \-emit\-debug\-info
     142.B \-emit\-debug\-info
    115143Emit additional information for each
    116144.B lambda
     
    119147
    120148.TP
    121 .BI \-emit\-exports\ filename
     149.BI \-emit\-exports \ filename
    122150Write exported toplevel variables to file
    123 .B filename
    124 
    125 .TP
    126 .I \-emit\-external\-prototypes\-first
     151.I filename
     152\.
     153
     154.TP
     155.B \-emit\-external\-prototypes\-first
    127156Emit prototypes for callbacks defined with
    128157.B define\-external
     
    131160the a Scheme program has to access the callbacks. By default the prototypes are emitted
    132161after foreign declarations.
     162
     163.TP
     164.BI \-emit\-inline\-file \ filename
     165Write procedures that can be globally inlined in internal form to
     166.I filename
     167, if global inlining is enabled. Implies "-inline -local".
    133168
    134169.TP
     
    143178.TP
    144179.BI \-extend \ filename
    145 Loads a Scheme file before compilation commences. This feature can be used to extend the compiler.
     180Loads a Scheme file,
     181.I filename
     182, before compilation commences. This feature can be used to extend the compiler.
    146183
    147184.TP
    148185.B \-extension
    149186Mostly equivalent to
    150 .B \-prelude\ \'\(define-extension\ NAME\)\'
     187.B \-prelude\ \'(define-extension\ NAME)\'
    151188where
    152189.B NAME
    153190is the basename of the currently compiled file. Note that if you want to compile a file
    154191as a normal (dynamically loadable) extension library, you should also pass the
    155 .I \-shared
     192.B \-shared
    156193option.
    157194
     
    166203.B \-fixnum\-arithmetic
    167204Equivalent to
    168 .B \-prelude\ "(declare\ (fixnum))"
     205.B \-prelude\ \'(declare\ (fixnum))\'
     206\.
    169207
    170208.TP
     
    177215or
    178216.B K
    179 suffix which stand for mega- and kilobytes, respectively. The default heap-size is 16 megabytes.
     217suffix which stand for mega- and kilo-bytes, respectively. The default heap-size is 16 megabytes.
    180218
    181219.TP
     
    193231.TP
    194232.B \-help
    195 Print a summary of available options and the format of the command-line parameters and exit the compiler.
     233Print a summary of available options and the format of the command-line
     234parameters and exit the compiler.
     235
     236.TP
     237.B \-ignore\-repository
     238Do not load any extensions from the repository (treat repository as empty). Also
     239do not consult compiled (only interpreted) import libraries in
     240.I import
     241forms.
    196242
    197243.TP
     
    204250Specifies an additional search path for files included via the
    205251.I include
    206 special form. This option may be given multiple times. If the environment variable
    207 .B CHICKEN_INCLUDE_PATH
    208 is set, it should contain a list of alternative include
    209 pathnames separated by
    210 .I \;
    211 \.
     252special form. This option may be given multiple times.
    212253
    213254.TP
     
    216257
    217258.TP
    218 .BI \-inline\-limit threshold
     259.B \-inline\-global
     260Enable cross-module inlining.
     261
     262.TP
     263.BI \-inline\-limit \ threshold
    219264Sets the maximum size of potentially inlinable procedures.
    220265
    221266.TP
    222267.BI \-keep\-shadowed\-macros
    223 Do not remove macro definitions with the same name as assigned toplevel variables (the default is to remove the macro definition).
    224 
    225 .TP
    226 .BI \-keyword\-style style
     268Do not remove macro definitions with the same name as assigned toplevel
     269variables (the default is to remove the macro definition).
     270
     271.TP
     272.BI \-keyword\-style \ style
    227273Enables alternative keyword syntax, where style may be either
    228274.B prefix
     
    231277(as in DSSSL) or
    232278.B none
    233 Any other value is ignored. The default is \texttt{suffix}.
     279Any other value is ignored. The default is
     280.B suffix
     281\.
    234282
    235283.TP
     
    238286
    239287.TP
     288.B \-local
     289Assume toplevel variables defined in the current compilation unit are
     290not externally modified.
     291
     292.TP
    240293.B \-no\-trace
    241 Disable generation of tracing information. If a compiled executable should halt due to a runtime error,
    242 then a file containing a stack-trace will be written to the current directory under the name
     294Disable generation of tracing information. If a compiled executable should halt
     295due to a runtime error, then a file containing a stack-trace will be written to
     296the current directory under the name
    243297.I STACKTRACE
    244 \. Each line in the created file gives the name and the line-number (if available) of a procedure call.
    245 With this option given, the generated code is slightly faster.
     298\. Each line in the created file gives the name and the line-number (if
     299available) of a procedure call. With this option given, the generated code is
     300slightly faster.
    246301
    247302.TP
     
    251306.TP
    252307.BI \-nursery \ number
     308
    253309.TP
    254310.BI \-stack\-size \ number
     
    297353.I expressions
    298354after all other toplevel expressions in the compiled file.
    299 This option may be given multiple times. Processing of this option takes place after processing of
     355This option may be given multiple times. Processing of this option takes place
     356after processing of
    300357.BI \-epilogue
    301358\.
     
    306363.I expressions
    307364before all other toplevel expressions in the compiled file.
    308 This option may be given multiple times. Processing of this option takes place before processing of
     365This option may be given multiple times. Processing of this option takes place
     366before processing of
    309367.B \-prologue
    310368\.
     
    313371.B \-profile
    314372.B \-accumulate\-profile
    315 Instruments the source code to count procedure calls and execution times. After the program terminates
    316 (either via an explicit
     373Instruments the source code to count procedure calls and execution times. After
     374the program terminates (either via an explicit
    317375.B exit
    318376or implicitly), profiling statistics are written to a file named
     
    325383
    326384.TP
    327 .B \-profile\-name\ filename
     385.BI \-profile\-name \ filename
    328386Specifies the name of the generated profile information file. Only useful
    329387in combination with the
     
    339397at the start of the compiled source file.
    340398The include-path is not searched. This option may be given multiple times.
    341 
    342 .TP
    343 .B \-quiet
    344 Disables output of compile information.
    345399
    346400.TP
     
    363417also available at run-time. By default
    364418low-level macros are not available at run-time. Note that highlevel-macros ("syntax-case")
    365  defined in compiled code are never available at run-time.
     419defined in compiled code are never available at run-time.
    366420
    367421.TP
     
    413467.TP
    414468.B CHICKEN_INCLUDE_PATH
    415 Contains one or more pathnames where the compiler should additionally look for include-files, separated by
     469Contains one or more pathnames where the compiler should additionally look for
     470include-files, separated by
    416471.B \;
    417472characters.
     
    423478\.
    424479
     480.SH RUNTIME\ OPTIONS
     481After successful compilation a C source file is generated and can be compiled
     482with a C compiler. Executables generated with
     483.B chicken
     484(and the
     485.B chicken
     486program itself) accept a small set of runtime options.
     487
     488.TP
     489.B \-:?
     490Shows a list of the available runtime options and exits the program.
     491
     492.TP
     493.B \-:aNUMBER
     494Specifies the length of the buffer for recording a trace of the last invoked
     495procedures. Defaults to 8.
     496
     497.TP
     498.B \-:b
     499Enter a read-eval-print-loop when an error is encountered.
     500
     501.TP
     502.B \-:B
     503Sounds a bell (ASCII 7) on every major garbage collection.
     504
     505.TP
     506.B \-:c
     507Forces console mode. Currently this is only used in the interpreter (csi) to
     508force output of the
     509.I #;N>
     510prompt even if stdin is not a terminal (for example if running in an emacs buffer under Windows).
     511
     512.TP
     513.B \-:d
     514Prints some debug-information at runtime.
     515
     516.TP
     517.B \-:D
     518Prints some more debug-information at runtime.
     519
     520.TP
     521.B \-:fNUMBER
     522Specifies the maximal number of currently pending finalizers before finalization is forced.
     523
     524.TP
     525.B \-:hNUMBER
     526Specifies fixed heap size
     527
     528.TP
     529.B \-:hgPERCENTAGE
     530Sets the growth rate of the heap in percent. If the heap is exhausted, then it
     531will grow by
     532.B PERCENTAGE
     533\. The default is 200.
     534
     535.TP
     536.B \-:hiNUMBER
     537Specifies the initial heap size
     538
     539.TP
     540.B \-:hmNUMBER
     541Specifies a maximal heap size. The default is (2GB - 15).
     542
     543.TP
     544.B \-:hsPERCENTAGE
     545Sets the shrink rate of the heap in percent. If no more than a quarter of
     546.B PERCENTAGE
     547of the heap is used, then it will shrink to
     548.B PERCENTAGE
     549\. The default
     550is 50. Note: If you want to make sure that the heap never shrinks, specify a
     551value of 0. (this can be useful in situations where an optimal heap-size is
     552known in advance).
     553
     554.TP
     555.B \-:o
     556Disables detection of stack overflows at run-time.
     557
     558.TP
     559.B \-:r
     560Writes trace output to stderr. This option has no effect with in files compiled with the
     561.B -no-trace
     562options.
     563
     564.TP
     565.B \-:sNUMBER
     566Specifies stack size.
     567
     568.TP
     569.B \-:tNUMBER
     570Specifies symbol table size.
     571
     572.TP
     573.B \-:w
     574Enables garbage collection of unused symbols. By default unused and unbound
     575symbols are not garbage collected.
     576
     577.TP
     578.B \-:x
     579Raises uncaught exceptions of separately spawned threads in primordial thread.
     580By default uncaught exceptions in separate threads are not handled, unless the
     581primordial one explicitly joins them. When warnings are enabled (the default)
     582and
     583.B \-:x
     584is not given, a warning will be shown, though.
     585
     586.P
     587The
     588.B NUMBER
     589argument values may be given in bytes, in kilobytes (suffixed with K or k),
     590in megabytes (suffixed with M or m), or in gigabytes (suffixed with G or g).
     591Runtime options may be combined, like
     592.B \-:dc
     593, but everything following a
     594.B NUMBER
     595argument is ignored. So
     596.B \-:wh64m
     597is OK, but
     598.B \-:h64mw
     599will not enable GC of unused symbols.
     600
    425601.SH DOCUMENTATION
    426602
  • chicken/branches/prerelease/chicken.h

    r11043 r13240  
    22;
    33; Copyright (c) 2000-2007, Felix L. Winkelmann
    4 ; Copyright (c) 2008, The Chicken Team
     4; Copyright (c) 2008-2009, The Chicken Team
    55; All rights reserved.
    66;
     
    99;
    1010;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
    11 ;     disclaimer. 
     11;     disclaimer.
    1212;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
    13 ;     disclaimer in the documentation and/or other materials provided with the distribution. 
     13;     disclaimer in the documentation and/or other materials provided with the distribution.
    1414;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
    15 ;     products derived from this software without specific prior written permission. 
     15;     products derived from this software without specific prior written permission.
    1616;
    1717; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
     
    2828/* Configuration: */
    2929
     30/*
     31 * The Watcom (__WATCOMC__), Metroworks (__MWERKS__), and Delorie (__DJGPP__)
     32 * compilers are not currently supported but existing references remain,
     33 * just in case.
     34 */
     35
    3036#ifndef ___CHICKEN
    3137#define ___CHICKEN
    3238
    33 #define C_MAJOR_VERSION       3
     39#define C_MAJOR_VERSION       4
    3440
    3541/*
     
    4046#endif
    4147
    42 #if !defined(__GNUC__) && !defined(__WATCOMC__)
     48
     49/* Kind of platform */
     50
     51#ifndef C_SIXTY_FOUR
     52# if defined (__alpha__) || defined (__sparc_v9__) || defined (__sparcv9) || defined(__ia64__) || defined(__x86_64__) || defined(__LP64__) || defined(__powerpc64__)
     53#   define C_SIXTY_FOUR
     54# elif defined(__mips64) && (!defined(__GNUC__) || _MIPS_SZPTR == 64)
     55#   define C_SIXTY_FOUR
     56# endif
     57#endif
     58
     59#if defined(__APPLE__) && defined(__MACH__)
     60# define C_MACOSX
     61#endif
     62
     63#if defined(C_MACOSX) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
     64# define C_XXXBSD
     65#endif
     66
     67#if /*defined(__GNUC__) &&*/ (defined(__linux__) || defined(C_XXXBSD))
     68# define C_GNU_ENV
     69#endif
     70
     71#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__WATCOMC__) || defined(__MWERKS__) || defined(__DJGPP__)
     72# define C_NONUNIX
     73#endif
     74
     75
     76/* Headers */
     77
     78#include <stdio.h>
     79#include <stdlib.h>
     80#include <stdarg.h>
     81#include <ctype.h>
     82#include <string.h>
     83#include <setjmp.h>
     84#include <limits.h>
     85#include <time.h>
     86
     87#if !defined(C_NONUNIX) || defined(__MINGW32__) || defined(__WATCOMC__)
     88# include <unistd.h>
     89# include <inttypes.h>
     90# include <sys/types.h>
     91#endif
     92
     93/* Byteorder in machine word */
     94
     95#if defined(__MINGW32__)
     96# include <sys/param.h>
     97#elif defined(__CYGWIN__)
     98# include <endian.h>
     99#elif defined(__linux__)
     100# include <endian.h>
     101#elif defined(C_XXXBSD)
     102# include <machine/endian.h>
     103#elif defined(__hpux__)
     104# include <arpa/nameser.h>
     105#elif defined(_AIX)
     106# include <sys/machine.h>
     107#elif defined(__sun__)
     108# include <sys/isa_defs.h>
     109#elif defined(__svr4__)
     110# include <sys/byteorder.h>
     111#endif
     112
     113#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__WATCOMC__)
     114# include <malloc.h>
     115#endif
     116
     117#ifdef _MSC_VER
     118# include <io.h>
     119#endif
     120
     121/* Much better with stack allocation API */
     122
     123#if defined(_MSC_VER)
     124# if HAVE_ALLOCA_H
     125#  define alloca            _alloca
     126# endif
     127#elif !defined(__GNUC__) && !defined(__WATCOMC__)
    43128# if HAVE_ALLOCA_H
    44129#  include <alloca.h>
    45 # else
    46 #  ifdef _AIX
     130# elif defined(_AIX)
    47131#   pragma alloca
    48 #  else
    49 #   ifndef alloca /* predefined by HP cc +Olibcalls */
    50 char *alloca ();
    51 #   endif
    52 #  endif
     132# elif !defined(alloca) /* predefined by HP cc +Olibcalls */
     133    char *alloca ();
    53134# endif
    54135#elif (defined(__sun__) && defined(__svr4__)) || defined(__sgi__)
     
    58139#endif
    59140
     141
     142/* Chicken Core C API */
     143
     144#if defined(__BYTE_ORDER) && __BYTE_ORDER == __BIG_ENDIAN
     145# define C_BIG_ENDIAN
     146#elif defined(BYTE_ORDER) && defined(BIG_ENDIAN) && BYTE_ORDER == BIG_ENDIAN
     147# define C_BIG_ENDIAN
     148#elif defined(__BIG_ENDIAN__)
     149# define C_BIG_ENDIAN
     150#elif defined(__sparc__) || defined(__POWERPC__) || defined(__MC68K__) || defined(__mips__)
     151# define C_BIG_ENDIAN
     152#endif
     153
     154#if defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && __BYTE_ORDER == __LITTLE_ENDIAN
     155# define C_LITTLE_ENDIAN
     156#elif defined(BYTE_ORDER) && defined(LITTLE_ENDIAN) && BYTE_ORDER == LITTLE_ENDIAN
     157# define C_LITTLE_ENDIAN
     158#elif defined(__LITTLE_ENDIAN__)
     159# define C_LITTLE_ENDIAN
     160#elif defined (__alpha__) || defined(_M_IX86) || defined(__i386__) || defined(__x86_64__) || defined(__ia64__)
     161# define C_LITTLE_ENDIAN
     162#endif
     163
     164/* Make sure some common C identifiers are availble w/ Windows */
     165
     166#ifdef _MSC_VER
     167# define strncasecmp       strnicmp
     168# define isatty            _isatty
     169typedef __int8             int8_t;
     170typedef unsigned __int8    uint8_t;
     171typedef __int16            int16_t;
     172typedef unsigned  __int16  uint16_t;
     173typedef __int32            int32_t;
     174typedef unsigned __int32   uint32_t;
     175typedef __int64            int64_t;
     176typedef unsigned __int64   uint64_t;
     177# pragma warning(disable: 4101)
     178#endif
     179
     180/* Could be used by C++ source */
     181
    60182#ifdef __cplusplus
    61183# define C_extern                  extern "C"
     
    67189# define C_END_C_DECLS
    68190#endif
    69  
     191
     192
     193/* Function declaration modes */
     194
     195/* Visibility */
    70196#define C_varextern                C_extern
    71197#define C_fctimport
     
    116242#endif
    117243
     244/* Language specifics: */
     245#if defined(__GNUC__) || defined(__INTEL_COMPILER)
     246# ifndef __cplusplus
     247#  define C_cblock                ({
     248#  define C_cblockend             })
     249#  define C_noret                 __attribute__ ((noreturn))
     250#  define C_noret_decl(name)
     251#  define C_aligned               __attribute__ ((aligned))
     252# endif
     253# ifdef __i386__
     254#  define C_regparm               __attribute__ ((regparm(3)))
     255# endif
     256#elif defined(_MSC_VER)
     257# define C_fcall                  __fastcall
     258#elif defined(__WATCOMC__)
     259# define C_ccall                  __cdecl
     260#endif
     261
     262#ifndef C_cblock
     263# define C_cblock                 do{
     264# define C_cblockend              }while(0)
     265# define C_noret
     266# define C_noret_decl(name)
     267#endif
     268
     269#ifndef C_regparm
     270# define C_regparm
     271#endif
     272
     273#ifndef C_fcall
     274# define C_fcall
     275#endif
     276
     277#ifndef C_ccall
     278# define C_ccall
     279#endif
     280
     281#ifndef C_aligned
     282# define C_aligned
     283#endif
     284
     285#define C_c_regparm
     286
     287/* Thread Local Stoarage */
    118288#ifdef C_ENABLE_TLS
    119289# if defined(__GNUC__)
     
    127297# define C_TLS
    128298#endif
     299
     300
     301/* Stack growth direction; used to compute stack addresses */
    129302
    130303#ifndef C_STACK_GROWS_DOWNWARD
     
    142315#endif
    143316
     317/* Have a GUI? */
     318
    144319#if defined(C_WINDOWS_GUI)
    145320# define C_MICROSOFT_WINDOWS
     
    148323#endif
    149324
     325/* Needed for pre-emptive threading */
     326
    150327#define C_TIMER_INTERRUPTS
    151 
    152 #ifdef C_DEFAULT_TARGET_STACK_SIZE
    153 # define C_resize_stack(n)           C_do_resize_stack(C_DEFAULT_TARGET_STACK_SIZE)
    154 #else
    155 # define C_resize_stack(n)           C_do_resize_stack(n)
    156 #endif
    157 
    158 #ifndef C_SIXTY_FOUR
    159 # if defined (__alpha__) || defined (__sparc_v9__) || defined (__sparcv9) || defined(__ia64__) || defined(__x86_64__) || defined(__LP64__) || defined(__powerpc64__)
    160 #   define C_SIXTY_FOUR
    161 # elif defined(__mips64) && (!defined(__GNUC__) || _MIPS_SZPTR == 64)
    162 #   define C_SIXTY_FOUR
    163 # endif
    164 #endif
    165 
    166 #if defined(__APPLE__) && defined(__MACH__)
    167 # define C_MACOSX
    168 #endif
    169 
    170 #if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
    171 # define C_XXXBSD
    172 #endif
    173 
    174 #if defined(C_MACOSX) || defined(__linux__) || defined(C_XXXBSD)
    175 # define C_GNU_ENV
    176 #endif
    177 
    178 #if defined(_MSC_VER) || defined(__MWERKS__) || defined(__DJGPP__) || defined(__MINGW32__) || defined(__WATCOMC__)
    179 # define C_NONUNIX
    180 #endif
    181 
    182 #include <stdio.h>
    183 #include <stdlib.h>
    184 #include <stdarg.h>
    185 #include <ctype.h>
    186 #include <string.h>
    187 #include <setjmp.h>
    188 #include <limits.h>
    189 #include <time.h>
    190 
    191 #if !defined(C_NONUNIX) || defined(__MINGW32__) || defined(__WATCOMC__)
    192 # include <unistd.h>
    193 # include <inttypes.h>
    194 # include <sys/types.h>
    195 #endif
    196 
    197 #if defined(__MINGW32__)
    198 # include <sys/param.h>
    199 #elif defined(__CYGWIN__)
    200 # include <endian.h>
    201 #elif defined(__linux__)
    202 # include <endian.h>
    203 #elif defined(C_MACOSX) || defined(C_XXXBSD)
    204 # include <machine/endian.h>
    205 #elif defined(__hpux__)
    206 # include <arpa/nameser.h>
    207 #elif defined(_AIX)
    208 # include <sys/machine.h>
    209 #elif defined(__sun__)
    210 # include <sys/isa_defs.h>
    211 #elif defined(__svr4__)
    212 # include <sys/byteorder.h>
    213 #endif
    214 
    215 #if defined(__BYTE_ORDER) && __BYTE_ORDER == __BIG_ENDIAN
    216 # define C_BIG_ENDIAN
    217 #elif defined(BYTE_ORDER) && defined(BIG_ENDIAN) && BYTE_ORDER == BIG_ENDIAN
    218 # define C_BIG_ENDIAN
    219 #elif defined(__BIG_ENDIAN__)
    220 # define C_BIG_ENDIAN
    221 #elif defined(__sparc__) || defined(__POWERPC__) || defined(__MC68K__) || defined(__mips__)
    222 # define C_BIG_ENDIAN
    223 #endif
    224 
    225 #if defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && __BYTE_ORDER == __LITTLE_ENDIAN
    226 # define C_LITTLE_ENDIAN
    227 #elif defined(BYTE_ORDER) && defined(LITTLE_ENDIAN) && BYTE_ORDER == LITTLE_ENDIAN
    228 # define C_LITTLE_ENDIAN
    229 #elif defined(__LITTLE_ENDIAN__)
    230 # define C_LITTLE_ENDIAN
    231 #elif defined (__alpha__) || defined(_M_IX86) || defined(__i386__) || defined(__x86_64__) || defined(__ia64__)
    232 # define C_LITTLE_ENDIAN
    233 #endif
    234 
    235 #ifdef __MINGW32__
    236 # include <malloc.h>
    237 #endif
    238 
    239 #ifdef _MSC_VER
    240 # include <malloc.h>
    241 # include <io.h>
    242 # define alloca            _alloca
    243 # define strncasecmp       strnicmp
    244 # define isatty            _isatty
    245 typedef __int8             int8_t;
    246 typedef unsigned __int8    uint8_t;
    247 typedef __int16            int16_t;
    248 typedef unsigned  __int16  uint16_t;
    249 typedef __int32            int32_t;
    250 typedef unsigned __int32   uint32_t;
    251 typedef __int64            int64_t;
    252 typedef unsigned __int64   uint64_t;
    253 # pragma warning(disable: 4101)
    254 #endif
    255 
    256 #ifdef __WATCOMC__
    257 # include <malloc.h>
    258 #endif
    259328
    260329/* For the easy FFI: */
     
    308377#define C_FIXNUM_SHIFT            1
    309378
     379/* Character range is that of a UTF-8 codepoint, not representable range */
    310380#define C_CHAR_BIT_MASK           0x1fffff
     381#define C_CHAR_SHIFT              8
    311382
    312383#ifdef C_SIXTY_FOUR
     
    336407# define C_CLOSURE_TYPE           (0x0400000000000000L | C_SPECIALBLOCK_BIT)
    337408# define C_FLONUM_TYPE            (0x0500000000000000L | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
    338 # define C_UNUSED_TYPE            (0x0600000000000000L)
     409/*       unused                   (0x0600000000000000L ...) */
    339410# define C_PORT_TYPE              (0x0700000000000000L | C_SPECIALBLOCK_BIT)
    340411# define C_STRUCTURE_TYPE         (0x0800000000000000L)
    341412# define C_POINTER_TYPE           (0x0900000000000000L | C_SPECIALBLOCK_BIT)
    342 # define C_BUCKET_TYPE            (0x0f00000000000000L)
    343413# define C_LOCATIVE_TYPE          (0x0a00000000000000L | C_SPECIALBLOCK_BIT)
    344414# define C_TAGGED_POINTER_TYPE    (0x0b00000000000000L | C_SPECIALBLOCK_BIT)
    345 # define C_SWIG_POINTER_TYPE      (0x0c00000000000000L | C_BYTEBLOCK_BIT)
     415# define C_SWIG_POINTER_TYPE      (0x0c00000000000000L | C_SPECIALBLOCK_BIT)
    346416# define C_LAMBDA_INFO_TYPE       (0x0d00000000000000L | C_BYTEBLOCK_BIT)
     417/*       unused                   (0x0e00000000000000L ...) */
     418# define C_BUCKET_TYPE            (0x0f00000000000000L)
    347419#else
    348420# define C_INT_SIGN_BIT           0x80000000
     
    361433# define C_CLOSURE_TYPE           (0x04000000 | C_SPECIALBLOCK_BIT)
    362434# ifdef C_DOUBLE_IS_32_BITS
    363 #  define C_FLONUM_TYPE            (0x05000000 | C_BYTEBLOCK_BIT)
     435#  define C_FLONUM_TYPE           (0x05000000 | C_BYTEBLOCK_BIT)
    364436# else
    365 #  define C_FLONUM_TYPE            (0x05000000 | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
     437#  define C_FLONUM_TYPE           (0x05000000 | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
    366438# endif
    367 # define C_UNUSED_TYPE            (0x06000000)
     439/*       unused                   (0x06000000 ...) */
    368440# define C_PORT_TYPE              (0x07000000 | C_SPECIALBLOCK_BIT)
    369441# define C_STRUCTURE_TYPE         (0x08000000)
    370442# define C_POINTER_TYPE           (0x09000000 | C_SPECIALBLOCK_BIT)
    371 # define C_BUCKET_TYPE            (0x0f000000)
    372443# define C_LOCATIVE_TYPE          (0x0a000000 | C_SPECIALBLOCK_BIT)
    373444# define C_TAGGED_POINTER_TYPE    (0x0b000000 | C_SPECIALBLOCK_BIT)
    374 # define C_SWIG_POINTER_TYPE      (0x0c000000 | C_BYTEBLOCK_BIT)
     445# define C_SWIG_POINTER_TYPE      (0x0c000000 | C_SPECIALBLOCK_BIT)
    375446# define C_LAMBDA_INFO_TYPE       (0x0d000000 | C_BYTEBLOCK_BIT)
    376 #endif
    377 
     447/*       unused                   (0x0e000000 ...) */
     448# define C_BUCKET_TYPE            (0x0f000000)
     449#endif
     450#define C_VECTOR_TYPE             0x00000000
     451#define C_BYTEVECTOR_TYPE         (C_VECTOR_TYPE | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
     452
     453#define C_SIZEOF_LIST(n)          ((n) * 3 + 1)
     454#define C_SIZEOF_PAIR             3
     455#define C_SIZEOF_STRING(n)        (C_bytestowords(n) + 2)
     456#define C_SIZEOF_SYMBOL           4
     457#define C_SIZEOF_INTERNED_SYMBOL(n) (C_SIZEOF_SYMBOL + C_SIZEOF_BUCKET + C_SIZEOF_STRING(n))
     458#ifdef C_DOUBLE_IS_32_BITS
     459# define C_SIZEOF_FLONUM          2
     460#else
     461# define C_SIZEOF_FLONUM          4
     462#endif
     463#define C_SIZEOF_POINTER          2
     464#define C_SIZEOF_TAGGED_POINTER   3
     465#define C_SIZEOF_SWIG_POINTER     3
     466#define C_SIZEOF_VECTOR(n)        ((n) + 1)
     467#define C_SIZEOF_BUCKET           3
     468#define C_SIZEOF_LOCATIVE         5
     469#define C_SIZEOF_PORT             16
     470
     471/* Fixed size types have pre-computed header tags */
     472#define C_PAIR_TAG                (C_PAIR_TYPE | (C_SIZEOF_PAIR - 1))
     473#define C_POINTER_TAG             (C_POINTER_TYPE | (C_SIZEOF_POINTER - 1))
     474#define C_LOCATIVE_TAG            (C_LOCATIVE_TYPE | (C_SIZEOF_LOCATIVE - 1))
     475#define C_TAGGED_POINTER_TAG      (C_TAGGED_POINTER_TYPE | (C_SIZEOF_TAGGED_POINTER - 1))
     476#define C_SWIG_POINTER_TAG        (C_SWIG_POINTER_TYPE | (C_wordstobytes(C_SIZEOF_SWIG_POINTER - 1)))
     477#define C_SYMBOL_TAG              (C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1))
     478#define C_FLONUM_TAG              (C_FLONUM_TYPE | sizeof(double))
     479
     480/* Locative subtypes */
    378481#define C_SLOT_LOCATIVE           0
    379482#define C_CHAR_LOCATIVE           1
     
    387490#define C_F64_LOCATIVE            9
    388491
    389 #define C_VECTOR_TYPE             0x00000000
    390 #define C_BYTEVECTOR_TYPE         (C_VECTOR_TYPE | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
    391 
    392 #define C_SIZEOF_LIST(n)          ((n) * 3 + 1)
    393 #define C_SIZEOF_PAIR             3
    394 #define C_SIZEOF_STRING(n)        (C_bytestowords(n) + 2)
    395 #define C_SIZEOF_SYMBOL          4
    396 #define C_SIZEOF_INTERNED_SYMBOL(n) (C_SIZEOF_SYMBOL + C_SIZEOF_BUCKET + C_SIZEOF_STRING(n))
    397 #ifdef C_DOUBLE_IS_32_BITS
    398 # define C_SIZEOF_FLONUM           2
    399 #else
    400 # define C_SIZEOF_FLONUM           4
    401 #endif
    402 #define C_SIZEOF_POINTER          2
    403 #define C_SIZEOF_TAGGED_POINTER   3
    404 #define C_SIZEOF_SWIG_POINTER     3
    405 #define C_SIZEOF_VECTOR(n)        ((n) + 1)
    406 #define C_SIZEOF_BUCKET           3
    407 #define C_SIZEOF_LOCATIVE         5
    408 #define C_SIZEOF_PORT             16
    409 
    410 #define C_PAIR_TAG                (C_PAIR_TYPE | (C_SIZEOF_PAIR - 1))
    411 #define C_POINTER_TAG             (C_POINTER_TYPE | (C_SIZEOF_POINTER - 1))
    412 #define C_LOCATIVE_TAG            (C_LOCATIVE_TYPE | (C_SIZEOF_LOCATIVE - 1))
    413 #define C_TAGGED_POINTER_TAG      (C_TAGGED_POINTER_TYPE | (C_SIZEOF_TAGGED_POINTER - 1))
    414 #define C_SWIG_POINTER_TAG        (C_SWIG_POINTER_TYPE | (C_wordstobytes(C_SIZEOF_SWIG_POINTER - 1)))
    415 #define C_SYMBOL_TAG              (C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1))
    416 #define C_FLONUM_TAG             (C_FLONUM_TYPE | sizeof(double))
    417 
    418492#ifdef C_SIXTY_FOUR
    419493# define C_word                   long
     
    451525#define C_NOT_A_CLOSURE_ERROR                         9
    452526#define C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR      10
     527#define C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR         11
    453528#define C_TOO_DEEP_RECURSION_ERROR                    12
    454529#define C_CANT_REPRESENT_INEXACT_ERROR                13
     
    478553
    479554
    480 #define CHICKEN_gc_root_ref(root)      (((C_GC_ROOT *)(root))->value)
    481 #define CHICKEN_gc_root_set(root, x)   C_mutate(&((C_GC_ROOT *)(root))->value, (x))
    482 
    483 #define CHICKEN_global_ref(root)       C_u_i_car(((C_GC_ROOT *)(root))->value)
    484 #define CHICKEN_global_set(root, x)    C_mutate(&C_u_i_car(((C_GC_ROOT *)(root))->value), (x))
    485 
    486 #define CHICKEN_default_toplevel       ((void *)C_default_stub_toplevel)
    487 
    488 
    489 /* Language specifics: */
    490 #if defined(__GNUC__) || defined(__INTEL_COMPILER)
    491 # ifndef __cplusplus
    492 #  define C_cblock                ({
    493 #  define C_cblockend             })
    494 #  define C_noret                 __attribute__ ((noreturn))
    495 #  define C_noret_decl(name)
    496 #  define C_aligned               __attribute__ ((aligned))
     555/* Platform information */
     556#if defined(C_BIG_ENDIAN)
     557# define C_MACHINE_BYTE_ORDER "big-endian"
     558#elif defined(C_LITTLE_ENDIAN)
     559# define C_MACHINE_BYTE_ORDER "little-endian"
     560#endif
     561
     562#if defined(__alpha__)
     563# define C_MACHINE_TYPE "alpha"
     564#elif defined(__mips__)
     565# define C_MACHINE_TYPE "mips"
     566#elif defined(__hppa__)
     567# define C_MACHINE_TYPE "hppa"
     568#elif defined(__sparc_v9__) || defined(__sparcv9)
     569# define C_MACHINE_TYPE "ultrasparc"
     570#elif defined(__sparc__)
     571# define C_MACHINE_TYPE "sparc"
     572#elif defined(__powerpc64__)
     573# define C_MACHINE_TYPE "ppc64"
     574#elif defined(__ppc__) || defined(__powerpc__)
     575# define C_MACHINE_TYPE "ppc"
     576#elif defined(_M_IX86) || defined(__i386__)
     577# define C_MACHINE_TYPE "x86"
     578#elif defined(__ia64__)
     579# define C_MACHINE_TYPE "ia64"
     580#elif defined(__x86_64__)
     581# define C_MACHINE_TYPE "x86-64"
     582#elif defined(__arm__)
     583# define C_MACHINE_TYPE "arm"
     584#else
     585# define C_MACHINE_TYPE "unknown"
     586#endif
     587
     588#if defined(__CYGWIN__) || defined(__MINGW32__) || defined(_WIN32) || defined(__WINNT__)
     589# define C_SOFTWARE_TYPE "windows"
     590#elif defined(__unix__) || defined(C_XXXBSD)
     591# define C_SOFTWARE_TYPE "unix"
     592#elif defined(ECOS)
     593# define C_SOFTWARE_TYPE "ecos"
     594#else
     595# define C_SOFTWARE_TYPE "unknown"
     596#endif
     597
     598#if defined(__CYGWIN__)
     599# define C_BUILD_PLATFORM "cygwin"
     600#elif defined(_MSC_VER)
     601# define C_BUILD_PLATFORM "msvc"
     602#elif defined(__SUNPRO_C)
     603# define C_BUILD_PLATFORM "sun"
     604#elif defined(__MINGW32__)
     605# define C_BUILD_PLATFORM "mingw32"
     606#elif defined(__GNUC__)
     607# define C_BUILD_PLATFORM "gnu"
     608#elif defined(__MWERKS__)
     609# define C_BUILD_PLATFORM "metrowerks"
     610#elif defined(__INTEL_COMPILER)
     611# define C_BUILD_PLATFORM "intel"
     612#elif defined(__WATCOMC__)
     613# define C_BUILD_PLATFORM "watcom"
     614#else
     615# define C_BUILD_PLATFORM "unknown"
     616#endif
     617
     618#if defined(_MSC_VER)
     619# if defined(_DLL)
     620#   define C_RUNTIME_VERSION "dynamic"
     621# else
     622#   define C_RUNTIME_VERSION "static"
    497623# endif
    498 # ifdef __i386__
    499 #  define C_regparm               __attribute__ ((regparm(3)))
     624#else
     625# define C_RUNTIME_VERSION "unknown"
     626#endif
     627
     628#if defined(__linux__)
     629# define C_SOFTWARE_VERSION "linux"
     630#elif defined(__FreeBSD__)
     631# define C_SOFTWARE_VERSION "freebsd"
     632#elif defined(__NetBSD__)
     633# define C_SOFTWARE_VERSION "netbsd"
     634#elif defined(__OpenBSD__)
     635# define C_SOFTWARE_VERSION "openbsd"
     636#elif defined(C_MACOSX)
     637# define C_SOFTWARE_VERSION "macosx"
     638#elif defined(__hpux__)
     639# define C_SOFTWARE_VERSION "hpux"
     640#elif defined(__DragonFly__)
     641# define C_SOFTWARE_VERSION "dragonfly"
     642#elif defined(__sun__)
     643# if defined(__svr4__)
     644#   define C_SOFTWARE_VERSION "solaris"
     645# else
     646#   define C_SOFTWARE_VERSION "sunos"
    500647# endif
    501 #elif defined(_MSC_VER)
    502 # define C_fcall                  __fastcall
    503 #elif defined(__WATCOMC__)
    504 # define C_ccall                  __cdecl
    505 #endif
    506 
    507 #ifndef C_cblock
    508 # define C_cblock                 do{
    509 # define C_cblockend              }while(0)
    510 # define C_noret
    511 # define C_noret_decl(name)
    512 #endif
    513 
    514 #ifndef C_regparm
    515 # define C_regparm
    516 #endif
    517 
    518 #ifndef C_fcall
    519 # define C_fcall
    520 #endif
    521 
    522 #ifndef C_ccall
    523 # define C_ccall
    524 #endif
    525 
    526 #ifndef C_aligned
    527 # define C_aligned
    528 #endif
    529 
    530 #define C_c_regparm
     648#else
     649# define C_SOFTWARE_VERSION "unknown"
     650#endif
     651
    531652
    532653/* Types: */
     
    550671  C_word value;
    551672  struct C_gc_root_struct *next, *prev;
     673  int finalizable;
    552674} C_GC_ROOT;
    553675
     
    561683# define C_AMD64_ABI_WEIRDNESS      , ...
    562684#else
    563 # define C_AMD64_ABI_WEIRDNESS     
     685# define C_AMD64_ABI_WEIRDNESS
    564686#endif
    565687
     
    629751
    630752/* Macros: */
     753
     754#define CHICKEN_gc_root_ref(root)      (((C_GC_ROOT *)(root))->value)
     755#define CHICKEN_gc_root_set(root, x)   C_mutate(&((C_GC_ROOT *)(root))->value, (x))
     756
     757#define CHICKEN_global_ref(root)       C_u_i_car(((C_GC_ROOT *)(root))->value)
     758#define CHICKEN_global_set(root, x)    C_mutate(&C_u_i_car(((C_GC_ROOT *)(root))->value), (x))
     759
     760#define CHICKEN_default_toplevel       ((void *)C_default_stub_toplevel)
    631761
    632762#define C_align4(n)                (((n) + 3) & ~3)
     
    728858#define C_return(x)                return(x)
    729859
     860#ifdef C_DEFAULT_TARGET_STACK_SIZE
     861# define C_resize_stack(n)           C_do_resize_stack(C_DEFAULT_TARGET_STACK_SIZE)
     862#else
     863# define C_resize_stack(n)           C_do_resize_stack(n)
     864#endif
     865
    730866#define C_memcpy_slots(t, f, n)    C_memcpy((t), (f), (n) * sizeof(C_word))
    731867#define C_block_header(x)          (((C_SCHEME_BLOCK *)(x))->header)
     
    751887#define C_fix(n)                   (((C_word)(n) << C_FIXNUM_SHIFT) | C_FIXNUM_BIT)
    752888#define C_unfix(x)                 ((x) >> C_FIXNUM_SHIFT)
    753 #define C_make_character(c)        ((((c) & C_CHAR_BIT_MASK) << 8) | C_CHARACTER_BITS)
    754 #define C_character_code(x)        (((x) >> 8) & C_CHAR_BIT_MASK)
     889#define C_make_character(c)        ((((c) & C_CHAR_BIT_MASK) << C_CHAR_SHIFT) | C_CHARACTER_BITS)
     890#define C_character_code(x)        (((x) >> C_CHAR_SHIFT) & C_CHAR_BIT_MASK)
    755891#define C_flonum_magnitude(x)      (*((double *)(((C_SCHEME_BLOCK *)(x))->data)))
    756892#define C_c_string(x)              ((C_char *)(((C_SCHEME_BLOCK *)(x))->data))
     
    806942#define C_zero_length_p(x)        C_mk_bool(C_header_size(x) == 0)
    807943#define C_boundp(x)               C_mk_bool(((C_SCHEME_BLOCK *)(x))->data[ 0 ] != C_SCHEME_UNBOUND)
     944#define C_unboundvaluep(x)        C_mk_bool((x) == C_SCHEME_UNBOUND)
    808945#define C_blockp(x)               C_mk_bool(!C_immediatep(x))
    809946#define C_forwardedp(x)           C_mk_bool((C_block_header(x) & C_GC_FORWARDING_BIT) != 0)
     
    9141051#define C_update_pointer(p, ptr)        (C_set_block_item(ptr, 0, C_num_to_unsigned_int(p)), C_SCHEME_UNDEFINED)
    9151052#define C_copy_pointer(from, to)        (C_set_block_item(to, 0, C_u_i_car(from)), C_SCHEME_UNDEFINED)
     1053#define C_pointer_to_object(ptr)        ((C_word*)C_block_item(ptr, 0))
    9161054
    9171055#define C_direct_return(dk, x)          (C_kontinue(dk, x), C_SCHEME_UNDEFINED)
     
    9391077#define C_qfree(ptr)                    (C_free(C_c_pointer_nn(ptr)), C_SCHEME_UNDEFINED)
    9401078
    941 #if defined(__MWERKS__) && !defined(__INTEL__)
    942 # define C_tty_portp(p)                 C_SCHEME_FALSE
    943 #else
    944 # define C_tty_portp(p)                 C_mk_bool(isatty(fileno(C_port_file(p))))
    945 #endif
     1079#define C_tty_portp(p)                 C_mk_bool(isatty(fileno(C_port_file(p))))
    9461080
    9471081#define C_emit_eval_trace_info(x, y, z) C_emit_trace_info2("<eval>", x, y, z)
     
    9901124#define C_i_structurep(x, s)            C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_STRUCTURE_TYPE && C_block_item(x, 0) == (s))
    9911125
    992 #define C_u_i_char_alphabeticp(x)       C_mk_bool(C_isalpha(C_character_code(x)))
    993 #define C_u_i_char_numericp(x)          C_mk_bool(C_isdigit(C_character_code(x)))
    994 #define C_u_i_char_whitespacep(x)       C_mk_bool(C_isspace(C_character_code(x)))
    995 #define C_u_i_char_upper_casep(x)       C_mk_bool(C_isupper(C_character_code(x)))
    996 #define C_u_i_char_lower_casep(x)       C_mk_bool(C_islower(C_character_code(x)))
    997 
    998 #define C_u_i_char_upcase(x)            C_make_character(C_toupper(C_character_code(x)))
    999 #define C_u_i_char_downcase(x)          C_make_character(C_tolower(C_character_code(x)))
     1126#define C_u_i_char_alphabeticp(x)       C_mk_bool(C_isalpha(C_character_code(x) & 0xff))
     1127#define C_u_i_char_numericp(x)          C_mk_bool(C_isdigit(C_character_code(x) & 0xff))
     1128#define C_u_i_char_whitespacep(x)       C_mk_bool(C_isspace(C_character_code(x) & 0xff))
     1129#define C_u_i_char_upper_casep(x)       C_mk_bool(C_isupper(C_character_code(x) & 0xff))
     1130#define C_u_i_char_lower_casep(x)       C_mk_bool(C_islower(C_character_code(x) & 0xff))
     1131
     1132#define C_u_i_char_upcase(x)            C_make_character(C_toupper(C_character_code(x) & 0xff))
     1133#define C_u_i_char_downcase(x)          C_make_character(C_tolower(C_character_code(x) & 0xff))
    10001134
    10011135#define C_i_list_ref(lst, i)            C_i_car(C_i_list_tail(lst, i))
     
    11161250
    11171251C_varextern C_TLS time_t C_startup_time_seconds;
    1118 C_varextern C_TLS C_word 
     1252C_varextern C_TLS C_word
    11191253  *C_temporary_stack,
    11201254  *C_temporary_stack_bottom,
     
    11451279  C_trace_buffer_size,
    11461280  C_main_argc;
    1147 C_varextern C_TLS C_uword 
     1281C_varextern C_TLS C_uword
    11481282  C_heap_growth,
    11491283  C_heap_shrinkage;
    1150 C_varextern C_TLS char 
     1284C_varextern C_TLS char
    11511285  **C_main_argv,
    11521286  *C_dlerror;
     
    11661300C_fctexport C_word CHICKEN_continue(C_word k);
    11671301C_fctexport void *CHICKEN_new_gc_root();
     1302C_fctexport void *CHICKEN_new_finalizable_gc_root();
     1303C_fctexport void *CHICKEN_new_gc_root_2(int finalizable);
    11681304C_fctexport void CHICKEN_delete_gc_root(void *root);
    11691305C_fctexport void *CHICKEN_global_lookup(char *name);
     
    12631399C_fctexport C_word C_fcall C_retrieve2(C_word val, char *name) C_regparm;
    12641400C_fctexport void *C_fcall C_retrieve_proc(C_word closure) C_regparm;
     1401C_fctexport void *C_fcall C_retrieve_symbol_proc(C_word sym) C_regparm;
     1402C_fctexport void *C_fcall C_retrieve2_symbol_proc(C_word val, char *name) C_regparm;
    12651403C_fctexport C_word C_fcall C_permanentp(C_word x) C_regparm;
    12661404C_fctexport int C_in_stackp(C_word x) C_regparm;
     
    14451583C_fctexport C_word C_fcall C_i_member(C_word x, C_word lst) C_regparm;
    14461584C_fctexport C_word C_fcall C_i_length(C_word lst) C_regparm;
     1585C_fctexport C_word C_fcall C_u_i_length(C_word lst) C_regparm;
    14471586C_fctexport C_word C_fcall C_i_inexact_to_exact(C_word n) C_regparm;
    14481587C_fctexport C_word C_fcall C_i_check_closure_2(C_word x, C_word loc) C_regparm;
     
    14721611C_fctexport C_word C_fcall C_string_to_pbytevector(C_word x) C_regparm;
    14731612C_fctexport C_word C_fcall C_i_null_pointerp(C_word x) C_regparm;
    1474 C_fctexport C_word C_fcall C_i_fixnum_arithmetic_shift(C_word n, C_word c) C_regparm; 
     1613C_fctexport C_word C_fcall C_i_fixnum_arithmetic_shift(C_word n, C_word c) C_regparm;
    14751614C_fctexport C_word C_fcall C_i_locative_set(C_word loc, C_word x) C_regparm;
    14761615C_fctexport C_word C_fcall C_i_locative_to_object(C_word loc) C_regparm;
  • chicken/branches/prerelease/chicken.scm

    r11632 r13240  
    22;
    33; Copyright (c) 2000-2007, Felix L. Winkelmann
    4 ; Copyright (c) 2008, The Chicken Team
     4; Copyright (c) 2008-2009, The Chicken Team
    55; All rights reserved.
    66;
     
    2727
    2828(declare
    29   (uses srfi-1 match srfi-4 utils files support compiler optimizer driver platform backend)
    30   (run-time-macros) )
     29  (uses chicken-syntax srfi-1 srfi-4 utils files support compiler optimizer driver
     30        platform backend srfi-69)
     31  (run-time-macros) )                   ;*** later: compile-syntax
    3132
    3233
    3334(private compiler
    3435  compiler-arguments
    35   default-standard-bindings default-extended-bindings side-effecting-standard-bindings
    36   non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
    37   standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
     36  default-standard-bindings default-extended-bindings
     37  foldable-bindings
    3838  installation-home optimization-iterations process-command-line
    3939  file-io-only nonwinding-call/cc debugging
     
    4343  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
    4444  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
    45   rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants
     45  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    4646  broken-constant-nodes inline-substitutions-enabled compiler-warning
    4747  direct-call-ids foreign-type-table first-analysis
     
    6969
    7070(eval-when (load)
    71   (include "chicken-more-macros")
    72   (include "chicken-ffi-macros") )
     71  (include "chicken-ffi-syntax") )
    7372
    7473
     
    7776(define compiler-arguments
    7877  (append
    79    (cdr (argv))
    80    (remove (lambda (x) (string=? x "")) (string-split (or (getenv "CHICKEN_OPTIONS") ""))) ) )
     78   (remove
     79    (lambda (x) (string=? x ""))
     80    (string-split (or (getenv "CHICKEN_OPTIONS") "")))
     81   (cdr (argv))))
    8182
    8283
     
    115116                   [(0) #f]
    116117                   [(1)
    117                     (set! options (cons* 'optimize-leaf-routines options)) ]
     118                    (set! options (cons 'optimize-leaf-routines options)) ]
    118119                   [(2)
    119                     (set! options
    120                       (cons 'optimize-leaf-routines options) ) ]
     120                    (set! options (cons 'optimize-leaf-routines options)) ]
    121121                   [(3)
    122122                    (set! options
    123                       (cons* 'optimize-leaf-routines 'unsafe options) ) ]
     123                      (cons* 'optimize-leaf-routines 'local 'inline options) ) ]
     124                   [(4)
     125                    (set! options
     126                      (cons* 'optimize-leaf-routines 'local 'inline 'unsafe options) ) ]
    124127                   [else (compiler-warning 'usage "invalid optimization level ~S - ignored" (car rest))] )
    125128                 (loop (cdr rest)) ) ]
     
    136139                 (cons* 'fixnum-arithmetic 'disable-interrupts 'no-trace 'unsafe
    137140                        'optimize-leaf-routines 'block 'lambda-lift 'no-lambda-info
     141                        'inline
    138142                        options) )
    139143               (loop rest) ]
  • chicken/branches/prerelease/compiler.scm

    r11958 r13240  
    11;;;; compiler.scm - The CHICKEN Scheme compiler
    2 ;
    32;
    43;
     
    87;-----------------------------------------------------------------------------------------------------------
    98; Copyright (c) 2000-2007, Felix L. Winkelmann
    10 ; Copyright (c) 2008, The Chicken Team
     9; Copyright (c) 2008-2009, The Chicken Team
    1110; All rights reserved.
    1211;
     
    3635; - Declaration specifiers:
    3736;
    38 ; (unit <unitname>)
    39 ; (uses {<unitname>})
     37; ([not] extended-bindings {<name>})
     38; ([not] inline {<var>})
     39; ([not] interrupts-enabled)
     40; ([not] safe)
    4041; ([not] standard-bindings {<name>})
    4142; ([not] usual-integrations {<name>})
    42 ; ([not] extended-bindings (<name>})
     43; (local {<name> ...})
     44; ([not] inline-global {<name>})
    4345; ([number-type] <type>)
     46; (always-bound {<name>})
     47; (block)
     48; (block-global {<name>})
     49; (bound-to-procedure {<var>})
     50; (c-options {<opt>})
     51; (compile-syntax)
     52; (disable-interrupts)
     53; (disable-warning <class> ...)
     54; (emit-import-library {<module> | (<module> <filename>)})
     55; (export {<name>})
    4456; (fixnum-arithmetic)
    45 ; (unsafe)
    46 ; ([not] safe)
    47 ; ([not] interrupts-enabled)
     57; (foreign-declare {<string>})
     58; (hide {<name>})
     59; (inline-limit <limit>)
     60; (keep-shadowed-macros)
     61; (lambda-lift)
     62; (link-options {<opt>})
     63; (no-argc-checks)
    4864; (no-bound-checks)
    49 ; (no-argc-checks)
    5065; (no-procedure-checks)
    5166; (no-procedure-checks-for-usual-bindings)
    52 ; (block-global {<name>})
    53 ; (lambda-lift)
    54 ; (hide {<name>})
    55 ; (disable-interrupts)
    56 ; (disable-warning <class> ...)
    57 ; (always-bound {<name>})
    58 ; (foreign-declare {<string>})
    59 ; (block)
     67; (post-process <string> ...)
     68; (profile <symbol> ...)
     69; (safe-globals)
    6070; (separate)
    61 ; (run-time-macros)
    62 ; (export {<name>})
    63 ; (safe-globals)
    64 ; (custom-declare (<tag> <name> <filename> <arg> ...) <string> ...)
    65 ; (data <tag1> <exp1> ...)
    66 ; (post-process <string> ...)
    67 ; (emit-exports <string>)
    68 ; (keep-shadowed-macros)
    69 ; (import <symbol-or-string> ...)
     71; (unit <unitname>)
     72; (unsafe)
    7073; (unused <symbol> ...)
    71 ; (profile <symbol> ...)
     74; (uses {<unitname>})
    7275;
    7376;   <type> = fixnum | generic
     77
     78; - Global symbol properties:
    7479;
     80;   ##compiler#always-bound -> BOOL
     81;   ##compiler#always-bound-to-procedure -> BOOL
     82;   ##compiler#local -> BOOL
     83;   ##compiler#visibility -> #f | 'hidden | 'exported
     84;   ##compiler#constant -> BOOL
     85;   ##compiler#intrinsic -> #f | 'standard | 'extended
     86;   ##compiler#inline -> 'no | 'yes
     87;   ##compiler#inline-global -> 'yes | 'no | <node>
     88;   ##compiler#profile -> BOOL
     89;   ##compiler#unused -> BOOL
     90;   ##compiler#foldable -> BOOL
     91
    7592; - Source language:
    7693;
    7794; <variable>
    7895; <constant>
    79 ; (##core#declare {(quote <spec>)})
     96; (##core#declare {<spec>})
    8097; (##core#immutable <exp>)
    8198; (##core#global-ref <variable>)
    8299; (quote <exp>)
    83100; (if <exp> <exp> [<exp>])
    84 ; (let ({(<variable> <exp>)}) <body>)
    85 ; (##core#let-location (quote <symbol>) (quote <type>) [<init>] <exp>)
    86 ; (lambda <variable> <body>)
    87 ; (lambda ({<variable>}+ [. <variable>]) <body>)
    88 ; (set! <variable> <exp>)
    89 ; (##core#set! <variable> <exp>)
     101; ([##core#]let <variable> ({(<variable> <exp>)}) <body>)
     102; ([##core#]let ({(<variable> <exp>)}) <body>)
     103; ([##core#]letrec ({(<variable> <exp>)}) <body>)
     104; (##core#let-location <symbol> <type> [<init>] <exp>)
     105; ([##core#]lambda <variable> <body>)
     106; ([##core#]lambda ({<variable>}+ [. <variable>]) <body>)
     107; ([##core#]set! <variable> <exp>)
    90108; (##core#named-lambda <name> <llist> <body>)
    91109; (##core#loop-lambda <llist> <body>)
     
    102120; (##core#elaborationtimetoo <exp>)
    103121; (##core#elaborationtimeonly <exp>)
    104 ; (##core#define-foreign-variable (quote <symbol>) (quote <type>) [(quote <string>)])
    105 ; (##core#define-foreign-type (quote <symbol>) (quote <type>) [<proc1> [<proc2>]])
    106 ; (##core#foreign-lambda (quote <type>) (quote <string>) {(quote <type>)})
    107 ; (##core#foreign-lambda* (quote <type>) (quote ({(<type> <var>)})) {(quote <string>)})
    108 ; (##core#foreign-callback-lambda (quote <type>) (quote <string>) {(quote <type>)})
    109 ; (##core#foreign-callback-lambda* (quote <type>) (quote ({(<type> <var>)})) {(quote <string>)})
    110 ; (##core#foreign-primitive (quote <type>) (quote ({(<type> <var>)})) {(quote <string>)})
    111 ; (##core#define-inline (quote <name>) <exp>)
    112 ; (##core#define-constant (quote <name>) <exp>)
    113 ; (##core#foreign-callback-wrapper (quote <name>) (quote <qualifiers>) (quote <type>) (quote {<type>}) <exp>)
     122; (define-foreign-variable <symbol> <type> [<string>])
     123; (define-foreign-type <symbol> <type> [<proc1> [<proc2>]])
     124; (foreign-lambda <type> <string> {<type>})
     125; (foreign-lambda* <type> ({(<type> <var>)})) {<string>})
     126; (foreign-safe-lambda <type> <string> {<type>})
     127; (foreign-safe-lambda* <type> ({(<type> <var>)})) {<string>})
     128; (foreign-primitive <type> ({(<type> <var>)}) {<string>})
     129; (##core#define-inline <name> <exp>)
     130; (define-constant <name> <exp>)
     131; (##core#foreign-callback-wrapper '<name> <qualifiers> '<type> '({<type>}) <exp>)
    114132; (##core#define-external-variable (quote <name>) (quote <type>) (quote <bool>))
    115133; (##core#check <exp>)
    116134; (##core#require-for-syntax <exp> ...)
    117 ; (##core#require-extension '<id> ...)
     135; (##core#require-extension (<id> ...) <bool>)
    118136; (##core#app <exp> {<exp>})
     137; (##coresyntax <exp>)
    119138; (<exp> {<exp>})
    120 ;
     139; (define-syntax <symbol> <expr>)
     140; (define-syntax (<symbol> . <llist>) <expr> ...)
     141; (define-compiled-syntax <symbol> <expr>)
     142; (define-compiled-syntax (<symbol> . <llist>) <expr> ...)
     143; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
     144; (##core#define-rewrite-rule <symbol> <expr>)
     145
    121146; - Core language:
    122147;
     
    144169; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
    145170; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
    146 ;
     171
    147172; - Closure converted/prepared language:
    148173;
     
    167192; [##core#call {<safe-flag> [<debug-info> [<call-id> <customizable-flag>]]} <exp-f> <exp>...]
    168193; [##core#callunit {<unitname>} <exp>...]
     194; [##core#cond <exp> <exp> <exp>]
    169195; [##core#local {<index>}]
    170196; [##core#setlocal {<index>} <exp>]
    171197; [##core#global {<literal> <safe-flag> <block-mode> [<name>]}]
    172 ; [##core#setglobal {<literal> <block-mode>} <exp>]
    173 ; [##core#setglobal_i {<literal> <block-mode>} <exp>]
     198; [##core#setglobal {<literal> <block-mode> <name>} <exp>]
     199; [##core#setglobal_i {<literal> <block-mode> <name>} <exp>]
    174200; [##core#literal {<literal>}]
    175201; [##core#immediate {<type> [<immediate>]}]     - type: bool/fix/nil/char
     
    178204; [##core#return <exp>]
    179205; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
    180 ;
    181 ;
     206
    182207; Analysis database entries:
    183208;
     
    188213;   call-sites -> ((<lambda-id> <node>) ...) Known call-nodes of a named procedure
    189214;   home -> <lambda-id>                      Procedure which introduces this variable
    190 ;   unknown -> <boolean>                     If true: variable can not have a known value
     215;   unknown -> <boolean>                     If true: variable cannot have a known value
    191216;   assigned -> <boolean>                    If true: variable is assigned somewhere
    192217;   assigned-locally -> <boolean>            If true: variable has been assigned inside user lambda
    193218;   undefined -> <boolean>                   If true: variable is unknown yet but can be known later
    194219;   value -> <node>                          Variable has a known value
     220;   local-value -> <node>                    Variable is declared local and has value
    195221;   potential-value -> <node>                Global variable was assigned this value
    196222;   references -> (<node> ...)               Nodes that are accesses of this variable (##core#variable nodes)
    197 ;   side-effecting -> <boolean>              If true: variable names side-effecting standard-binding
    198 ;   foldable -> <boolean>                    If true: variable names foldable standard-binding
    199223;   boxed -> <boolean>                       If true: variable has to be boxed after closure-conversion
    200224;   contractable -> <boolean>                If true: variable names contractable procedure
     
    210234;   o-r/access-count -> <n>                  Contains number of references as arguments of optimizable rest operators
    211235;   constant -> <boolean>                    If true: variable has fixed value
     236;   hidden-refs -> <boolean>                 If true: procedure that refers to hidden global variables
    212237;
    213238; <lambda-id>:
     
    228253 (disable-warning var) )
    229254
    230 #>
    231 #ifndef C_INSTALL_SHARE_HOME
    232 # define C_INSTALL_SHARE_HOME NULL
    233 #endif
    234 
    235 #ifndef C_DEFAULT_TARGET_STACK_SIZE
    236 # define C_DEFAULT_TARGET_STACK_SIZE 0
    237 #endif
    238 
    239 #ifndef C_DEFAULT_TARGET_HEAP_SIZE
    240 # define C_DEFAULT_TARGET_HEAP_SIZE 0
    241 #endif
    242 <#
    243 
    244255
    245256(private compiler
    246   compiler-arguments process-command-line explicit-use-flag inline-list not-inline-list
    247   default-standard-bindings default-extended-bindings side-effecting-standard-bindings
    248   non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings
    249   standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
     257  compiler-arguments process-command-line explicit-use-flag
     258  default-standard-bindings default-extended-bindings
     259  foldable-bindings llist-length
    250260  installation-home decompose-lambda-list external-to-pointer defconstant-bindings constant-declarations
    251261  copy-node! error-is-extended-binding toplevel-scope toplevel-lambda-id
    252   unit-name insert-timer-checks used-units external-variables require-imports-flag custom-declare-alist
     262  unit-name insert-timer-checks used-units external-variables require-imports-flag
    253263  profile-info-vector-name finish-foreign-result pending-canonicalizations
    254264  foreign-declarations emit-trace-info block-compilation line-number-database-size
    255   always-bound-to-procedure block-globals make-block-variable-literal block-variable-literal? block-variable-literal-name
    256   target-heap-size target-stack-size valid-c-identifier? profiled-procedures
     265  make-block-variable-literal block-variable-literal? block-variable-literal-name
     266  target-heap-size target-stack-size valid-c-identifier? profiled-procedures standalone-executable
    257267  target-initial-heap-size internal-bindings source-filename dump-nodes source-info->string
    258268  default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size
    259269  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
    260   rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used mutable-constants
     270  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    261271  broken-constant-nodes inline-substitutions-enabled loop-lambda-names expand-profile-lambda
    262272  profile-lambda-list profile-lambda-index emit-profile expand-profile-lambda
    263273  direct-call-ids foreign-type-table first-analysis callback-names disabled-warnings
    264274  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database! scan-toplevel-assignments
    265   compiler-warning import-table use-import-table compiler-macro-table compiler-macros-enabled
     275  compiler-warning variable-visible? hide-variable mark-variable inline-locally
    266276  perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization!
    267277  reorganize-recursive-bindings substitution-table simplify-named-call inline-max-size
    268278  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub
    269279  expand-foreign-lambda* data-declarations emit-control-file-item expand-foreign-primitive
    270   process-declaration external-protos-first basic-literal?
     280  process-declaration external-protos-first basic-literal? rewrite
    271281  transform-direct-lambdas! expand-foreign-callback-lambda* debugging emit-unsafe-marker
    272282  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
     
    277287  simple-lambda-node? compute-database-statistics print-program-statistics output gen gen-list
    278288  pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
    279   topological-sort print-version print-usage initialize-analysis-database export-list csc-control-file
    280   estimate-foreign-result-location-size unused-variables
     289  topological-sort print-version print-usage initialize-analysis-database csc-control-file
     290  estimate-foreign-result-location-size inline-output-file
    281291  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
    282292  units-used-by-default words-per-flonum disable-stack-overflow-checking
     
    284294  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
    285295  make-random-name final-foreign-type real-name-table real-name set-real-name! safe-globals-flag
    286   location-pointer-map literal-rewrite-hook
    287   lookup-exports-file undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info
     296  location-pointer-map literal-rewrite-hook inline-globally
     297  local-definitions export-variable variable-mark intrinsic?
     298  undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info
    288299  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
    289   process-custom-declaration do-lambda-lifting file-requirements emit-closure-info export-file-name
     300  do-lambda-lifting file-requirements emit-closure-info
    290301  foreign-argument-conversion foreign-result-conversion foreign-type-convert-argument foreign-type-convert-result
    291   big-fixnum?)
    292 
    293 (eval-when (compile eval)
    294   (match-error-control #:fail) )
     302  big-fixnum? import-libraries unlikely-variables)
    295303
    296304
     
    309317  (define-foreign-variable default-target-heap-size int "C_DEFAULT_TARGET_HEAP_SIZE")
    310318  (define-foreign-variable default-target-stack-size int "C_DEFAULT_TARGET_STACK_SIZE") )
    311 
    312 (define user-options-pass (make-parameter #f))
    313 (define user-read-pass (make-parameter #f))
    314 (define user-preprocessor-pass (make-parameter #f))
    315 (define user-pass (make-parameter #f))
    316 (define user-pass-2 (make-parameter #f))
    317 (define user-post-analysis-pass (make-parameter #f))
    318319
    319320(define-constant foreign-type-table-size 301)
     
    324325(define-constant file-requirements-size 301)
    325326(define-constant real-name-table-size 997)
    326 (define-constant import-table-size 997)
    327 (define-constant default-inline-max-size 10)
     327(define-constant default-inline-max-size 20)
    328328
    329329
     
    337337(define used-units '())
    338338(define unsafe #f)
    339 (define always-bound '())
    340 (define always-bound-to-procedure '())
    341339(define foreign-declarations '())
    342340(define emit-trace-info #f)
     
    351349(define no-argc-checks #f)
    352350(define no-procedure-checks #f)
    353 (define block-globals '())
    354351(define source-filename #f)
    355 (define export-list #f)
    356352(define safe-globals-flag #f)
    357353(define explicit-use-flag #f)
     
    361357(define external-protos-first #f)
    362358(define do-lambda-lifting #f)
    363 (define inline-max-size -1)
     359(define inline-max-size default-inline-max-size)
    364360(define emit-closure-info #t)
    365 (define export-file-name #f)
    366 (define import-table #f)
    367 (define use-import-table #f)
    368361(define undefine-shadowed-macros #t)
    369362(define constant-declarations '())
    370363(define profiled-procedures #f)
     364(define import-libraries '())
     365(define standalone-executable #t)
     366(define local-definitions #f)
     367(define inline-globally #f)
     368(define inline-locally #f)
     369(define inline-output-file #f)
    371370
    372371
     
    389388(define constant-table #f)
    390389(define constants-used #f)
    391 (define mutable-constants '())
    392390(define broken-constant-nodes '())
    393391(define inline-substitutions-enabled #f)
     
    412410(define toplevel-scope #t)
    413411(define toplevel-lambda-id #f)
    414 (define custom-declare-alist '())
    415412(define csc-control-file #f)
    416413(define data-declarations '())
    417 (define inline-list '())
    418 (define not-inline-list '())
    419414(define file-requirements #f)
    420415(define postponed-initforms '())
    421 (define unused-variables '())
    422 (define compiler-macro-table #f)
    423 (define compiler-macros-enabled #t)
    424416(define literal-rewrite-hook #f)
    425417
     
    442434      (vector-fill! file-requirements '())
    443435      (set! file-requirements (make-vector file-requirements-size '())) )
    444   (if import-table
    445       (vector-fill! import-table '())
    446       (set! import-table (make-vector import-table-size '())) )
    447436  (if foreign-type-table
    448437      (vector-fill! foreign-type-table '())
     
    454443(define (canonicalize-expression exp)
    455444
    456   (define (resolve v ae)
    457     (cond [(assq v ae) => cdr]
    458           [else v] ) )
     445  (define (find-id id se)               ; ignores macro bindings
     446    (cond ((null? se) #f)
     447          ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
     448          (else (find-id id (cdr se)))))
     449
     450  (define (lookup id se)
     451    (cond ((find-id id se))
     452          ((##sys#get id '##core#macro-alias))
     453          (else id)))
     454
     455  (define (macro-alias var se)
     456    (let ((alias (gensym var)))
     457      (##sys#put! alias '##core#macro-alias (lookup var se))
     458      alias) )
    459459
    460460  (define (set-real-names! as ns)
     
    466466      (get-output-string out) ) )
    467467
    468   (define unquotify
    469     (match-lambda
    470       [('quote x) x]
    471       [x x] ) )
    472 
    473   (define (resolve-atom x ae me dest)
    474     (cond [(and constants-used (##sys#hash-table-ref constant-table x))
    475            => (lambda (val) (walk (car val) ae me dest)) ]
    476           [(and inline-table-used (##sys#hash-table-ref inline-table x))
    477            => (lambda (val)
    478                 (walk val ae me dest)) ]
    479           [(assq x foreign-variables)
    480            => (lambda (fv)
    481                 (let* ([t (second fv)]
    482                        [ft (final-foreign-type t)]
    483                        [body `(##core#inline_ref (,(third fv) ,t))] )
    484                   (foreign-type-convert-result
    485                    (finish-foreign-result ft body)
    486                    t) ) ) ]
    487           [(assq x location-pointer-map)
    488            => (lambda (a)
    489                 (let* ([t (third a)]
    490                        [ft (final-foreign-type t)]
    491                        [body `(##core#inline_loc_ref (,t) ,(second a))] )
    492                   (foreign-type-convert-result
    493                    (finish-foreign-result ft body)
    494                    t) ) ) ]
    495           [else #f] ) )
    496 
    497   (define (walk-literal x ae me dest)
    498     (if literal-rewrite-hook
    499         (literal-rewrite-hook x (cut walk <> ae me dest))
    500         `(quote ,x) ) )
    501 
    502   (define (walk x ae me dest)
     468  (define (unquotify x se)
     469    (if (and (list? x)
     470             (= 2 (length x))
     471             (symbol? (car x))
     472             (eq? 'quote (lookup (car x) se)))
     473        (cadr x)
     474        x) )
     475
     476  (define (resolve-variable x0 se dest)
     477    (let ((x (lookup x0 se)))
     478      (cond ((not (symbol? x)) x0)      ; syntax?
     479            [(and constants-used (##sys#hash-table-ref constant-table x))
     480             => (lambda (val) (walk (car val) se dest)) ]
     481            [(and inline-table-used (##sys#hash-table-ref inline-table x))
     482             => (lambda (val) (walk val se dest)) ]
     483            [(assq x foreign-variables)
     484             => (lambda (fv)
     485                  (let* ([t (second fv)]
     486                         [ft (final-foreign-type t)]
     487                         [body `(##core#inline_ref (,(third fv) ,t))] )
     488                    (walk
     489                     (foreign-type-convert-result
     490                      (finish-foreign-result ft body)
     491                      t)
     492                     se dest)))]
     493            [(assq x location-pointer-map)
     494             => (lambda (a)
     495                  (let* ([t (third a)]
     496                         [ft (final-foreign-type t)]
     497                         [body `(##core#inline_loc_ref (,t) ,(second a))] )
     498                    (walk
     499                     (foreign-type-convert-result
     500                      (finish-foreign-result ft body)
     501                      t)
     502                     se dest))) ]
     503            ((not (assq x0 se)) (##sys#alias-global-hook x #f)) ; only if global
     504            ((##sys#get x '##core#primitive))
     505            (else x))))
     506 
     507  (define (eval/meta form)
     508    (parameterize ((##sys#current-module #f)
     509                   (##sys#macro-environment (##sys#meta-macro-environment)))
     510      ((##sys#compile-to-closure
     511        form
     512        '()
     513        (##sys#current-meta-environment))
     514       '() ) ))
     515
     516  (define (walk x se dest)
    503517    (cond ((symbol? x)
    504            (cond ((keyword? x) (walk-literal x ae me dest))
    505                  ((assq x ae) =>
    506                   (lambda (a)
    507                     (let ((alias (cdr a)))
    508                       (or (resolve-atom alias ae me dest)
    509                           alias) ) ) )
    510                  ((resolve-atom x ae me dest))
    511                  (else (##sys#alias-global-hook x))) )
    512           ((and (not-pair? x) (constant? x))
    513            (walk-literal x ae me dest) )
    514           ((not-pair? x) (syntax-error "illegal atomic form" x))
     518           (cond ((keyword? x) `(quote ,x))
     519                 ((memq x unlikely-variables)
     520                  (compiler-warning
     521                   'var
     522                   "reference to variable `~s' possibly unintended" x) ))
     523           (resolve-variable x se dest))
     524          ((not-pair? x)
     525           (if (constant? x)
     526               `(quote ,x)
     527               (syntax-error "illegal atomic form" x)))
    515528          ((symbol? (car x))
    516            (let* ([head (car x)]
    517                   [rest (cdr x)]
    518                   [ln (get-line x)]
    519                   [name (resolve head ae)] )
     529           (let ([ln (get-line x)])
    520530             (emit-syntax-trace-info x #f)
    521531             (unless (proper-list? x)
     
    524534                   (syntax-error "malformed expression" x)))
    525535             (set! ##sys#syntax-error-culprit x)
    526              (let* ([x2 (cons name rest)]
    527                     [xexpanded (##sys#macroexpand-1-local x2 me)] )
    528                (cond [(not (eq? x2 xexpanded))
    529                       (when ln (update-line-number-database! xexpanded ln))
    530                       (walk xexpanded ae me dest) ]
     536             (let* ((name0 (lookup (car x) se))
     537                    (name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
     538                    (xexpanded (##sys#expand x se)))
     539               (cond ((not (eq? x xexpanded))
     540                      (walk xexpanded se dest))
     541                     
    531542                     [(and inline-table-used (##sys#hash-table-ref inline-table name))
    532543                      => (lambda (val)
    533                            (walk (cons val (cdr x)) ae me dest)) ]
     544                           (walk (cons val (cdr x)) se dest)) ]
     545                     
    534546                     [else
     547                      (when ln (update-line-number-database! xexpanded ln))
    535548                      (case name
    536 
     549                       
    537550                        ((if)
    538                          (##sys#check-syntax 'if x '(if _ _ . #(_)))
    539                          `(if ,(walk (cadr x) ae me #f)
    540                               ,(walk (caddr x) ae me #f)
    541                               ,(if (null? (cdddr x))
    542                                    '(##core#undefined)
    543                                    (walk (cadddr x) ae me #f) ) ) )
    544 
    545                         ((quote)
    546                          (##sys#check-syntax 'quote x '(quote _))
    547                          (walk-literal (cadr x) ae me dest) )
     551                         (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
     552                         `(if
     553                           ,(walk (cadr x) se #f)
     554                           ,(walk (caddr x) se #f)
     555                           ,(if (null? (cdddr x))
     556                                '(##core#undefined)
     557                                (walk (cadddr x) se #f) ) ) )
     558
     559                        ((quote syntax)
     560                         (##sys#check-syntax name x '(_ _) #f se)
     561                         `(quote ,(##sys#strip-syntax (cadr x))))
    548562
    549563                        ((##core#check)
    550564                         (if unsafe
    551565                             ''#t
    552                              (walk (cadr x) ae me dest) ) )
     566                             (walk (cadr x) se dest) ) )
    553567
    554568                        ((##core#immutable)
     
    558572                                  (let ([var (gensym 'c)])
    559573                                    (set! immutable-constants (alist-cons c var immutable-constants))
    560                                     (set! always-bound (cons var always-bound))
    561                                     (set! block-globals (cons var block-globals))
     574                                    (mark-variable var '##compiler#always-bound)
     575                                    (hide-variable var)
    562576                                    var) ] ) ) )
    563577
    564                         ((##core#undefined ##core#callunit ##core#primitive ##core#inline_ref
    565                                            ##core#inline_loc_ref) x)
     578                        ((##core#undefined ##core#callunit ##core#primitive) x)
     579                       
     580                        ((##core#inline_ref)
     581                         `(##core#inline_ref
     582                           (,(caadr x) ,(##sys#strip-syntax (cadadr x)))))
     583
     584                        ((##core#inline_loc_ref)
     585                         `(##core#inline_loc_ref
     586                           ,(##sys#strip-syntax (cadr x))
     587                           ,(walk (caddr x) se dest)))
    566588
    567589                        ((##core#require-for-syntax)
     
    569591                           (apply ##sys#require ids)
    570592                           (##sys#hash-table-update!
    571                             file-requirements 'syntax-requirements (cut lset-union eq? <> ids)
     593                            file-requirements 'dynamic/syntax
     594                            (cut lset-union eq? <> ids)
    572595                            (lambda () ids) )
    573596                           '(##core#undefined) ) )
    574597
    575598                        ((##core#require-extension)
    576                          (walk
    577                           (let loop ([ids (cdr x)])
    578                             (if (null? ids)
    579                                 '(##core#undefined)
    580                                 (let ([id (cadar ids)])
    581                                   (let-values ([(exp f) (##sys#do-the-right-thing id #t)])
    582                                     (if (not (or f
    583                                                  (and (symbol? id)
    584                                                      (or (feature? id)
    585                                                          (##sys#find-extension
    586                                                           (##sys#canonicalize-extension-path
    587                                                            id 'require-extension) #f)) ) ) )
     599                         (let ((imp? (caddr x)))
     600                           (walk
     601                            (let loop ([ids (cadr x)])
     602                              (if (null? ids)
     603                                  '(##core#undefined)
     604                                  (let ([id (car ids)])
     605                                    (let-values ([(exp f) (##sys#do-the-right-thing id #t imp?)])
     606                                      (unless (or f
     607                                                  (and (symbol? id)
     608                                                       (or (feature? id)
     609                                                           (##sys#find-extension
     610                                                            (##sys#canonicalize-extension-path
     611                                                             id 'require-extension) #f)) ) )
    588612                                        (compiler-warning
    589                                          'ext "extension `~A' is currently not installed" id)
    590                                         (unless (and-let* (use-import-table
    591                                                            ((symbol? id))
    592                                                            (info (##sys#extension-information id #f))
    593                                                            (exps (assq 'exports info)) )
    594                                                   (for-each
    595                                                    (cut ##sys#hash-table-set! import-table <> id)
    596                                                    (cdr exps) )
    597                                                   #t)
    598                                           (lookup-exports-file id) ) )
    599                                     `(begin ,exp ,(loop (cdr ids))) ) ) ) )
    600                           ae me dest) )
    601 
    602                         ((let)
    603                          (##sys#check-syntax 'let x '(let #((variable _) 0) . #(_ 1)))
    604                          (let* ([bindings (cadr x)]
    605                                 [vars (unzip1 bindings)]
    606                                 [aliases (map gensym vars)]
    607                                 (ae2 (append (map cons vars aliases) ae)) )
     613                                         'ext "extension `~A' is currently not installed" id))
     614                                      `(begin ,exp ,(loop (cdr ids))) ) ) ) )
     615                            se dest) ) )
     616
     617                        ((let ##core#let)
     618                         (##sys#check-syntax 'let x '(_ #((variable _) 0) . #(_ 1)) #f se)
     619                         (let* ((bindings (cadr x))
     620                                (vars (unzip1 bindings))
     621                                (aliases (map gensym vars))
     622                                (se2 (append (map cons vars aliases) se)) )
    608623                           (set-real-names! aliases vars)
    609                            `(let ,(map (lambda (alias b)
    610                                          (list alias (walk (cadr b) ae me (car b))) )
    611                                        aliases bindings)
    612                               ,(walk (##sys#canonicalize-body (cddr x) (cut assq <> ae2) me dest)
    613                                      ae2
    614                                      me dest) ) ) )
    615 
    616                         ((lambda ##core#internal-lambda)
    617                          (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)))
    618                          (let ([llist (cadr x)]
    619                                [obody (cddr x)] )
     624                           `(let
     625                             ,(map (lambda (alias b)
     626                                     (list alias (walk (cadr b) se (car b))) )
     627                                   aliases bindings)
     628                             ,(walk (##sys#canonicalize-body (cddr x) se2)
     629                                    se2 dest) ) ) )
     630
     631                         ((letrec ##core#letrec)
     632                          (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
     633                          (let ((bindings (cadr x))
     634                                (body (cddr x)) )
     635                            (walk
     636                             `(##core#let
     637                               ,(##sys#map (lambda (b)
     638                                             (list (car b) '(##core#undefined)))
     639                                           bindings)
     640                               ,@(##sys#map (lambda (b)
     641                                              `(##core#set! ,(car b) ,(cadr b)))
     642                                            bindings)
     643                               (##core#let () ,@body) )
     644                             se dest)))
     645
     646                        ((lambda ##core#lambda)
     647                         (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
     648                         (let ((llist (cadr x))
     649                               (obody (cddr x)) )
    620650                           (when (##sys#extended-lambda-list? llist)
    621651                             (set!-values
    622652                              (llist obody)
    623653                              (##sys#expand-extended-lambda-list
    624                                llist obody
    625                                ##sys#error) ) )
     654                               llist obody ##sys#error se) ) )
    626655                           (decompose-lambda-list
    627656                            llist
    628657                            (lambda (vars argc rest)
    629658                              (let* ((aliases (map gensym vars))
    630                                      (ae2 (append (map cons vars aliases) ae))
    631                                      (body0 (##sys#canonicalize-body obody (cut assq <> ae2) me dest))
    632                                      (body (walk body0 ae2 me #f))
     659                                     (se2 (append (map cons vars aliases) se))
     660                                     (body0 (##sys#canonicalize-body obody se2))
     661                                     (body (walk body0 se2 #f))
    633662                                     (llist2
    634663                                      (build-lambda-list
     
    638667                                (set-real-names! aliases vars)
    639668                                (cond ((or (not dest)
    640                                            (not (eq? dest (resolve dest ae)))) ; global?
     669                                           (assq dest se)) ; not global?
    641670                                       l)
    642                                       ((and (eq? 'lambda name)
    643                                             emit-profile
    644                                             (or (not profiled-procedures)
    645                                                 (memq dest profiled-procedures)))
     671                                      ((and (eq? 'lambda (or (lookup name se) name))
     672                                            emit-profile
     673                                            (or (eq? profiled-procedures 'all)
     674                                                (and
     675                                                 (eq? profiled-procedures 'some)
     676                                                 (variable-mark dest '##compiler#profile))))
    646677                                       (expand-profile-lambda dest llist2 body) )
    647678                                      (else
    648                                        (match body0
    649                                          (('begin (or (? string? doc) ('quote doc)) _ . more)
    650                                           (process-lambda-documentation
    651                                            dest doc l) )
    652                                          (_ l) ) ) ) ) ) ) ) )
    653 
    654                         ((##core#named-lambda)
    655                          (walk `(lambda ,@(cddr x)) ae me (cadr x)) )
    656 
    657                         ((##core#loop-lambda)
    658                          (let* ([vars (cadr x)]
    659                                 [obody (cddr x)]
    660                                 [aliases (map gensym vars)]
    661                                 (ae2 (append (map cons vars aliases) ae))
    662                                 [body
    663                                  (walk
    664                                   (##sys#canonicalize-body obody (cut assq <> ae2) me dest)
    665                                   ae2
    666                                   me #f) ] )
    667                            (set-real-names! aliases vars)
    668                            `(lambda ,aliases ,body) ) )
     679                                       (if (and (> (length body0) 1)
     680                                                (symbol? (car body0))
     681                                                (eq? 'begin (or (lookup (car body0) se) (car body0)))
     682                                                (let ((x1 (cadr body0)))
     683                                                  (or (string? x1)
     684                                                      (and (list? x1)
     685                                                           (= (length x1) 2)
     686                                                           (symbol? (car x1))
     687                                                           (eq? 'quote (or (lookup (car x1) se) (car x1)))))))
     688                                           (process-lambda-documentation
     689                                            dest (cadr body) l)
     690                                           l))))))))
     691                       
     692                        ((let-syntax)
     693                         (##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se)
     694                         (let ((se2 (append
     695                                     (map (lambda (b)
     696                                            (list
     697                                             (car b)
     698                                             se
     699                                             (##sys#er-transformer
     700                                              (eval/meta (cadr b)))))
     701                                          (cadr x) )
     702                                     se) ) )
     703                           (walk
     704                            (##sys#canonicalize-body (cddr x) se2)
     705                            se2
     706                            dest) ) )
     707                               
     708                       ((letrec-syntax)
     709                        (##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se)
     710                        (let* ((ms (map (lambda (b)
     711                                          (list
     712                                           (car b)
     713                                           #f
     714                                           (##sys#er-transformer
     715                                            (eval/meta (cadr b)))))
     716                                        (cadr x) ) )
     717                               (se2 (append ms se)) )
     718                          (for-each
     719                           (lambda (sb)
     720                             (set-car! (cdr sb) se2) )
     721                           ms)
     722                          (walk
     723                           (##sys#canonicalize-body (cddr x) se2)
     724                           se2 dest)))
     725                               
     726                       ((define-syntax)
     727                        (##sys#check-syntax
     728                         'define-syntax x
     729                         (if (pair? (cadr x))
     730                             '(_ (variable . lambda-list) . #(_ 1))
     731                             '(_ variable _) )
     732                         #f se)
     733                        (let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
     734                               (body (if (pair? (cadr x))
     735                                         `(,(macro-alias 'lambda se) ,(cdadr x) ,@(cddr x))
     736                                         (caddr x)))
     737                               (name (lookup var se)))
     738                          (##sys#register-syntax-export name (##sys#current-module) body)
     739                          (##sys#extend-macro-environment
     740                           name
     741                           (##sys#current-environment)
     742                           (##sys#er-transformer (eval/meta body)))
     743                          (walk
     744                           (if ##sys#enable-runtime-macros
     745                               `(##sys#extend-macro-environment
     746                                 ',var
     747                                 (##sys#current-environment)
     748                                 (##sys#er-transformer ,body)) ;*** possibly wrong se?
     749                               '(##core#undefined) )
     750                           se dest)) )
     751
     752                       ((define-compiled-syntax)
     753                        (##sys#check-syntax
     754                         'define-compiled-syntax x
     755                         (if (pair? (cadr x))
     756                             '(_ (variable . lambda-list) . #(_ 1))
     757                             '(_ variable _) )
     758                         #f se)
     759                        (let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
     760                               (body (if (pair? (cadr x))
     761                                         `(,(macro-alias 'lambda se) ,(cdadr x) ,@(cddr x))
     762                                         (caddr x)))
     763                               (name (lookup var se)))
     764                          (##sys#extend-macro-environment
     765                           name
     766                           (##sys#current-environment)
     767                           (##sys#er-transformer (eval/meta body)))
     768                          (##sys#register-syntax-export name (##sys#current-module) body)
     769                          (walk
     770                           `(##sys#extend-macro-environment
     771                             ',var
     772                             (##sys#current-environment)
     773                             (##sys#er-transformer
     774                              ,body)) ;*** possibly wrong se?
     775                           se dest)))
     776
     777                       ((##core#define-rewrite-rule)
     778                        (let ((name (##sys#strip-syntax (cadr x) se #t))
     779                              (re (caddr x)))
     780                          (##sys#put! name '##compiler#intrinsic 'rewrite)
     781                          (rewrite
     782                           name 8
     783                           (eval/meta re))
     784                          '(##core#undefined)))
     785
     786                       ((##core#module)
     787                        (let* ((name (lookup (cadr x) se))
     788                               (exports
     789                                (or (eq? #t (caddr x))
     790                                    (map (lambda (exp)
     791                                           (cond ((symbol? exp) exp)
     792                                                 ((and (pair? exp)
     793                                                       (let loop ((exp exp))
     794                                                         (or (null? exp)
     795                                                             (and (symbol? (car exp))
     796                                                                  (loop (cdr exp))))))
     797                                                  exp)
     798                                                 (else
     799                                                  (##sys#syntax-error-hook
     800                                                   'module
     801                                                   "invalid export syntax" exp name))))
     802                                         (##sys#strip-syntax (caddr x))))))
     803                          (when (##sys#current-module)
     804                            (##sys#syntax-error-hook 'module "modules may not be nested" name))
     805                          (let-values (((body mreg)
     806                                        (parameterize ((##sys#current-module
     807                                                        (##sys#register-module name exports) )
     808                                                       (##sys#current-environment '())
     809                                                       (##sys#macro-environment ##sys#initial-macro-environment))
     810                                            (let loop ((body (cdddr x)) (xs '()))
     811                                              (cond
     812                                               ((null? body)
     813                                                (##sys#finalize-module (##sys#current-module))
     814                                                (cond ((assq name import-libraries) =>
     815                                                       (lambda (il)
     816                                                         (when verbose-mode
     817                                                           (print "generating import library " (cdr il) " for module "
     818                                                                  name " ..."))
     819                                                         (with-output-to-file (cdr il)
     820                                                           (lambda ()
     821                                                             (for-each
     822                                                              pretty-print
     823                                                              (##sys#compiled-module-registration
     824                                                               (##sys#current-module)))))
     825                                                         (values
     826                                                          (reverse xs)
     827                                                          '((##core#undefined)))))
     828                                                      (else
     829                                                       (values
     830                                                        (reverse xs)
     831                                                        (if standalone-executable
     832                                                            '()
     833                                                            (##sys#compiled-module-registration (##sys#current-module)))))))
     834                                               (else
     835                                                (when (and (pair? body)
     836                                                           (null? xs)
     837                                                           (pair? (car body))
     838                                                           (symbol? (caar body))
     839                                                           (let ((imp (or (lookup (caar body) se) (caar body))))
     840                                                             (and (not (memq imp '(import import-for-syntax)))
     841                                                                  ;; can it get any uglier? yes, it can
     842                                                                  (not (eq? imp (cdr (assq 'import ##sys#initial-macro-environment))))
     843                                                                  (not (eq? imp (cdr (assq 'import-for-syntax ##sys#initial-macro-environment)))))))
     844                                                  (compiler-warning
     845                                                   'syntax
     846                                                   "module body of `~s' does not begin with `import' form - maybe unintended?"
     847                                                   name))
     848                                                (loop
     849                                                 (cdr body)
     850                                                 (cons (walk
     851                                                        (car body)
     852                                                        (##sys#current-environment)
     853                                                        #f)
     854                                                       xs))))))))
     855                            (canonicalize-begin-body
     856                             (append
     857                              (parameterize ((##sys#current-module #f)
     858                                             (##sys#macro-environment (##sys#meta-macro-environment)))
     859                                (map
     860                                 (lambda (x)
     861                                   (walk x (##sys#current-meta-environment) #f) )
     862                                 mreg))
     863                              body)))))
     864
     865                       ((##core#named-lambda)
     866                        (walk `(,(macro-alias 'lambda se) ,@(cddr x)) se (cadr x)) )
     867
     868                       ((##core#loop-lambda)
     869                        (let* ([vars (cadr x)]
     870                               [obody (cddr x)]
     871                               [aliases (map gensym vars)]
     872                               (se2 (append (map cons vars aliases) se))
     873                               [body
     874                                (walk
     875                                 (##sys#canonicalize-body obody se2)
     876                                 se2 #f) ] )
     877                          (set-real-names! aliases vars)
     878                          `(lambda ,aliases ,body) ) )
    669879
    670880                        ((set! ##core#set!)
    671                          (##sys#check-syntax 'set! x '(_ variable _))
     881                         (##sys#check-syntax 'set! x '(_ variable _) #f se)
    672882                         (let* ([var0 (cadr x)]
    673                                 [var (resolve var0 ae)]
     883                                [var (lookup var0 se)]
    674884                                [ln (get-line x)]
    675                                 [val (walk (caddr x) ae me var0)] )
    676                            (when (eq? var var0) ; global?
    677                              (set! var (##sys#alias-global-hook var))
    678                              (when safe-globals-flag
    679                                (set! always-bound-to-procedure
    680                                  (lset-adjoin eq? always-bound-to-procedure var))
    681                                (set! always-bound (lset-adjoin eq? always-bound var)) )
    682                              (when (macro? var)
    683                                (compiler-warning
    684                                 'var "assigned global variable `~S' is a macro ~A"
    685                                 var
    686                                 (if ln (sprintf "in line ~S" ln) "") )
    687                                (when undefine-shadowed-macros (undefine-macro! var) ) ) )
    688                            (when (keyword? var)
    689                              (compiler-warning 'syntax "assignment to keyword `~S'" var) )
    690                            (cond [(assq var foreign-variables)
    691                                   => (lambda (fv)
    692                                        (let ([type (second fv)]
    693                                              [tmp (gensym)] )
    694                                          `(let ([,tmp ,(foreign-type-convert-argument val type)])
    695                                             (##core#inline_update
    696                                              (,(third fv) ,type)
    697                                              ,(foreign-type-check tmp type) ) ) ) ) ]
    698                                  [(assq var location-pointer-map)
     885                                [val (caddr x)] )
     886                           (when (memq var unlikely-variables)
     887                             (compiler-warning
     888                              'var
     889                              "assignment to variable `~s' possibly unintended"
     890                              var))
     891                           (cond ((assq var foreign-variables)
     892                                   => (lambda (fv)
     893                                        (let ([type (second fv)]
     894                                              [tmp (gensym)] )
     895                                          (walk
     896                                           `(let ([,tmp ,(foreign-type-convert-argument val type)])
     897                                              (##core#inline_update
     898                                               (,(third fv) ,type)
     899                                               ,(foreign-type-check tmp type) ) )
     900                                           se #f))))
     901                                 ((assq var location-pointer-map)
    699902                                  => (lambda (a)
    700903                                       (let* ([type (third a)]
    701904                                              [tmp (gensym)] )
    702                                          `(let ([,tmp ,(foreign-type-convert-argument val type)])
    703                                             (##core#inline_loc_update
    704                                              (,type)
    705                                              ,(second a)
    706                                              ,(foreign-type-check tmp type) ) ) ) ) ]
    707                                  [else `(set! ,var ,val)] ) ) )
     905                                         (walk
     906                                          `(let ([,tmp ,(foreign-type-convert-argument val type)])
     907                                             (##core#inline_loc_update
     908                                              (,type)
     909                                              ,(second a)
     910                                              ,(foreign-type-check tmp type) ) )
     911                                          se #f))))
     912                                 (else
     913                                  (when (eq? var var0) ; global?
     914                                    (set! var (##sys#alias-global-hook var #t))
     915                                    (when safe-globals-flag
     916                                      (mark-variable var '##compiler#always-bound-to-procedure)
     917                                      (mark-variable var '##compiler#always-bound))
     918                                    (when (macro? var)
     919                                      (compiler-warning
     920                                       'var "assigned global variable `~S' is a macro ~A"
     921                                       var
     922                                       (if ln (sprintf "in line ~S" ln) "") )
     923                                      (when undefine-shadowed-macros (undefine-macro! var) ) ) )
     924                                  (when (keyword? var)
     925                                    (compiler-warning 'syntax "assignment to keyword `~S'" var) )
     926                                  (when (pair? var) ; macro
     927                                    (syntax-error
     928                                     'set! "assignment to syntactic identifier" var))
     929                                  `(set! ,var ,(walk val se var0))))))
    708930
    709931                        ((##core#inline)
    710                          `(##core#inline ,(unquotify (cadr x)) ,@(mapwalk (cddr x) ae me)))
     932                         `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) se)))
    711933
    712934                        ((##core#inline_allocate)
    713935                         `(##core#inline_allocate
    714                            ,(map unquotify (second x))
    715                            ,@(mapwalk (cddr x) ae me)))
     936                           ,(map (cut unquotify <> se) (second x))
     937                           ,@(mapwalk (cddr x) se)))
    716938
    717939                        ((##core#inline_update)
    718                          `(##core#inline_update ,(cadr x) ,(walk (caddr x) ae me #f)) )
     940                         `(##core#inline_update ,(cadr x) ,(walk (caddr x) se #f)) )
    719941
    720942                        ((##core#inline_loc_update)
    721943                         `(##core#inline_loc_update
    722944                           ,(cadr x)
    723                            ,(walk (caddr x) ae me #f)
    724                            ,(walk (cadddr x) ae me #f)) )
     945                           ,(walk (caddr x) se #f)
     946                           ,(walk (cadddr x) se #f)) )
    725947
    726948                        ((##core#compiletimetoo ##core#elaborationtimetoo)
    727949                         (let ((exp (cadr x)))
    728                            (eval exp)
    729                            (walk exp ae me dest) ) )
     950                           (eval/meta exp)
     951                           (walk exp se dest) ) )
    730952
    731953                        ((##core#compiletimeonly ##core#elaborationtimeonly)
    732                          (eval (cadr x))
     954                         (eval/meta (cadr x))
    733955                         '(##core#undefined) )
    734956
    735957                        ((begin)
    736                          (##sys#check-syntax 'begin x '(begin . #(_ 0)))
     958                         (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
    737959                         (if (pair? (cdr x))
    738960                             (canonicalize-begin-body
     
    741963                                      [r (cdr xs)] )
    742964                                  (if (null? r)
    743                                       (list (walk x ae me dest))
    744                                       (cons (walk x ae me #f) (fold r)) ) ) ) )
     965                                      (list (walk x se dest))
     966                                      (cons (walk x se #f) (fold r)) ) ) ) )
    745967                             '(##core#undefined) ) )
    746968
    747                         ((##core#foreign-lambda)
    748                          (walk (expand-foreign-lambda x) ae me dest) )
    749 
    750                         ((##core#foreign-callback-lambda)
    751                          (walk (expand-foreign-callback-lambda x) ae me dest) )
    752 
    753                         ((##core#foreign-lambda*)
    754                          (walk (expand-foreign-lambda* x) ae me dest) )
    755 
    756                         ((##core#foreign-callback-lambda*)
    757                          (walk (expand-foreign-callback-lambda* x) ae me dest) )
    758 
    759                         ((##core#foreign-primitive)
    760                          (walk (expand-foreign-primitive x) ae me dest) )
    761 
    762                         ((##core#define-foreign-variable)
    763                          (let* ([var (cadr (second x))]
    764                                 [type (cadr (third x))]
     969                        ((foreign-lambda)
     970                         (walk (expand-foreign-lambda x) se dest) )
     971
     972                        ((foreign-safe-lambda)
     973                         (walk (expand-foreign-callback-lambda x) se dest) )
     974
     975                        ((foreign-lambda*)
     976                         (walk (expand-foreign-lambda* x) se dest) )
     977
     978                        ((foreign-safe-lambda*)
     979                         (walk (expand-foreign-callback-lambda* x) se dest) )
     980
     981                        ((foreign-primitive)
     982                         (walk (expand-foreign-primitive x) se dest) )
     983
     984                        ((define-foreign-variable)
     985                         (let* ([var (##sys#strip-syntax (second x))]
     986                                [type (third x)]
    765987                                [name (if (pair? (cdddr x))
    766                                           (cadr (fourth x))
     988                                          (fourth x)
    767989                                          (symbol->string var) ) ] )
    768990                           (set! foreign-variables
    769                              (cons (list var type (if (string? name) name (symbol->string name)))
     991                             (cons (list var type
     992                                         (if (string? name)
     993                                             name
     994                                             (symbol->string name)))
    770995                                   foreign-variables))
    771996                           '(##core#undefined) ) )
    772997
    773                         ((##core#define-foreign-type)
    774                          (let ([name (cadr (second x))]
    775                                [type (cadr (third x))]
     998                        ((define-foreign-type)
     999                         (let ([name (second x)]
     1000                               [type (third x)]
    7761001                               [conv (cdddr x)] )
    7771002                           (cond [(pair? conv)
     
    7791004                                        [ret (gensym)] )
    7801005                                    (##sys#hash-table-set! foreign-type-table name (vector type arg ret))
    781                                     (set! always-bound (cons* arg ret always-bound))
    782                                     (set! block-globals (cons* arg ret block-globals))
     1006                                    (mark-variable arg '##compiler#always-bound)
     1007                                    (mark-variable ret '##compiler#always-bound)
     1008                                    (hide-variable arg)
     1009                                    (hide-variable ret)
    7831010                                    (walk
    784                                      `(begin
    785                                         (##core#set! ,arg ,(first conv))
    786                                         (##core#set!
     1011                                     `(,(macro-alias 'begin se)
     1012                                        (define ,arg ,(first conv))
     1013                                        (define
    7871014                                         ,ret
    7881015                                         ,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
    789                                      ae me dest) ) ]
     1016                                     se dest) ) ]
    7901017                                 [else
    7911018                                  (##sys#hash-table-set! foreign-type-table name type)
    7921019                                  '(##core#undefined) ] ) ) )
    7931020
    794                         ((##core#define-external-variable)
    795                          (let* ([sym (cadr (second x))]
     1021                        ((define-external-variable)
     1022                         (let* ([sym (second x)]
    7961023                                [name (symbol->string sym)]
    797                                 [type (cadr (third x))]
    798                                 [exported (cadr (fourth x))]
     1024                                [type (third x)]
     1025                                [exported (fourth x)]
    7991026                                [rname (make-random-name)] )
    800                            (unless exported (set! name (symbol->string (cadr (fifth x)))))
     1027                           (unless exported (set! name (symbol->string (fifth x))))
    8011028                           (set! external-variables (cons (vector name type exported) external-variables))
    8021029                           (set! foreign-variables
     
    8071034
    8081035                        ((##core#let-location)
    809                          (let* ([var (cadr (second x))]
    810                                 [type (cadr (third x))]
     1036                         (let* ([var (second x)]
     1037                                [type (third x)]
    8111038                                [alias (gensym)]
    8121039                                [store (gensym)]
     
    8151042                           (set! location-pointer-map
    8161043                             (cons (list alias store type) location-pointer-map) )
    817                            `(let (,(let ([size (words (estimate-foreign-result-location-size type))])
    818                                      ;; Add 2 words: 1 for the header, 1 for double-alignment:
    819                                      ;; Note: C_a_i_bytevector takes number of words, not bytes
    820                                      (list
    821                                       store
    822                                       `(##core#inline_allocate
    823                                         ("C_a_i_bytevector" ,(+ 2 size))
    824                                         ',size)) ) )
    825                               ,(walk
    826                                 `(begin
    827                                    ,@(if init
    828                                         `((##core#set! ,alias ,init))
    829                                         '() )
    830                                    ,(if init (fifth x) (fourth x)) )
    831                                 (alist-cons var alias ae)
    832                                 me dest) ) ) )
     1044                           (walk
     1045                            `(let (,(let ([size (words (estimate-foreign-result-location-size type))])
     1046                                      ;; Add 2 words: 1 for the header, 1 for double-alignment:
     1047                                      ;; Note: C_a_i_bytevector takes number of words, not bytes
     1048                                      (list
     1049                                       store
     1050                                       `(##core#inline_allocate
     1051                                         ("C_a_i_bytevector" ,(+ 2 size))
     1052                                         ',size)) ) )
     1053                               (,(macro-alias 'begin se)
     1054                                ,@(if init
     1055                                      `((##core#set! ,alias ,init))
     1056                                      '() )
     1057                              &