Changeset 5358 in project


Ignore:
Timestamp:
08/08/07 22:40:50 (12 years ago)
Author:
felix winkelmann
Message:
  • renamed manual dir
  • can't get cmake to handle assembler file. I give up.
  • removed darcs link from site index
  • trivial build output changes
  • some more cleanup, trivialities
  • I'm out of ASCII banners
Location:
chicken
Files:
16 added
6 deleted
28 edited

Legend:

Unmodified
Added
Removed
  • chicken/CMakeLists.txt

    r5220 r5358  
    802802    ADD_DEFINITIONS(/MD)
    803803  ENDIF(USE_DYNAMIC_C_RUNTIME)
    804 ELSE(MSVC)
    805   OPTION(WITHOUT_LIBFFI "disable use if libffi, even if installed" FALSE)
    806804ENDIF(MSVC)
    807805
     
    915913ENDIF(HAVE_DL_H)
    916914
    917 CHECK_INCLUDE_FILE(ffi.h HAVE_FFI_H)
    918 
    919 TRY_RUN(LIBFFI_TEST_SUCCEEDED
    920   LIBFFI_TEST_COMPILED
    921   ${CMAKE_CURRENT_BINARY_DIR}
    922   ${Chicken_SOURCE_DIR}/libffi-test.c)
    923 IF(LIBFFI_TEST_COMPILED)
    924   IF(LIBFFI_TEST_SUCCEEDED STREQUAL "FAILED_TO_RUN")
    925     MESSAGE("libffi test failed")
    926     SET(WITHOUT_LIBFFI TRUE)
    927   ELSE(LIBFFI_TEST_SUCCEEDED STREQUAL "FAILED_TO_RUN")
    928     MESSAGE("libffi seems to work")
    929   ENDIF(LIBFFI_TEST_SUCCEEDED STREQUAL "FAILED_TO_RUN")
    930 ELSE(LIBFFI_TEST_COMPILED)
    931   MESSAGE("Unable to compile libffi test - no libffi support available")
    932   SET(WITHOUT_LIBFFI TRUE)
    933 ENDIF(LIBFFI_TEST_COMPILED)
    934 
    935 IF(NOT MSVC)
    936   IF(WITHOUT_LIBFFI)
    937     SET(HAVE_FFI_H FALSE)
    938   ELSE(WITHOUT_LIBFFI)
    939     IF(HAVE_FFI_H)
    940       SET(MORE_LIBS ${MORE_LIBS} ffi)
    941       SET(MORE_STATIC_LIBS ${MORE_STATIC_LIBS} ffi)
    942     ENDIF(HAVE_FFI_H)
    943   ENDIF(WITHOUT_LIBFFI)
    944 ENDIF(NOT MSVC)
    945  
    946915# check for windows.h
    947916CHECK_INCLUDE_FILE(windows.h HAVE_WINDOWS_H)
     
    10801049
    10811050####################################################################
    1082 #  CHICKEN_SPEC                                                    #
    1083 ####################################################################
    1084 
    1085 # I don't really know what chicken.spec is for.
    1086 CONFIGURE_FILE(${Chicken_SOURCE_DIR}/chicken.spec.in
    1087   ${CMAKE_CURRENT_BINARY_DIR}/chicken.spec)
    1088 
    1089 
    1090 ####################################################################
    10911051#  CHICKEN_DEFAULTS_H                                              #
    10921052####################################################################
     
    11381098    ${Chicken_SOURCE_DIR}/chicken.h
    11391099    ${CMAKE_CURRENT_BINARY_DIR}/chicken-defaults.h
    1140     ${Chicken_SOURCE_DIR}/runtime.c
    1141   )
     1100    ${Chicken_SOURCE_DIR}/runtime.c)
    11421101ENDMACRO(GET_LIB_CSOURCE)
    11431102
     
    15391498  TARGET_LINK_LIBRARIES(libchickengui libpcre-for-shared ${GUI_LIBS} ${MORE_LIBS})
    15401499  ADD_DEPENDENCIES(libchickengui libchicken-c)
    1541 
     1500 
    15421501ELSE(MSVC)
    15431502
     
    15501509  # prefix onto every library.  For cross-platform stuff,
    15511510  # this often results in the 'liblibfoo" problem.
    1552    
     1511
    15531512  ADD_LIBRARY(libchicken SHARED ${CHICKEN_LIB_SOURCES} ${PCRE_HEADER})
    15541513  SET_TARGET_PROPERTIES(libchicken PROPERTIES
  • chicken/Makefile.am

    r5220 r5358  
    1111lt_version_info = 0:0:0
    1212
    13 HAVE_ALLOCA_H=@HAVE_ALLOCA_H@
    1413STACK_GROWS_DOWNWARD=@STACK_GROWS_DOWNWARD@
    1514NO_STATIC_EXECUTABLES=@NO_STATIC_EXECUTABLES@
    1615BINARY_VERSION=@BINARY_VERSION@
    17 
    18 if IS_MINGW
    19 MORE_LIBS = @LIBS@ @SHLIBS@ @WINSOCKLIB@
    20 MORE_STATIC_LIBS = @LIBS@ @WINSOCKLIB@
    21 else
     16APPLY_HACK_FILE=@APPLY_HACK_FILE@
     17
    2218MORE_LIBS = @LIBS@ @SHLIBS@
    2319MORE_STATIC_LIBS = @LIBS@
    24 endif
    2520
    2621# These C_INSTALL_* variables are necessary so that
     
    272267commonlibsources = match.c profiler.c runtime.c scheduler.c stub.c
    273268chickenlibsources = eval.c extras.c library.c lolevel.c utils.c tcp.c \
    274   srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c regex.c
     269  srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c regex.c posixunix.c
    275270chickenulibsources = ueval.c uextras.c ulibrary.c ulolevel.c uutils.c utcp.c \
    276   usrfi-1.c usrfi-4.c usrfi-13.c usrfi-14.c usrfi-18.c uregex.c
    277 
    278 if IS_MINGW
    279 chickenlibsources += posixwin.c
    280 chickenulibsources += uposixwin.c
    281 else
    282 chickenlibsources += posixunix.c
    283 chickenulibsources += uposixunix.c
     271  usrfi-1.c usrfi-4.c usrfi-13.c usrfi-14.c usrfi-18.c uregex.c uposixunix.c
     272
     273if USE_APPLY_HACK
     274chickenlibsources += apply-hack.s
     275chickenulibsources += apply-hack.s
    284276endif
    285277
     
    327319# standard place to install these sorts of files so we must leave that
    328320# to the package builder.
    329 EXTRA_DIST = makefile.vc INSTALL win-install.bat INSTALL-CMake.txt chicken.spec.in *.1
     321EXTRA_DIST = makefile.vc INSTALL win-install.bat INSTALL-CMake.txt *.1
    330322
    331323
  • chicken/NEWS

    r3839 r5358  
    1 2.52
     12.6
    22
    33- Many bugfixes
  • chicken/README

    r5220 r5358  
    33  (c)2000-2007 Felix L. Winkelmann
    44
    5   Version 2.632
     5  Version 2.634
    66
    77
     
    8383          strips the executables from symbol- information which makes
    8484          them much smaller.
    85 
    86           To make `apply' work, C function calls have to be
    87           constructed at run-time, which can not be portably
    88           implemented, unless using a big `switch' statement for every
    89           possible number of arguments. If the libffi library is
    90           available for this platform and if it is installed, then
    91           CHICKEN can take advantage of this to construct function
    92           calls for an (theoretical) unlimited number of arguments
    93           (currently there is an arbitrary limit of 1000 arguments
    94           maximum). To build CHICKEN with support for libffi, download
    95           and install libffi from http://sources.redhat.com/libffi/
    96           before running "./configure".  libffi is supposed to work on
    97           Mac OS X, many Linux systems (x86, Alpha, ARM, m68k, PPC)
    98           and Solaris.
    99 
    100           (Note: a more recent development snapshot of libffi is
    101           available at
    102           http://www.call-with-current-continuation.org/tarballs/libffi-3.tgz).
    103           If you experience any problems with your libffi installation,
    104           you can disable support for it by passing "--without-libffi"
    105           to configure.
    10685
    10786          To build and run some benchmarks, enter
  • chicken/banner.scm

    r3241 r5358  
    11(define-constant banner #<<EOF
    22
    3  .--. .-.    _       .-.               
    4 : .--': :   :_;      : :.-.           
    5 : :   : `-. .-. .--. : `'.' .--. ,-.,-.
    6 : :__ : .. :: :'  ..': . `.' '_.': ,. :
    7 `.__.':_;:_;:_;`.__.':_;:_;`.__.':_;:_;
    8 
     3this is CHICKEN
    94
    105EOF
  • chicken/benchmarks/fprint.scm

    r1016 r5358  
    3535  (init-aux m n atoms)))
    3636
    37 (define test-pattern (init 6 6 test-atoms))
     37(define test-pattern (init 8 8 test-atoms))
    3838
    3939(define (fprint)
  • chicken/build.scm

    r5220 r5358  
    2020       (not (equal? (getenv "TERM") "dumb"))))
    2121
     22(define *tty-width*
     23  (or (and *tty*
     24           (with-input-from-pipe "stty size 2>/dev/null"
     25             (lambda () (read) (read))))
     26      72))
     27
    2228(define *info-message-escape* (if *tty* "\x1b[0m\x1b[2m" ""))
    2329(define *target-message-escape* (if *tty* "\x1b[0m\x1b[32m" ""))
     
    2632(define *reset-escape* (if *tty* "\x1b[0m" ""))
    2733
     34(define (format-message msg #!optional (nl #t))
     35  (if (or *verbose* (not *tty*))
     36      ((if nl print print*) msg)
     37      (for-each
     38       (lambda (ln)
     39         (printf "\r\x1b[K~a~!"
     40                 (if (>= (string-length ln) (sub1 *tty-width*))
     41                     (string-append
     42                      (substring ln 0 (- *tty-width* 5))
     43                      "...")
     44                     ln) ) )
     45       (string-split msg "\n")) ) )
     46
    2847(define (message fstr . args)
    29   (printf "~a* ~?~a~%" *info-message-escape* fstr args *reset-escape*) )
     48  (when *verbose*
     49    (format-message (sprintf "~a* ~?~a " *info-message-escape* fstr args *reset-escape*)) ) )
     50
     51(define (message* fstr . args)
     52  (when *verbose*
     53    (format-message (sprintf "~a* ~?~a " *info-message-escape* fstr args *reset-escape*) #f) ) )
    3054
    3155(define (target-message fstr . args)
    32   (printf "~a~?~a~%" *target-message-escape* fstr args *reset-escape*) )
     56  (format-message (sprintf "~a~?~a " *target-message-escape* fstr args *reset-escape*)))
    3357
    3458(define (command-message fstr . args)
    35   (printf "~a  ~?~a~%" *command-message-escape* fstr args *reset-escape*) )
     59  (when *verbose*
     60    (format-message (sprintf "~a  ~?~a " *command-message-escape* fstr args *reset-escape*))) )
    3661
    3762(define (error-message fstr . args)
    38   (sprintf "~a~?~a~%" *error-message-escape* fstr args *reset-escape*) )
     63  (sprintf "~%~a~?~a~%" *error-message-escape* fstr args *reset-escape*))
    3964
    4065(define (quit fstr . args)
    4166  (display (apply error-message fstr args) (current-error-port))
    4267  (reset) )
     68
     69(define (cleanup-output)
     70  (when (and (not *verbose*) *tty*)
     71    (printf "\r\x1b[0m\x1b[K~!") ) )
    4372
    4473
     
    139168   (lambda (exp)
    140169     (let ((cmd (string-intersperse (map ->string (flatten exps)))))
    141        (when *verbose* (command-message "~A" cmd))
     170       (command-message "~A" cmd)
    142171       (let ((s (system cmd)))
    143172         (unless (zero? s)
     
    212241      (begin
    213242        (when (file-exists? t)
    214           (when *verbose* (message "deleting ~a" t))
     243          (message "deleting ~a" t)
    215244          (delete-file t) )
    216245        (abort ex) )
     
    248277        (when continuous
    249278          (watch-dependencies wdeps ftable)
    250           (loop))))))
     279          (loop)))
     280      (cleanup-output))))
    251281
    252282(define (build-dump #!optional (port (current-output-port)))
     
    333363                             ((> ft (hash-table-ref/default tab dep 0))))
    334364                    (hash-table-set! tab dep ft)
    335                     (when *verbose* (message "~a changed" dep))
     365                    (message "~a changed" dep)
    336366                    #t) )
    337367                deps))
     
    358388            (lambda () (set! old (current-directory)))
    359389            (lambda ()
    360               (when *verbose* (command-message "cd ~a" dir))
     390              (command-message "cd ~a" dir)
    361391              (change-directory dir)
    362392              (thunk) )
    363393            (lambda ()
    364394              (change-directory old)
    365               (when *verbose* (command-message "cd ~a" old) ) ) ) ) ) )
     395              (command-message "cd ~a" old) ) ) ) ) )
    366396
    367397(define (try-run code #!optional (msg "trying to compile and run some C code") (flags "") (cc "cc"))
    368398  (let ((tmp (create-temporary-file "c")))
    369399    (with-output-to-file tmp (lambda () (display code)))
    370     (when *verbose* (printf "~a ... ~!" msg))
     400    (message* "~a ..." msg)
    371401    (let ((r (zero? (system (sprintf "~a ~a ~a 2>/dev/null && ./a.out" cc tmp flags)))))
    372402      (delete-file* tmp)
    373       (when *verbose*
    374         (print (if r "ok" "failed")))
     403      (message (if r "ok" "failed"))
    375404      r) ) )
    376405
     
    399428                                      (when (null? next)
    400429                                        (error "missing argument for option" (car args)) )
    401                                       (set! next (cdr next))
    402                                       (values opt (car next)) ) ) )
     430                                      (let ((x (car next)))
     431                                        (set! next (cdr next))
     432                                        (values opt x)))))
    403433                              ((_ (? string?) opt #f #f) (values opt #t))
    404434                              (_ (values #f #f)) ) ) )
  • chicken/buildversion

    r5220 r5358  
    1 2.632
     12.634
  • chicken/c-platform.scm

    r5220 r5358  
    10931093
    10941094(rewrite 'read-char 23 0 '##sys#read-char/port '##sys#standard-input)
    1095 (rewrite 'write-char 23 0 '##sys#write-char/port '##sys#standard-output)
     1095(rewrite 'write-char 23 1 '##sys#write-char/port '##sys#standard-output)
    10961096(rewrite 'read-string 23 1 '##sys#read-string/port '##sys#standard-input)
    1097 
    1098 (rewrite 'substring=? 24 2 '##sys#substring=? 0 0 #f)
    1099 (rewrite 'substring-ci=? 24 2 '##sys#substring-ci=? 0 0 #f)
    1100 (rewrite 'substring-index 24 2 '##sys#substring-index 0)
    1101 (rewrite 'substring-index-ci 24 2 '##sys#substring-index-ci 0)
     1097(rewrite 'substring=? 23 2 '##sys#substring=? 0 0 #f)
     1098(rewrite 'substring-ci=? 23 2 '##sys#substring-ci=? 0 0 #f)
     1099(rewrite 'substring-index 23 2 '##sys#substring-index 0)
     1100(rewrite 'substring-index-ci 23 2 '##sys#substring-index-ci 0)
  • chicken/chicken-config-cmake.h.in

    r4845 r5358  
    3434#cmakedefine HAVE_DL_H @HAVE_DL_H@
    3535
    36 #cmakedefine HAVE_FFI_H @HAVE_FFI_H@
    37 
    3836#cmakedefine HAVE_WINDOWS_H @HAVE_WINDOWS_H@
    3937
  • chicken/chicken-more-macros.scm

    r4845 r5358  
    441441
    442442(##sys#register-macro-2
     443 'select
     444 (let ((gensym gensym))
     445   (lambda (form)
     446     (let ((exp (car form))
     447           (body (cdr form)) )
     448       (let ((tmp (gensym)))
     449         `(let ((,tmp ,exp))
     450            ,(let expand ((clauses body))
     451               (if (not (pair? clauses))
     452                   '(##core#undefined)
     453                   (let ((clause (##sys#slot clauses 0))
     454                         (rclauses (##sys#slot clauses 1)) )
     455                     (##sys#check-syntax 'switch clause '#(_ 1))
     456                     (if (eq? 'else (car clause))
     457                         `(begin ,@(cdr clause))
     458                         `(if (or ,@(map (lambda (x) `(eqv? ,tmp ,x))
     459                                         (car clause) ) )
     460                              (begin ,@(cdr clause))
     461                              ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )
     462
     463(##sys#register-macro-2                 ; DEPRECATED
    443464 'switch
    444465 (let ((gensym gensym))
  • chicken/chicken.h

    r4845 r5358  
    221221#endif
    222222
    223 #if defined(C_MACOSX) || defined(__linux__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__)
     223#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
     224# define C_XXXBSD
     225#endif
     226
     227#if defined(C_MACOSX) || defined(__linux__) | defined(C_XXXBSD)
    224228# define C_GNU_ENV
    225229#endif
     
    10721076
    10731077C_varextern C_TLS void (C_fcall *C_restart_trampoline)(void *proc) C_regparm C_noret;
    1074 C_varextern C_TLS void (*C_post_gc_hook)(int mode);
     1078C_varextern C_TLS void (*C_post_gc_hook)(int mode, long ms);
    10751079C_varextern C_TLS void (*C_panic_hook)(C_char *msg);
    10761080
  • chicken/configure.in

    r5220 r5358  
    2020AC_ARG_WITH(suncc, [  --with-suncc            build with Sun's C compiler],[CC="suncc"; CFLAGS="-fast -xalias_level=strong -xrestrict -xregs=frameptr"; SUNCC=1])
    2121
    22 dnl Disable libffi (if found)?
    23 AC_ARG_WITH(libffi, [  --without-libffi        do not use libffi, even if available],[USE_LIBFFI=$withval], [USE_LIBFFI=yes])
    24 
    2522dnl Enable GC hooks?
    2623AC_ARG_ENABLE(gc-hooks, [  --enable-gc-hooks       enable various garbage-collector hooks],[AC_DEFINE(C_GC_HOOKS, [], [define if GC hooks should be available])])
     
    4441AC_LIBTOOL_WIN32_DLL
    4542AM_PROG_LIBTOOL
     43AM_PROG_AS
    4644
    4745dnl Check for GNU make.
     
    8684esac
    8785
    88 dnl Check for MinGW
    89 AC_MSG_CHECKING([whether we are in a MinGW system])
    90 echo
    91 AC_CHECK_DECL([__MINGW32__], [mingw_system=1])
    92 
    9386dnl Check for Cygwin
    9487AC_MSG_CHECKING([whether we are running on Cygwin])
    9588echo
    9689AC_CHECK_DECL([__CYGWIN__], [cygwin_system=1])
    97 
    98 dnl Check for MinGW library path, with the all important drive letter
    99 if test -n "${mingw_system}"; then
    100   mingw_libdir=`mingw32-gcc -print-prog-name=ld | sed 's%/lib/gcc-lib/.*%/lib%'`
    101   if test "$cross_compiling" != "yes"; then
    102     AC_CHECK_FILE(${mingw_libdir}/libws2_32.a, [mingw_ws2=1])
    103   else
    104     mingw_ws2=1
    105   fi
    106 fi
    107 AM_CONDITIONAL(IS_MINGW, [test -n "${mingw_system}"])
    108 if test -n "${mingw_ws2}"; then
    109   WINSOCKLIB="-L${mingw_libdir} -lws2_32"
    110   AC_SUBST(WINSOCKLIB)
    111   AC_MSG_RESULT([importing Winsock2 library with ${WINSOCKLIB}])
    112 elif test -n "${mingw_system}"; then
    113   AC_MSG_RESULT([unknown MinGW configuration])
    114 fi
    11590
    11691dnl Checks for header files.
     
    125100AC_CHECK_HEADER(windows.h, [AC_DEFINE(HAVE_WINDOWS_H,1,[Define if windows.h is useable])])
    126101AC_CHECK_HEADER(grp.h, [AC_DEFINE(HAVE_GRP_H,1,[Define if grp.h is available])])
    127 
    128 if test x"${cygwin_system}" = x1; then
    129   USE_LIBFFI=no
    130 fi
    131 
    132 if test x"$USE_LIBFFI" = xyes; then
    133 AC_CHECK_HEADER(ffi.h, [AC_DEFINE(HAVE_FFI_H,1,[Define if ffi.h is available])])
    134 fi
    135 
    136102AC_CHECK_HEADER(crt_externs.h, [AC_DEFINE(HAVE_CRT_EXTERNS_H, 1, [Define if crt_externs.h is available])])
    137103
     
    161127AC_CHECK_LIB(dl, dlopen, [LIBS="$LIBS -ldl"; SHLIBS="$SHLIBS -ldl"])
    162128
    163 if test x"$USE_LIBFFI" = xyes; then
    164 AC_CHECK_LIB(ffi, ffi_prep_cif, [LIBS="$LIBS -lffi"; SHLIBS="$SHLIBS -lffi"])
    165 fi
    166 
    167129dnl Win32 DLL functions.
    168130AC_CHECK_DECL(LoadLibrary, [AC_DEFINE(HAVE_LOADLIBRARY,1,[Define if windows.h declares LoadLibrary])],,[#include <windows.h>])
     
    173135
    174136dnl We need this for HP-UX, it seems:
    175 if test -z "${mingw_ws2}"; then
    176   AC_CHECK_LIB(m, modf, [LIBS="$LIBS -lm"])
    177 fi
     137AC_CHECK_LIB(m, modf, [LIBS="$LIBS -lm"])
    178138
    179139dnl Socket stuff for Solaris (stolen from thw SWIG configure.in):
     
    211171fi
    212172
     173dnl check for apply hack
     174AC_MSG_CHECKING([whether apply hack is available for this platform ($host_cpu)])
     175APPLY_HACK_FILE=""
     176case "$host_cpu" in
     177     i*86|powerpc)
     178       AC_MSG_RESULT([available.])
     179       case "$host_cpu" in
     180         i*86) APPLY_HACK_FILE="apply-hack.x86.s";;
     181         powerpc) APPLY_HACK_FILE="apply-hack.ppc.s";;
     182         *)
     183            echo "this shouldn't happen"
     184            exit 1
     185       esac
     186       AC_DEFINE(C_HACKED_APPLY, [], [define if apply hack is available for this platform]);;
     187     *)
     188       AC_MSG_RESULT([not available.]);;
     189esac
     190AM_CONDITIONAL(USE_APPLY_HACK, [test "$APPLY_HACK_FILE" != ""])
     191AC_SUBST(APPLY_HACK_FILE)
     192if test "$APPLY_HACK_FILE" != ""; then
     193   rm -f apply-hack.s
     194   ln -s $APPLY_HACK_FILE apply-hack.s
     195fi
     196
    213197dnl If we're using gcc, try to find better CFLAGS than the default -g -O2.
    214198AC_MSG_CHECKING([for better CFLAGS])
     
    216200  *gcc*)
    217201  if test "-g -O2" = "$CFLAGS"; then
    218     if test x${mingw_system} = x1; then
    219        CFLAGS="-Os -fno-strict-aliasing $WARNFLAGS"
    220     else
    221        CFLAGS="-Os -fomit-frame-pointer -fno-strict-aliasing $WARNFLAGS"
    222     fi
     202    CFLAGS="-Os -fomit-frame-pointer -fno-strict-aliasing $WARNFLAGS"
    223203  fi;;
    224204  *)
     
    326306dnl output all configured files
    327307AC_CONFIG_FILES([
    328 chicken.spec
    329308Makefile
    330309])
  • chicken/csc.scm

    r5220 r5358  
    617617                    (set! target-filename
    618618                      (if shared
    619                           (pathname-replace-extension (last scheme-files) shared-library-extension)
    620                           (pathname-replace-extension (last scheme-files) executable-extension) ) ) )
     619                          (pathname-replace-extension (first scheme-files) shared-library-extension)
     620                          (pathname-replace-extension (first scheme-files) executable-extension) ) ) )
    621621                  (run-translation) ] )
    622622           (unless translate-only
     
    680680                (set! verbose #t)
    681681                (t-options "-verbose")
    682                 (set! compile-options (cons "-v" compile-options))
     682                (set! compile-options (cons "-v -Q" compile-options))
    683683                (set! link-options (cons "-v" link-options)) ]
    684684               [(|-A| -analyze-only)
  • chicken/csi.scm

    r4845 r5358  
    508508
    509509(define report
    510   (let ([printf printf]
     510  (let ((printf printf)
    511511        (chop chop)
    512         [with-output-to-port with-output-to-port]
    513         [current-output-port current-output-port] )
     512        (sort sort)
     513        (with-output-to-port with-output-to-port)
     514        (current-output-port current-output-port) )
    514515    (lambda port
    515516      (with-output-to-port (if (pair? port) (car port) (current-output-port))
     
    522523            (for-each
    523524             (lambda (lst)
    524                (newline)
    525                (for-each (cut print* #\tab <>) lst) )
    526              (chop (map keyword->string ##sys#features) 8) )
     525               (display "\n  ")
     526               (for-each
     527                (lambda (f)
     528                  (printf "~a~a" f (make-string (fxmax 1 (fx- 16 (string-length f))) #\space)) )
     529                lst) )
     530             (chop (sort (map keyword->string ##sys#features) string<?) 5))
    527531            (printf "~%~
    528532                   Machine type:    \t~A ~A~%~
  • chicken/dist.cmake

    r5220 r5358  
    109109  pcre/ucptable.c
    110110  pcre/ucp_findchar.c
     111  apply-hack.ppc.s
     112  apply-hack.x86.s
     113  apply-hack.x86-64.s
    111114  static/CMakeLists.txt
    112115  benchmarks/boyer.scm
  • chicken/distribution/manifest

    r4845 r5358  
    99README
    1010StackGrowsDownward.c
    11 libffi-test.c
    1211autogen.sh
    1312banner.scm
     
    245244chicken-gzip.exe
    246245chicken-tar.exe
     246apply-hack.x86.s
     247apply-hack.x86-64.s
     248apply-hack.ppc.s
  • chicken/hen.el

    r4845 r5358  
    217217              "match" "match-lambda" "match-lambda*" "match-define" "match-let" "match-let*"
    218218
    219               "case" "case-lambda" "cond" "cond-expand" "condition-case" "switch"
     219              "case" "case-lambda" "cond" "cond-expand" "condition-case" "select"
    220220              "handle-exceptions"
    221221              "cut" "cute" "time" "regex-case"
  • chicken/library.scm

    r5220 r5358  
    31183118                   (if (##sys#fudge 3) " 64bit" "")
    31193119                   (if (##sys#fudge 15) " symbolgc" "")
    3120                    (if (##sys#fudge 22) " libffi" "")
     3120                   (if (##sys#fudge 40) " manyargs" "")
    31213121                   (if (##sys#fudge 24) " dload" "")
    31223122                   (if (##sys#fudge 28) " ptables" "")
     
    31743174  (check (machine-byte-order)) )
    31753175
    3176 (when (##sys#fudge 22) (set! ##sys#features (cons #:libffi ##sys#features)))
     3176(when (##sys#fudge 40) (set! ##sys#features (cons #:manyargs ##sys#features)))
    31773177(when (##sys#fudge 24) (set! ##sys#features (cons #:dload ##sys#features)))
    31783178(when (##sys#fudge 28) (set! ##sys#features (cons #:ptables ##sys#features)))
     
    38793879   (##core#undefined)                   ; #10 specific
    38803880   #f                                   ; #11 block object (type depends on blocking type)
    3881    '() ) )                              ; #12 recipients (currently unused)
     3881   '()                                  ; #12 recipients (currently unused)
     3882   #f) )                                ; #13 unblocked by timeout?
    38823883
    38833884(define ##sys#primordial-thread (##sys#make-thread #f 'running 'primordial ##sys#default-thread-quantum))
  • chicken/optimizer.scm

    r5220 r5358  
    853853(define (simplify-named-call db params name cont class classargs callargs)
    854854  (define (test sym prop) (get db sym prop))
     855  (define (defarg x)
     856    (cond ((symbol? x) (varnode x))
     857          ((and (pair? x) (eq? 'quote (car x))) (qnode (cadr x)))
     858          (else (qnode x))))
    855859
    856860  (case class
     
    12181222                        callargs) ) ) ) ) ) )
    12191223
    1220     ;; (<op> <arg1> ... <argN> <specialarg>) ->
    1221     ;;   (<primitiveop> <arg1> ... <argN> <specialarg>)
    1222     ;; (<op> <arg1> ... <argN>) ->
    1223     ;;   (<primitiveop> <arg1> ... <argN> <defaultvar>)
    1224     ((23) ; classargs = (<N> <primitiveop> <defaultvar>)
    1225      (let ((argc (first classargs))
    1226            (rargc (length callargs)))
    1227        (and inline-substitutions-enabled
    1228             (<= argc rargc (add1 argc))
    1229             (or (test name 'standard-binding) (test name 'extended-binding))
    1230             (make-node
    1231              '##core#call '(#t)
    1232              (append
    1233               (list (varnode (second classargs)) cont)
    1234               callargs
    1235               (if (= rargc argc)
    1236                   (list (varnode (third classargs)))
    1237                   '() ) ) ) ) ) )
    1238 
    12391224    ;; (<op> <arg1> ... <argN>) -> (<primitiveop> ...)
    1240     ;; (<op> <arg1> ... <argN-I> <literalN-I>) -> (<primitiveop> ...)
    1241     ((24) ; classargs = (<argc> <primitiveop> <literal1> ...)
     1225    ;; (<op> <arg1> ... <argN-I> <defargN-I>) -> (<primitiveop> ...)
     1226    ;; - default args in classargs should be either symbol or (optionally)
     1227    ;;   quoted literal
     1228    ((23) ; classargs = (<minargc> <primitiveop> <literal1>|<varable1> ...)
    12421229     (and inline-substitutions-enabled
    12431230          (or (test name 'standard-binding) (test name 'extended-binding))
     
    12571244                               (if (null? da)
    12581245                                   '()
    1259                                    (cons (qnode (car da)) (loop '() (cdr da))) ) )
     1246                                   (cons (defarg (car da)) (loop '() (cdr da))) ) )
    12601247                              ((null? da) '())
    12611248                              (else (cons (car ca) (loop (cdr ca) (cdr da))))))))))))))
  • chicken/posixunix.scm

    r4845 r5358  
    4343#include <signal.h>
    4444#include <errno.h>
     45#include <math.h>
    4546
    4647static int C_not_implemented(void);
     
    248249}
    249250
     251static void C_set_timeval(C_word num, struct timeval *tm)
     252{
     253  if((num & C_FIXNUM_BIT) != 0) {
     254    tm->tv_sec = C_unfix(num);
     255    tm->tv_usec = 0;
     256  }
     257  else {
     258    double i;
     259    tm->tv_usec = (int)(modf(C_flonum_magnitude(num), &i) * 1000000);
     260    tm->tv_sec = (int)i;
     261  }
     262}
     263
    250264#define C_set_exec_arg(i, a, len)       C_set_arg_string(C_exec_args, i, a, len)
    251265#define C_free_exec_args()              C_free_arg_string(C_exec_args)
     
    310324#define C_test_fd_set(i, fd)  FD_ISSET(fd, &C_fd_sets[ i ])
    311325#define C_C_select(m)         C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, NULL))
    312 #define C_C_select_t(m, t)    (C_timeval.tv_sec = C_unfix(t), C_timeval.tv_usec = 0, C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, &C_timeval)))
     326#define C_C_select_t(m, t)    (C_set_timeval(t, &C_timeval), \
     327                               C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, &C_timeval)))
    313328
    314329#define C_ctime(n)          (C_secs = (n), ctime(&C_secs))
     
    616631                fdsw) ] )
    617632        (let ([n (cond [tm
    618                         (##sys#check-exact tm 'file-select)
     633                        (##sys#check-number tm 'file-select)
    619634                        (##core#inline "C_C_select_t" (fx+ fdmax 1) tm) ]
    620635                       [else (##core#inline "C_C_select" (fx+ fdmax 1))] ) ] )
  • chicken/runtime.c

    r5220 r5358  
    101101#endif
    102102
    103 #if defined(HAVE_FFI_H)
    104 # include <ffi.h>
    105 #endif
    106 
    107103#ifndef RTLD_GLOBAL
    108104# define RTLD_GLOBAL                   0
     
    143139# define S_IFDIR            _S_IFDIR
    144140# define timezone           _timezone
    145 
    146 # ifdef _M_IX86
    147 #  define HACKED_APPLY
     141# if defined(_M_IX86)
     142#  define C_HACKED_APPLY
    148143# endif
    149 
     144#else
     145# ifdef C_HACKED_APPLY
     146extern void C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
     147# endif
    150148#endif
    151149
     
    166164#define DEFAULT_LOCATIVE_TABLE_SIZE    32
    167165#define DEFAULT_COLLECTIBLES_SIZE      1024
    168 #define DEFAULT_TRACE_BUFFER_SIZE      16
     166#define DEFAULT_TRACE_BUFFER_SIZE      8
    169167
    170168#define MAX_HASH_PREFIX                64
     
    342340
    343341C_TLS void (C_fcall *C_restart_trampoline)(void *proc) C_regparm C_noret;
    344 C_TLS void (*C_post_gc_hook)(int mode);
     342C_TLS void (*C_post_gc_hook)(int mode, long ms);
    345343
    346344C_TLS int
     
    721719  reload_lf = NULL;
    722720  callback_continuation_level = 0;
     721  timer_start_gc_ms = 0;
    723722  C_randomize(time(NULL));
    724723  return 1;
     
    28492848  if(gc_mode == GC_MAJOR) gc_count_1 = 0;
    28502849
    2851   if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode);
     2850  if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, tgc);
    28522851
    28532852  /* Jump from the Empire State Building... */
     
    40044003    return C_fix(C_MOST_POSITIVE_FIXNUM);
    40054004
    4006   case C_fix(22):
    4007 #if defined(HAVE_FFI_H)
    4008     return C_SCHEME_TRUE;
    4009 #else
    4010     return C_SCHEME_FALSE;
    4011 #endif
     4005  /*  case C_fix(22): */
    40124006
    40134007  case C_fix(23):
     
    40674061
    40684062  case C_fix(34):
    4069 #ifdef HAVE_FFI_H
     4063#ifdef C_HACKED_APPLY
    40704064    return C_fix(1000);
    40714065#else
     
    40894083  case C_fix(39):
    40904084#if defined(C_CROSS_CHICKEN) && C_CROSS_CHICKEN
     4085    return C_SCHEME_TRUE;
     4086#else
     4087    return C_SCHEME_FALSE;
     4088#endif
     4089
     4090  case C_fix(40):
     4091#if defined(C_HACKED_APPLY)
    40914092    return C_SCHEME_TRUE;
    40924093#else
     
    58165817  va_list v;
    58175818  int i, n = c - 3;
    5818   C_word x, skip;
    5819 #if defined(HAVE_FFI_H)
    5820   ffi_cif cif;
    5821   ffi_type **argtypes;
    5822   void **argvalues;
    5823   ffi_status status;
    5824 #endif
    5825 #ifdef HACKED_APPLY
     5819  C_word x, skip, fn2;
     5820#ifdef C_HACKED_APPLY
    58265821  C_word *buf = C_temporary_stack_limit;
    58275822  void *proc;
     
    58315826  if(c < 4) C_bad_min_argc(c, 4);
    58325827
    5833   fn = resolve_procedure(fn, "apply");
     5828  fn2 = resolve_procedure(fn, "apply");
    58345829#endif
    58355830
     
    58385833  for(i = n; i > 1; --i) {
    58395834    x = va_arg(v, C_word);
    5840 #ifdef HACKED_APPLY
     5835#ifdef C_HACKED_APPLY
    58415836    *(buf++) = x;
    58425837#else
     
    58555850    x = C_u_i_car(skip);
    58565851
    5857 #ifdef HACKED_APPLY
     5852#ifdef C_HACKED_APPLY
    58585853# ifndef C_UNSAFE_RUNTIME
    58595854    if(buf >= C_temporary_stack_bottom) barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
     
    58685863      barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
    58695864# endif
    5870 
    58715865#endif
    58725866    ++n;
     
    58765870  --n;
    58775871
    5878 #ifdef HAVE_FFI_H
    5879   if(n >= 120) {
    5880 # ifndef C_UNSAFE_RUNTIME
    5881     if(debug_mode == 2 && n > 126)
    5882       fputs(C_text("[debug] `apply' argument list length exceeds default maximum (using libffi)\n"), stderr);
    5883 
    5884     if(n > 1000) barf(C_TOO_MANY_PARAMETERS_ERROR, "apply"); /* arbitrary */
    5885 # endif
    5886  
    5887     argtypes = (ffi_type **)C_alloca(sizeof(ffi_type *) * (n + 3));
    5888     argvalues = (void **)C_alloca(sizeof(void *) * (n + 3));
    5889     argtypes[ 0 ] = &ffi_type_pointer;
    5890     argtypes[ 1 ] = &ffi_type_pointer;
    5891     argtypes[ 2 ] = &ffi_type_pointer;
    5892     c = n + 2;
    5893     argvalues[ 0 ] = &c;
    5894     argvalues[ 1 ] = &fn;
    5895     argvalues[ 2 ] = &k;
    5896 
    5897     for(i = 0; i < n; ++i) {
    5898       argtypes[ i + 3 ] = &ffi_type_pointer;
    5899       argvalues[ i + 3 ] = C_temporary_stack_bottom - (i + 1);
    5900     }
    5901 
    5902     C_temporary_stack = C_temporary_stack_bottom;
    5903     status = ffi_prep_cif(&cif, FFI_DEFAULT_ABI, n + 3, &ffi_type_void, argtypes);
    5904     assert(status == FFI_OK);
    5905     ffi_call(&cif, (void *)C_block_item(fn, 0), NULL, argvalues);
    5906   }
    5907 
    5908 #elif defined(HACKED_APPLY)
     5872#ifdef C_HACKED_APPLY
    59095873  buf = alloca((n + 3) * sizeof(C_word));
    59105874  buf[ 0 ] = n + 2;
    5911   buf[ 1 ] = fn;
     5875  buf[ 1 ] = fn2;
    59125876  buf[ 2 ] = k;
    59135877  C_memcpy(&buf[ 3 ], C_temporary_stack_limit, n * sizeof(C_word));
    5914   proc = (void *)C_block_item(fn, 0);
     5878  proc = (void *)C_block_item(fn2, 0);
     5879# ifdef _MSC_VER
    59155880  __asm {
    59165881    mov eax, proc
     
    59185883    call eax
    59195884  }
    5920 #endif
    5921 
    5922   C_do_apply(n, fn, k);
     5885# elif defined(__GNUC__)
     5886  C_do_apply_hack(proc, buf, n + 3);
     5887# endif
     5888#endif
     5889
     5890  C_do_apply(n, fn2, k);
    59235891}
    59245892
     
    80378005  a = C_alloc(2 + C_bytestowords(7));
    80388006  s = C_string2(&a, "windows");
    8039 #elif defined(__unix__) || defined(C_MACOSX)
     8007#elif defined(__unix__) || defined(C_MACOSX) || defined(C_XXXBSD)
    80408008  a = C_alloc(2 + C_bytestowords(4));
    80418009  s = C_string2(&a, "unix");
  • chicken/scheduler.scm

    r4340 r5358  
    115115    ;; Put current thread on ready-queue:
    116116    (when (or (eq? cts 'running) (eq? cts 'ready)) ; should ct really be 'ready? - normally not.
     117      (##sys#setislot ct 13 #f)                    ; clear timeout-unblock flag
    117118      (##sys#add-to-ready-queue ct) )
    118119    (let loop1 ()
     
    131132                      (if (>= now tmo1)
    132133                          (begin
     134                            (##sys#setislot tto 13 #t) ; mark as being unblocked by timeout
    133135                            (##sys#thread-basic-unblock! tto)
    134136                            (loop (cdr lst)) )
     
    226228        (loop (cdr tl) tl) ) )
    227229  (##sys#setslot t 3 'blocked)
     230  (##sys#setislot t 13 #f)
    228231  (##sys#setislot t 4 tm) )
    229232
     
    234237      (##sys#setslot t2 12 (cons t (##sys#slot t2 12)))
    235238      (##sys#setslot t 3 'blocked)
     239      (##sys#setislot t 13 #f)
    236240      (##sys#setslot t 11 t2) ) ) )
    237241
     
    297301    "struct timeval timeout;"
    298302    "timeout.tv_sec = tm / 1000;"
    299     "timeout.tv_usec = tm % 1000;"
     303    "timeout.tv_usec = (tm % 1000) * 1000;"
    300304    "C_fdset_input_2 = C_fdset_input;"
    301305    "C_fdset_output_2 = C_fdset_output;"
     
    340344     (##sys#fdset-output-set fd) ) )
    341345  (##sys#setslot t 3 'blocked)
     346  (##sys#setislot t 13 #f)
    342347  (##sys#setslot t 11 (cons fd i/o)) )
    343348
     
    348353         [n (##sys#fdset-select-timeout ; we use FD_SETSIZE, but really should use max fd
    349354             (or rq? to?)
    350              (if (and to? (not rq?))
     355             (if (and to? (not rq?))    ; no thread was unblocked by timeout, so wait
    351356                 (let* ([tmo1 (caar ##sys#timeout-list)]
    352357                        [now (##sys#fudge 16)])
     
    373378                               (let* ([t (car threads)]
    374379                                      [p (##sys#slot t 11)] )
    375                                  (when (and (pair? p) (eq? fd (car p)))
     380                                 (when (and (pair? p)
     381                                            (eq? fd (car p))
     382                                            (not (##sys#slot t 13) ) ) ; not unblocked by timeout
    376383                                   (##sys#thread-basic-unblock! t) )
    377384                                 (loop2 (cdr threads)) ) ) )
  • chicken/site/index.html

    r5220 r5358  
    150150<a href="http://www.call-with-current-continuation.org/chicken-2.6.zip">chicken-2.6.zip</a> (the sources as a zip archive)<br>
    151151
    152 Latest development snapshot: <a
    153 href="http://www.call-with-current-continuation.org/chicken-2.631.tar.gz">chicken-2.631.tar.gz</a>
    154 and <a href="http://www.call-with-current-continuation.org/ChangeLog.txt">(Change log)</a>
     152Snapshots of the current development version can be found here:
     153<a href="http://chicken.wiki.br/dev-snapshots/">http://chicken.wiki.br/dev-snapshots/</a>
    155154
    156155</p>
     
    160159Browse the <a href="http://chicken.wiki.br/The User's Manual">User's manual</a> at the CHICKEN
    161160<a href="http://chicken.wiki.br/">wiki</a>
    162 </p>
    163 <p>A PDF version of the manual is available as well: <a href="chicken.pdf">chicken.pdf</a>.
    164161</p>
    165162
     
    179176<h3>DEVELOPMENT</h3>
    180177<p class="block">
    181 The current CHICKEN development version can be accessed through the <a href="http://www.darcs.net">darcs</a>
    182 and <a href="http://subversion.tigris.org">Subversion</a> revision control systems, like this:<br>
    183 <pre>
    184 $ darcs get --partial <a href="http://galinha.ucpel.tche.br/chicken">http://galinha.ucpel.tche.br/chicken</a>
    185 </pre>
    186 
     178The current CHICKEN development version can be accessed through the
     179<a href="http://subversion.tigris.org">Subversion</a> revision control system, like this:<br>
    187180<pre>
    188181$ svn co <a href="https://galinha.ucpel.tche.br/svn/chicken-eggs/chicken">https://galinha.ucpel.tche.br/svn/chicken-eggs/chicken</a>
    189182</pre>
    190183(username: <tt>anonymous</tt>, password: &lt;none&gt;)
    191 <p>See the file <tt>README.darcs</tt> for details on how to bootstrap the system.
    192184</p>
    193185
  • chicken/srfi-13.scm

    r4845 r5358  
    10571057;                               (<= 0 n (string-length s))))
    10581058;            n string-take)
    1059   (##sys#check-exact n 'string-take)
     1059  (##sys#check-string s 'string-take)
     1060  (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-take)
    10601061  (%substring/shared s 0 n))
    10611062
    10621063(define (string-take-right s n)
    10631064;  (check-arg string? s string-take-right)
    1064   (let ((len (string-length s)))
     1065  (##sys#check-string s 'string-take-right)
     1066  (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-take-right)
     1067  (let ((len (##sys#size s)))
    10651068;    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
    10661069;              n string-take-right)
    1067     (##sys#check-exact n 'string-take-right)
    10681070    (%substring/shared s (- len n) len)))
    10691071
    10701072(define (string-drop s n)
    10711073;  (check-arg string? s string-drop)
    1072   (let ((len (string-length s)))
     1074  (##sys#check-string s 'string-drop)
     1075  (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-drop)
     1076  (let ((len (##sys#size s)))
    10731077;    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
    10741078;              n string-drop)
    1075     (##sys#check-exact n 'string-drop)
    1076   (%substring/shared s n len)))
     1079    (%substring/shared s n len)))
    10771080
    10781081(define (string-drop-right s n)
    10791082;  (check-arg string? s string-drop-right)
    1080   (let ((len (string-length s)))
     1083  (##sys#check-string s 'string-drop-right)
     1084  (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-drop-right)
     1085  (let ((len (##sys#size s)))
    10811086;    (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
    10821087;              n string-drop-right)
    1083     (##sys#check-exact n 'string-drop-right)
    10841088    (%substring/shared s 0 (- len n))))
    10851089
  • chicken/tcp.scm

    r4413 r5358  
    4141  (no-bound-checks)
    4242  (export tcp-close tcp-listen tcp-connect tcp-accept tcp-accept-ready? ##sys#tcp-port->fileno tcp-listener? tcp-addresses
    43           tcp-abandon-port tcp-listener-port tcp-listener-fileno tcp-port-numbers tcp-buffer-size)
     43          tcp-abandon-port tcp-listener-port tcp-listener-fileno tcp-port-numbers tcp-buffer-size
     44          tcp-read-timeout tcp-write-timeout tcp-accept-timeout tcp-connect-timeout)
    4445  (no-procedure-checks-for-usual-bindings)
    4546  (bound-to-procedure
     
    106107    (define-macro (##sys#check-string x) '(##core#undefined))
    107108    (define-macro (##sys#check-char x) '(##core#undefined))
    108     (define-macro (##sys#check-exact x) '(##core#undefined))
     109    (define-macro (##sys#check-exact x . _) '(##core#undefined))
    109110    (define-macro (##sys#check-port x . _) '(##core#undefined))
    110111    (define-macro (##sys#check-number x) '(##core#undefined))))
     
    322323
    323324(define tcp-buffer-size (make-parameter #f))
     325(define tcp-read-timeout)
     326(define tcp-write-timeout)
     327(define tcp-connect-timeout)
     328(define tcp-accept-timeout)
     329
     330(let ()
     331  (define ((check loc) x)
     332    (when x (##sys#check-exact x loc))
     333    x)
     334  (set! tcp-read-timeout (make-parameter #f (check 'tcp-read-timeout)))
     335  (set! tcp-write-timeout (make-parameter #f (check 'tcp-write-timeout)))
     336  (set! tcp-connect-timeout (make-parameter #f (check 'tcp-connect-timeout)))
     337  (set! tcp-accept-timeout (make-parameter #f (check 'tcp-accept-timeout))) )
    324338
    325339(define ##net#io-ports
     
    340354             (outbufsize (tbs))
    341355             (outbuf (and outbufsize (fx> outbufsize 0) ""))
     356             (tmr (tcp-read-timeout))
     357             (tmw (tcp-write-timeout))
    342358             (read-input
    343359              (lambda ()
     
    346362                    (cond ((eq? -1 n)
    347363                           (cond ((eq? errno _ewouldblock)
     364                                  (when tmr
     365                                    (##sys#thread-block-for-timeout!
     366                                     ##sys#current-thread
     367                                     (fx+ (##sys#fudge 16) tmr) ) )
    348368                                  (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
    349369                                  (yield)
     370                                  (when (##sys#slot ##sys#current-thread 13)
     371                                    (##sys#signal-hook
     372                                     #:network-error
     373                                     "read operation timed out" fd) )
    350374                                  (loop) )
    351375                                 (else
     
    434458                         (n (##net#send fd s count 0)) )
    435459                    (cond ((eq? -1 n)
    436                            (if (eq? errno _ewouldblock)
    437                                (begin
    438                                  (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
    439                                  (yield)
    440                                  (loop len s) )
    441                                (begin
    442                                  (##sys#update-errno)
    443                                  (##sys#signal-hook
    444                                   #:network-error (##sys#string-append "can not write to socket - " strerror) fd) ) ) )
     460                           (cond ((eq? errno _ewouldblock)
     461                                  (when tmw
     462                                    (##sys#thread-block-for-timeout!
     463                                     ##sys#current-thread
     464                                     (fx+ (##sys#fudge 16) tmw) ) )
     465                                  (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
     466                                  (yield)
     467                                  (when (##sys#slot ##sys#current-thread 13)
     468                                    (##sys#signal-hook
     469                                     #:network-error
     470                                     "write operation timed out" fd) )
     471                                  (loop len s) )
     472                                 (else
     473                                  (##sys#update-errno)
     474                                  (##sys#signal-hook
     475                                   #:network-error
     476                                   (##sys#string-append "can not write to socket - " strerror)
     477                                   fd) ) ) )
    445478                          ((fx< n len)
    446479                           (loop (fx- len n) (##sys#substring s n (##sys#size s))) ) ) ) ) ) )
     
    482515(define (tcp-accept tcpl)
    483516  (##sys#check-structure tcpl 'tcp-listener)
    484   (let ((fd (##sys#slot tcpl 1)))
     517  (let ((fd (##sys#slot tcpl 1))
     518        (tma (tcp-accept-timeout)))
    485519    (let loop ()
    486520      (if (eq? 1 (##net#select fd))
     
    493527            (##net#io-ports fd) )
    494528          (begin
     529            (when tma
     530              (##sys#thread-block-for-timeout!
     531               ##sys#current-thread
     532               (fx+ (##sys#fudge 16) tma) ) )
    495533            (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
    496534            (yield)
     535            (when (##sys#slot ##sys#current-thread 13)
     536              (##sys#signal-hook
     537               #:network-error
     538               'tcp-accept
     539               "accept operation timed out" fd) )
    497540            (loop) ) ) ) ) )
    498541
     
    509552(define get-socket-error
    510553  (foreign-lambda* int ((int socket))
    511                    "int err, optlen;"
    512                    "optlen = sizeof(err);"
    513                    "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == -1)"
    514                    "return(-1);"
    515                    "return(err);"))
     554    "int err, optlen;"
     555    "optlen = sizeof(err);"
     556    "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == -1)"
     557    "return(-1);"
     558    "return(err);"))
    516559
    517560(define general-strerror (foreign-lambda c-string "strerror" int))
    518561
    519562(define (tcp-connect host . more)
    520   (let ((port (:optional more #f)))
     563  (let ((port (:optional more #f))
     564        (tmc (tcp-connect-timeout)))
    521565    (##sys#check-string host)
    522566    (unless port
     
    546590                (when (eq? f -1) (fail))
    547591                (unless (eq? f 1)
     592                  (when tmc
     593                    (##sys#thread-block-for-timeout!
     594                     ##sys#current-thread
     595                     (fx+ (##sys#fudge 16) tmc) ) )
    548596                  (##sys#thread-block-for-i/o! ##sys#current-thread s #:all)
    549597                  (yield)
     598                  (when (##sys#slot ##sys#current-thread 13)
     599                    (##sys#signal-hook
     600                     #:network-error
     601                     'tcp-connect
     602                     "connect operation timed out" s) )
    550603                  (loop) ) ) )
    551604            (fail) ) )
  • chicken/tests/runtests.sh

    r4340 r5358  
    55export DYLD_LIBRARY_PATH=`pwd`/..
    66export LD_LIBRARY_PATH=`pwd`/..
    7 compile="../csc -compiler ../chicken -o a.out"
     7compile="../csc -compiler ../chicken-static -o a.out"
     8
     9echo "======================================== runtime tests ..."
     10../csi -s apply-test.scm
    811
    912echo "======================================== library tests ..."
     
    3336        *)
    3437            echo $x
    35             ../csc $x -O2 -d0 -prologue plists.scm && ./`basename $x .scm` >/dev/null;;
     38            ../csc $x -compiler ../chicken-static -O2 -d0 -prologue plists.scm && ./`basename $x .scm` >/dev/null;;
    3639    esac
    3740done
  • chicken/version.scm

    r4918 r5358  
    1 (define-constant +build-version+ "2.627")
     1(define-constant +build-version+ "2.634")
Note: See TracChangeset for help on using the changeset viewer.