Changeset 3839 in project


Ignore:
Timestamp:
04/14/07 21:12:47 (14 years ago)
Author:
felix winkelmann
Message:

chicken update

Location:
chicken
Files:
39 edited

Legend:

Unmodified
Added
Removed

  • chicken/ANNOUNCE

    r3241 r3839  
    1 The CHICKEN Scheme-to-C compiler, Version 2.5 is now
     1The CHICKEN Scheme-to-C compiler, Version 2.6 is now
    22available at <http://www.call-with-current-continuation.org>.
    33
    4 Things changed since the last release (2.41):
    5 
    6 - Bugfixes
    7 - CHICKEN can now be built using CMake <http://www.cmake.org>, in fact CMake
    8   is required to built CHICKEN from sources on Windows with the Microsoft
    9   tools or mingw32
    10 - the whole build process has been cleaned up and simplified
    11 - the "easyffi" and "tinyclos" library units have been removed from the base
    12   system and are now available as separate extensions
    13 - the deprecated "set-dispatch-read-syntax!" has been removed
    14 - Will Farr cleaned up the behaviour of number-type specific numeric operations
    15   ("fx..."/"fp...") with respect to safe/unsafe mode
    16 - added "(finite? NUMBER)"
    17 - the "$" macro moved into its own separate extension
    18 - the values of "software-type", "software-version", "machine-type" and "machine-byte-order"
    19   are now registered as features and can be tested using "cond-expand" or "#+"
    20 - all tools now support the "-release" option
    21 - chicken-setup: added "-test" option
    22 
    23 Special thanks to Brandon Van Every, who put considerable effort into
    24 the CHICKEN build system and who ported it to CMake completely from
    25 scratch.  The installation instructions and build file are extensively
    26 documented and may serve as a tutorial for creating non-trivial
    27 software projects with CMake.  Thanks, Brandon! Also thanks to Bill
    28 Hoffmann and Brad King from Kitware for their support.
    29 
    30 Many thanks to Peter Bex, Toby Butzon, Thomans Chust, John Cowan,
    31 Alejandro Forero Cuervo, dgym, Alex Drummond, Mario Domenech Goulart,
    32 Kon Lovett, Benedikt Rosenau and Zbigniew Szadkowski for reporting
    33 bugs, suggesting improvements and contributing fixes.
     4Things changed since the last release (2.5):
     5
     6- Many bugfixes
     7- Better support for Sun's C compiler
     8- Input-performance has been improved
     9- PCRE (Perl compatible regular expressions) by Philip Hazel is now
     10  bundled with CHICKEN
     11- Static linking of extensions is now possible (when supported by
     12  the egg)
     13- The interpreter warns about references to potentially unbound variables
     14  in loaded code and expressions entered on the REPL
     15- The expansion process is traced during compilation and interpretation
     16  to give (slightly) more usable syntactic context in error messages
     17- library:
     18  * added `any?`, `bit-set?' and `on-exit'
     19- eval:
     20  * new procedure `set-parameterized-read-syntax!'
     21- posix:
     22  * SRFI-17 setters for `file-position`, `current-user-id',
     23    `current-group-id', `process-group-id'; the respective setter-procedures
     24    are still available but have been deprecated
     25  * `file-stat' returns more information (including device info)
     26  * added `process*'
     27- extras:
     28  * added `read-string!'
     29- utils:
     30  * `apropos' and `apropos-list' procedures
     31- srfi-4:
     32  * added `read-u8vector', `read-u8vector!' and `write-u8vector'
     33- srfi-18: 
     34  * added `time->milliseconds' and `milliseconds->time'
     35- csi:
     36  * `-ss SCRIPTNAME' option
     37- csc:
     38  * accepts options given in the environment variable `CSC_OPTIONS'
     39  * new options `-static-extensions' and `-host'
     40- chicken/csc:
     41  * new option `-keep-shadowed-macros'
     42- chicken-setup:
     43  * accepts options given in the environment variable `CHICKEN_SETUP_OPTIONS'
     44  * allows retrieval and installation of eggs from subversion repository
     45    and the local filesystem
     46  * new options `-tree FILENAME', `-svn', `-local', `-revision' and
     47    `-destdir PATHNAME'
     48  * added helper procedures `required-chicken-version' and
     49    `required-extension-version'
     50- Lots of improvements in the CMake build
     51
     52Many thanks to Ingo Bungener, Peter Busser, John Cowan, Marc Feeley,
     53Stephen Gilardi, Mario Domenech Goulart, Joshua Griffith, Sven
     54Hartrumpf, Paulo Jabardo, Daishi Kato, mejedi, Dan Muresan, Deanna
     55Phillips, Robin Lee Powell, Ivan Raikov, Danial Sadilek, Alex Shinn,
     56Tony Sideaway, Minh Thu for reporting bugs, suggesting improvements
     57and contributing fixes.
     58
     59Thanks again to Brandon Van Every for his extensive work on the CMake
     60build process.
     61
     62Special thanks to Kon Lovett for many improvements made in the posix
     63library.
    3464
    3565
    … …  
    94124  datatype debug defstruct dissector doctype dollar dpfw easyffi
    95125  eggdoc environments epeg estraier expat ezxdisp F-operator
    96   fancypants fastcgi format format-modular fp ftp futures g2 dgb gdbm
     126  fancypants fastcgi format format-modular fp ftp futures g2 gdb gdbm
    97127  generalised-case generator gettext glut gmp gtk2 gtk2-glade
    98128  gtk2-gobject hashes honu hostinfo html-plots html-stream htmlprag
    … …  
    100130  javahack job-worker jni json kanren lalr lazy-ffi levenshtein
    101131  lightning lirc-client locale logging lookup-table loop loopy-loop
    102   macosx magic mailbox make man mapm match-action matchable matcher
    103   mathh md5 meroon message-digest mime metakit metaphone misc-extn
    104   miscmacros mistie modds modules mole mpd-client mysql nbstdin
    105   ncurses numbers octave objc object-apply oblist openal opengl
    106   openssl orders packedobjects packrat patch pcap perfect-hash
     132  macosx magic mailbox make man mapm mat5-lib match-action matchable
     133  matcher mathh md5 meroon message-digest mime metakit metaphone
     134  misc-extn miscmacros mistie modds modules mole mpd-client mysql
     135  nbstdin ncurses numbers octave objc object-apply oblist openal
     136  opengl openssl orders packedobjects packrat patch pcap perfect-hash
    107137  phoghorn pipeline pmatch pop3 postgresql ppi procedure-surface
    108138  prometheus proplist protobj pty q-lang qt r6rs-libraries readline
    109139  records regex-case remote-launch remote-mailbox rfc3339 rfc822
    110140  rgraph ripemd rlimit rpc rss s11n sandbox sassy schelog
    111   scheme-dissect sdl sedna sfio sha1 sha2 silex simple-macros slib
    112   smtp softscheme spiffy spiffy-utils spread sql sqlite sqlite3
     141  scheme-dissect sdl sedna sfio sha1 sha2 silex simple-macros slang
     142  slib smtp softscheme spiffy spiffy-utils spread sql sqlite sqlite3
    113143  sqlite3-tinyclos sqlora srfi-4-comprehensions srfi-19 srfi-25
    114144  srfi-27 srfi-29 srfi-37 srfi-38 srfi-40 srfi-42 srfi-45 srfi-47
    … …  
    149179  <http://chicken.wiki.br>
    150180
    151 You might also find the CHICKEN documentation browser helpful:
     181Toby Butzon kindly provided the CHICKEN documentation browser:
    152182
    153183  <http://callcc.org>
    … …  
    162192
    163193
     194A mailing list specific to CHICKEN development and porting is
     195available at:
     196
     197  <http://mail.nongnu.org/mailman/listinfo/chicken-hackers>
     198
     199
    164200Bug and feature requests should be directed towards the CHICKEN
    165201bug tracker at:
    … …  
    171207
    172208
    173 A mailing list specific to CHICKEN development and porting is
    174 available at:
    175 
    176   <http://mail.nongnu.org/mailman/listinfo/chicken-hackers>
    177 
    178 
    179209Bug reports, suggestions and comments would be very welcome. Contact
    180210me at <felix@call-with-current-continuation.org>

  • chicken/Buildfile

    r3241 r3839  
    3030(set! MANDIR (path DESTDIR "man"))
    3131(set! OPTIM "-g")
    32 (set!+ CCFLAGS " -DHAVE_CHICKEN_CONFIG_H -DC_ENABLE_PTABLES -DC_NO_PIC_NO_DLL -fno-strict-aliasing")
     32(set!+ CCFLAGS " -DHAVE_CHICKEN_CONFIG_H -DC_ENABLE_PTABLES -fno-strict-aliasing")
    3333(set!+ LINKLIBS "-lffi -ldl -lm")
    3434(set!+ STATICLINKLIBS "-lffi -lm")
    … …  
    4545(set!? TARGET_PREFIX PREFIX)
    4646(set! TARGET_LIB_HOME (path TARGET_PREFIX "lib"))
     47(set! TARGET_RUN_LIB_HOME (path TARGET_PREFIX "lib"))
    4748(set! TARGET_INCLUDE_HOME (path TARGET_PREFIX "include"))
    4849(set! TARGET_STATIC_LIB_HOME (path TARGET_PREFIX "lib"))
    4950(set! TARGET_SHARE_HOME (path TARGET_PREFIX "share"))
     51(set! TARGET_DLL_EXTENSION "so")
    5052(set!? TARGET_CFLAGS (conc CCFLAGS " " OPTIM))
    5153
    … …  
    149151      -e "s,@C_TARGET_CFLAGS[@],\"#{TARGET_CFLAGS}\"," \
    150152      -e "s,@C_TARGET_LIB_HOME[@],\"#{TARGET_LIB_HOME}\"," \
     153      -e "s,@C_TARGET_RUN_LIB_HOME[@],\"#{TARGET_RUN_LIB_HOME}\"," \
    151154      -e "s,@C_TARGET_STATIC_LIB_HOME[@],\"#{TARGET_STATIC_LIB_HOME}\"," \
    152155      -e "s,@C_TARGET_INCLUDE_HOME[@],\"#{TARGET_INCLUDE_HOME}\"," \
    153156      -e "s,@C_TARGET_SHARE_HOME[@],\"#{TARGET_SHARE_HOME}\"," \
     157      -e "s,@C_TARGET_DLL_EXTENSION[@],\"#{TARGET_DLL_EXTENSION}\"," \
    154158      -e "s%@C_TARGET_MORE_LIBS[@]%\"#{LINKLIBS}\"%" \
    155159      -e "s%@C_TARGET_MORE_STATIC_LIBS[@]%\"#{STATICLINKLIBS}\"%" \
    … …  
    236240(cc "runtime-static.o" "runtime.c")
    237241
    238 (define (dest d)
    239   (if (->boolean ($ DESTDIR))
    240       (path DESTDIR (pathname-file d))
    241       d) )
    242 
    243 (install-bin (dest BINDIR) "chicken" "chicken-static" "csi" "csi-static" "csc" "chicken-profile" "chicken-setup")
    244 (install-bin (dest LIBDIR) (suffix SUFSHR "libchicken" "libuchicken"))
    245 (install-lib (dest LIBDIR) "libchicken.a" "libuchicken.a")
    246 (install-man (dest MANDIR) "chicken.1" "csi.1" "csc.1" "chicken-profile.1" "chicken-setup.1")
    247 (install-file (dest INCDIR) "chicken.h" "chicken-defaults.h" "chicken-config.h")
    248 (install-file (dest DOCDIR) "ChangeLog" "README" "LICENSE")
    249 (install-file (path (dest DOCDIR) "html") (glob "html/*") )
     242(install-bin BINDIR "chicken" "chicken-static" "csi" "csi-static" "csc" "chicken-profile" "chicken-setup")
     243(install-bin LIBDIR (suffix SUFSHR "libchicken" "libuchicken"))
     244(install-lib LIBDIR "libchicken.a" "libuchicken.a")
     245(install-man MANDIR "chicken.1" "csi.1" "csc.1" "chicken-profile.1" "chicken-setup.1")
     246(install-file INCDIR "chicken.h" "chicken-defaults.h" "chicken-config.h")
     247(install-file DOCDIR "ChangeLog" "README" "LICENSE")
     248(install-file (path DOCDIR "html") (glob "html/*") )
     249(install-file
     250 SHAREDIR
     251 "chicken-more-macros.scm"
     252 (map (cut make-pathname #f <> "exports")
     253      '("library" "eval" "srfi-1" "srfi-4" "srfi-13" "srfi-14" "srfi-18" "utils" "extras"
     254        "tcp" "regex" "posix" "lolevel" "scheduler") ) )
    250255
    251256(notfile "spotless")
    … …  
    318323    {cd ,sdir ";" make}
    319324    {cd ,sdir ";" make install}
    320     {cd ,idir ";" "CSI_OPTIONS= echo ,r |" bin/csi -n}
    321325    {cd ,idir ";" bin/chicken-setup -dv bloom-filter}
     326    {cd ,idir ";" "CSI_OPTIONS= echo ,r |" bin/csi -n -R bloom-filter}
    322327    {rm -fr ,sdir ,idir}
    323     {tar xfz *.tar.gz -C ,bdir}
     328    {tar xfz ,(conc "site/" tgz) -C ,bdir}
    324329    {mkdir -p ,bbdir}
    325330    {cd ,bbdir ";" cmake ,(conc "-DCMAKE_INSTALL_PREFIX=" idir) ../chicken-*}
    326331    {cd ,bbdir ";" make VERBOSE=1}
    327332    {cd ,bbdir ";" make VERBOSE=1 install}
    328     {cd ,idir ";" "CSI_OPTIONS= echo ,r |" bin/csi -n}
    329333    {cd ,idir ";" bin/chicken-setup -dv bloom-filter}
     334    {cd ,idir ";" "CSI_OPTIONS= echo ,r |" bin/csi -n -R bloom-filter}
    330335    {rm -fr ,bdir} ) )
    331336

  • chicken/CMakeLists.txt

    r3241 r3839  
    9494# non-trivial, you are probably exploring non-trivial CMake
    9595# capabilities somewhere, and backwards compatibility is not assured.
    96 
    97 CMAKE_MINIMUM_REQUIRED(VERSION 2.4.5 FATAL_ERROR)
    98 
    99 # Bugs typically show up in the current version of CMake you're using.
    100 # Then you make a bug report to http://www.kitware.com/Bug , and
    101 # often the bug gets fixed in the CVS repository.  Then you want to
    102 # verify that the bug was actually fixed.  But, you want to keep
    103 # running your old code, because the next version of CMake hasn't
    104 # shipped and you don't expect people to be compiling CMake from CVS.
    105 #
    106 # To handle this, we need to know what version of CMake we're using.
    107 # We already issue a fatal error for any CMake less than 2.4.5.
    108 # So this is sufficient for distinguishing whether we've got
    109 # CMake 2.4.5, or something greater.  We would ideally like to
    110 # make lexical comparisons on CMake version numbers, and be able
    111 # to say things like "if it's greater than version 2.x.y, do this."
    112 # But that's work to implement, and this is easy and sufficient for now.
    113 
    114 SET(IS_CMAKE_245 false)
    115 IF(CMAKE_MAJOR_VERSION EQUAL 2)
    116   IF(CMAKE_MINOR_VERSION EQUAL 4)
    117     IF(CMAKE_PATCH_VERSION EQUAL 4)
    118       SET(IS_CMAKE_245 true)
    119     ENDIF(CMAKE_PATCH_VERSION EQUAL 4)
    120   ENDIF(CMAKE_MINOR_VERSION EQUAL 4)
    121 ENDIF(CMAKE_MAJOR_VERSION EQUAL 2)
     96#
     97# Generally, the required CMake version number will be bumped up anytime
     98# there's a suspicion that CMake itself may be a source of problems.
     99# Suspicion shall be deemed sufficient, not proof.  I don't want old bug
     100# reports about problems that may have been solved already, and my time
     101# as a CMake maintainer is too scarce to be asking, "Are you using the
     102# most recent CMake?" over and over again.  Note that CMake bugs can be
     103# platform or compiler specific, so just because it works fine for you with
     104# an older version, doesn't mean it works fine for everyone else.  That
     105# said, the CMake version number won't be bumped without probable
     106# cause.
     107
     108CMAKE_MINIMUM_REQUIRED(VERSION 2.4.6 FATAL_ERROR)
    122109
    123110
    … …  
    843830ADD_DEFINITIONS(-DHAVE_CHICKEN_CONFIG_H)
    844831
    845 ADD_DEFINITIONS(-DC_NO_PIC_NO_DLL)
    846 
    847832# Compiler optimizations.  Beware that these must be
    848833# passed to C_INSTALL_CFLAGS somehow.
    … …  
    10941079SET(C_TARGET_CFLAGS ${C_INSTALL_CFLAGS})
    10951080SET(C_TARGET_LIB_HOME ${C_INSTALL_LIB_HOME})
     1081SET(C_TARGET_RUN_LIB_HOME ${C_INSTALL_LIB_HOME})
    10961082SET(C_TARGET_SHARE_HOME ${C_INSTALL_SHARE_HOME})
    10971083SET(C_TARGET_INCLUDE_HOME ${C_INSTALL_INCLUDE_HOME})
    … …  
    10991085SET(C_TARGET_MORE_LIBS ${C_INSTALL_MORE_LIBS})
    11001086SET(C_TARGET_MORE_STATIC_LIBS ${C_INSTALL_MORE_LIBS})
     1087SET(C_TARGET_DLL_EXTENSION "NULL")
    11011088SET(C_CROSS_CHICKEN 0)
    11021089

  • chicken/Makefile.am

    r3241 r3839  
    4343C_TARGET_CXX=\"@TARGET_CXX@\"
    4444C_TARGET_CFLAGS=\"@TARGET_CFLAGS@\"
     45C_TARGET_DLL_EXTENSION=@TARGET_DLL_EXTENSION@
    4546C_CROSS_CHICKEN=@CROSS_CHICKEN@
    4647
    … …  
    6263 C_TARGET_INCLUDE_HOME=\"@TARGET_PREFIX@/include\"
    6364 C_TARGET_STATIC_LIB_HOME=\"@TARGET_PREFIX@/lib\"
     65 C_TARGET_RUN_LIB_HOME=\"@TARGET_PREFIX@/lib\"
    6466else
    6567 C_TARGET_LIB_HOME=\"$(libdir)\"
    … …  
    6769 C_TARGET_INCLUDE_HOME=\"$(includedir)\"
    6870 C_TARGET_STATIC_LIB_HOME=\"$(libdir)/lib\"
     71 C_TARGET_RUN_LIB_HOME=\"$(libdir)\"
     72endif
     73
     74if USE_TARGET_RUN_PATH
     75 C_TARGET_RUN_LIB_HOME=\"@TARGET_RUN_PATH@/lib\"
    6976endif
    7077
    … …  
    129136            -e "s,@C_TARGET_CFLAGS[@],$(C_TARGET_CFLAGS)," \
    130137            -e "s,@C_TARGET_LIB_HOME[@],$(C_TARGET_LIB_HOME)," \
     138            -e "s,@C_TARGET_RUN_LIB_HOME[@],$(C_TARGET_RUN_LIB_HOME)," \
    131139            -e "s,@C_TARGET_STATIC_LIB_HOME[@],$(C_TARGET_STATIC_LIB_HOME)," \
    132140            -e "s,@C_TARGET_INCLUDE_HOME[@],$(C_TARGET_INCLUDE_HOME)," \
    133141            -e "s,@C_TARGET_SHARE_HOME[@],$(C_TARGET_SHARE_HOME)," \
     142            -e "s,@C_TARGET_DLL_EXTENSION[@],$(C_TARGET_DLL_EXTENSION)," \
    134143            -e "s,@C_STACK_GROWS_DOWNWARD[@],$(C_STACK_GROWS_DOWNWARD),g" \
    135144            -e "s,@C_CROSS_CHICKEN[@],$(C_CROSS_CHICKEN),g" \
    … …  
    295304  chicken-ffi-macros.scm library.exports eval.exports srfi-1.exports srfi-4.exports \
    296305  srfi-13.exports srfi-14.exports srfi-18.exports utils.exports extras.exports \
    297   eval.exports tcp.exports regex.exports posix.exports lolevel.exports scheduler.exports
     306  tcp.exports regex.exports posix.exports lolevel.exports scheduler.exports
    298307
    299308# Install docs and sources.

  • chicken/NEWS

    r3156 r3839  
    112.52
    22
    3 - Mountains of bugfixes
     3- Many bugfixes
    44- Better support for Sun's C compiler
    55- Input-performance has been improved

  • chicken/README

    r3241 r3839  
    33  (c)2000-2007 Felix L. Winkelmann
    44
    5   Version 2.6rc1
     5  Version 2.610
    66
    77
    … …  
    252252
    253253        If you have any more questions or problems (even the slightest
    254         problems, or the most stupid questions), then please contact
    255         me at:
     254        problems, or the most stupid questions), then please subscribe
     255        to the CHICKEN mailing list or contact me at:
    256256
    257257        <felix@call-with-current-continuation.org>.

  • chicken/TODO

    r1403 r3839  
    1 TODO list for Chicken                                                           -*- Outline -*-
    2 
    3 
    4 * creating lots of threads (1000) + repl seems to hang - something's wrong in the
    5   scheduler (situation: primordial blocked for I/O and others ready)
    6 
    7 * ##core#global-ref should warn on unexported variable
    8 
    9 * Some solution for embedding stringified non-standard literals in compiled code
    10 
    11 * eval: ##core#named-lambda could use name for lambda-decoration
    12 
    13 * remove deprecated features
    14 
    15 * inline-defs for generated accessors in define-record and define-record-type [Benedikt]
    16   (or option/declaration `-inline-record-accessors' ?)
    17 
    18 * foreign-types
    19 ** `string-list': NULL-terminated array of C-strings
    20 
    21 * csi: stop canonicalizing options even if "-s" is collapsed with other options
    22 
    23 * macroexpander: `me' (macroenvironment) - is not really needed anymore.
    24 
    25 * a `read-string' primitive port-method would probably speed up input considerably...
    26 
    27 * hen.el
    28 ** `#| ... |#' colored as comment would be nice
    29 ** properly colored `(define ((...' would be nice as well
    30 
    31 * reader
    32 ** more speed
    33 ** #/.../ (regexps) ?, or "#rx<delim>...<delim>" ?
    34 ** PLT's (X . OP . Y) ?
    35 
    36 * chicken-setup
    37 ** `-uninstall' doesn't remove executables (their names are registered nowhere)
    38 
    39 * manual
    40 ** example for C_gc_protect()
    41 ** document class-linerization
    42 
    43 * Can we implement a size-independent wchar_t foreign type?
    44 
    45 * runtime
    46 ** Better info for platforms where dload isn't supported
    47 ** check finalizers using a different method than interrupts? [Suggested by Bruce Hoult]
    48 ** better overflow-detection for fixnum plus/minus (see "Hacker's Delight")
    49 ** possible bug: free() of malloc'd blocks that have been aligned (like `tospace_start')
    50 ** random scatter hash-func (cii book) ?
    51 ** printf-style function for building (permanent) data structures
    52 
    53 * regexes
    54 ** [PCRE] should `regexp' use `pcre_study()'? (benchmark)
    55 ** bundle PCRE
    56 
    57 * Compiler
    58 ** speed up closure conversion
    59 ** warn if undefined globals are declared hidden [Peter Wang]
    60 ** explicit rest-consing with (##core#inline_allocate "C_a_i_list" ...) is unneeded if the restvar is never used
    61 ** gen-lit and friends do not check tmpstack overflow
    62 ** gen-lit (and friends) could generate better code for lists with immediate items
    63 ** setter-optimization for `let' doesn't work with nallch, why?
    64 
    65 * Optimizations
    66 ** hashing of case-values?
    67 ** compile-time format-string checks?
    68 ** lexical refs/assigns could be cached in local variables
    69 ** Treat ids in inline-declarations as known, but inhibit customization/argument dropping
    70 
    71 * FFI
    72 ** optional args?
    73 ** This fails:
    74 void XML_SetStartElementHandler(struct XML_ParserStruct *p, void (*)(void *, const char *name, const char **attrs));
    75 (cast omits first "const" specifier)
    76 
    77 * tcp
    78 ** reverse DNS lookup (gethostbyaddr)
    79 
    80 * lolevel
    81 [procedure] (object-traverse X PROC)
    82 [parameter] byte-vector-allocator -> bytes -> X         (uses by SRFI-4 as well)
    83 
    84 * TinyCLOS
    85 ** this bombs with -block (reported by Benedikt), probably caused by ##core#global-ref:
    86 (declare (uses tinyclos))
    87 
    88 (define-method (print-bool (b <boolean>))
    89   (display (if b "true\n" "false\n")))
    90 
    91 
    92 (define-class <toggle> ()
    93   (state))
    94 
    95 (define-class <nth-toggle> (<toggle>)
    96   (count-max counter))
    97 
    98 
    99 (define-method (initialize (t <toggle>) initargs)
    100   (call-next-method)
    101   (initialize-slots t initargs))
    102 
    103 (define-method (initialize (n-t <nth-toggle>) initargs)
    104   (call-next-method)
    105   (initialize-slots n-t initargs)
    106   (slot-set! n-t 'counter 0))
    107 
    108 
    109 (define-method (activate! (t <toggle>))
    110   (slot-set! t 'state (not (slot-ref t 'state)))
    111   t)
    112 
    113 (define-method (activate! (n-t <nth-toggle>))
    114   (let ((counter (+ 1 (slot-ref n-t 'counter))))
    115     (slot-set! n-t 'counter counter)
    116     (if (>= counter (slot-ref n-t 'count-max))
    117       (begin (slot-set! n-t 'state (not (slot-ref n-t 'state)))
    118              (slot-set! n-t 'counter 0)))
    119     n-t))
    120 
    121 (define-method (value? (t <toggle>))
    122   (slot-ref t 'state))
    123 
    124 
    125   (let ((ntog (make <nth-toggle> 'state #t 'count-max 3)))
    126     (do ((i 0 (+ i 1))) ((= i 8))
    127          (print-bool (value? (activate! ntog)))))
    128 
    129 * Platforms
    130 ** may `regparm' attribute be a problem on some machines? (as suggested by gcc 3.4 docs)
    131 ** add Hans Hübner's ecos patches

  • chicken/batch-driver.scm

    r3156 r3839  
    5656  broken-constant-nodes inline-substitutions-enabled
    5757  emit-profile profile-lambda-list profile-lambda-index profile-info-vector-name
    58   direct-call-ids foreign-type-table first-analysis emit-closure-info emit-line-info
     58  direct-call-ids foreign-type-table first-analysis emit-closure-info
    5959  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database scan-toplevel-assignments
    6060  perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization!
    … …  
    240240    (when (memq 'emit-external-prototypes-first options) (set! external-protos-first #t))
    241241    (when (memq 'inline options) (set! inline-max-size default-inline-max-size))
    242     (when (memq 'track-scheme options) (set! emit-line-info #t))
    243242    (and-let* ([inlimit (memq 'inline-limit options)])
    244243      (set! inline-max-size
    … …  
    394393                                     (map string->expr postlude) ) ) )
    395394                        (let* ((f (car files))
    396                                (in (check-and-open-input-file f))
    397                                (x1 (read-form in)) )
    398                           (do ((x x1 (read-form in)))
    399                               ((eof-object? x)
    400                                (close-checked-input-file in f) )
    401                             (set! forms (cons x forms)) ) ) ) ] ) ) )
     395                               (in (check-and-open-input-file f)) )
     396                          (fluid-let ((##sys#current-source-filename f))
     397                            (let ((x1 (read-form in)) )
     398                              (do ((x x1 (read-form in)))
     399                                  ((eof-object? x)
     400                                   (close-checked-input-file in f) )
     401                                (set! forms (cons x forms)) ) ) ) ) ) ] ) ) )
    402402
    403403           ;; Start compilation passes:

  • chicken/build.scm

    r3241 r3839  
    1 (define-constant +build-version+ "2.6rc1")
     1(define-constant +build-version+ "2.610")

  • chicken/buildversion

    r3241 r3839  
    1 2.6rc1
     12.610

  • chicken/c-backend.scm

    r3241 r3839  
    5454  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants
    5555  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    56   mutable-constants emit-line-info
     56  mutable-constants
    5757  broken-constant-nodes inline-substitutions-enabled
    5858  direct-call-ids foreign-type-table first-analysis block-variable-literal?
    … …  
    298298                    (fn (car subs)) )
    299299               (when name
    300                  (when emit-line-info
    301                    (match name
    302                      ((file (? number? ln) _)
    303                       (gen #t "#line " ln " \"" (slashify file) "\"") )
    304                      (_ #f) ) )
    305300                 (if emit-trace-info
    306301                     (gen #t "C_trace(\"" (slashify name-str) "\");")
    … …  
    11621157            ns]
    11631158           [(float double c-pointer unsigned-integer unsigned-integer32 long integer integer32 unsigned-long
    1164                    nonnull-c-pointer number integer64)
     1159                   nonnull-c-pointer number integer64 c-string-list c-string-list*)
    11651160            (string-append ns "+3") ]
    1166            [(c-string c-string*)
     1161           [(c-string c-string* unsigned-c-string unsigned-c-string unsigned-c-string*)
    11671162            (string-append ns "+2+(" var "==NULL?1:C_bytestowords(C_strlen(" var ")))") ]
    1168            [(nonnull-c-string nonnull-c-string* symbol)
     1163           [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string nonnull-unsigned-c-string* symbol)
    11691164            (string-append ns "+2+C_bytestowords(C_strlen(" var "))") ]
    11701165           [else
    … …  
    12241219    (case type
    12251220      [(scheme-object) (str "C_word")]
    1226       [(char byte) (str "char")]
    1227       [(unsigned-char unsigned-byte) (str "unsigned char")]
     1221      [(char byte) (str "C_char")]
     1222      [(unsigned-char unsigned-byte) (str "unsigned C_char")]
    12281223      [(unsigned-int unsigned-integer) (str "unsigned int")]
    12291224      [(unsigned-int32 unsigned-integer32) (str "C_u32")]
    … …  
    12381233      [(double number) (str "double")]
    12391234      ;; pointer and nonnull-pointer are DEPRECATED
    1240       [(pointer nonnull-pointer c-pointer nonnull-c-pointer scheme-pointer nonnull-scheme-pointer)
     1235      [(pointer nonnull-pointer c-pointer nonnull-c-pointer scheme-pointer
     1236                nonnull-scheme-pointer)
    12411237       (str "void *")]
     1238      [(c-string-list c-string-list*) "C_char **"]
    12421239      [(byte-vector nonnull-byte-vector u8vector nonnull-u8vector) (str "unsigned char *")]
    12431240      [(u16vector nonnull-u16vector) (str "unsigned short *")]
    … …  
    12481245      [(f32vector nonnull-f32vector) (str "float *")]
    12491246      [(f64vector nonnull-f64vector) (str "double *")]
    1250       [(nonnull-c-string c-string nonnull-c-string* c-string* symbol) (str "char *")]
     1247      [(nonnull-c-string c-string nonnull-c-string* c-string*
     1248                         nonnull-unsigned-c-string nonnull-unsigned-c-string*
     1249                         symbol) (str "char *")]
    12511250      [(void) (str "void")]
    12521251      [else
    … …  
    13331332      ((f64vector) "C_c_f64vector_or_null(")
    13341333      ((nonnull-f64vector) "C_c_f64vector(")
    1335       ((c-string c-string*) "C_string_or_null(")
    1336       ((nonnull-c-string nonnull-c-string* symbol) "C_c_string(")
     1334      ((c-string c-string* unsigned-c-string unsigned-c-string*) "C_string_or_null(")
     1335      ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string
     1336                         nonnull-unsigned-c-string* symbol) "C_c_string(")
    13371337      ((bool) "C_truep(")
    13381338      (else
    … …  
    13691369      ((float double integer64) (sprintf "C_flonum(&~a," dest)) ;*** suboptimal for int64
    13701370      ((number) (sprintf "C_number(&~a," dest))
    1371       ((nonnull-c-string c-string nonnull-c-pointer c-string* nonnull-c-string* symbol)
     1371      ((nonnull-c-string c-string nonnull-c-pointer c-string* nonnull-c-string*
     1372                         unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string
     1373                         nonnull-unsigned-c-string* symbol c-string-list c-string-list*)
    13721374       (sprintf "C_mpointer(&~a,(void*)" dest) )
    13731375      ((c-pointer) (sprintf "C_mpointer_or_false(&~a,(void*)" dest))

  • chicken/c-platform.scm

    r3241 r3839  
    128128    lambda-lift run-time-macros tag-pointers accumulate-profile
    129129    disable-stack-overflow-checks disable-c-syntax-checks unsafe-libraries raw
    130     emit-external-prototypes-first track-scheme release
     130    emit-external-prototypes-first release
    131131    analyze-only dynamic extension) )
    132132

  • chicken/chicken-defaults.h.in

    r3241 r3839  
    6060# define C_TARGET_LIB_HOME @C_TARGET_LIB_HOME@
    6161#endif
     62#ifndef C_TARGET_RUN_LIB_HOME
     63# define C_TARGET_RUN_LIB_HOME @C_TARGET_RUN_LIB_HOME@
     64#endif
    6265#ifndef C_TARGET_SHARE_HOME
    6366# define C_TARGET_SHARE_HOME @C_TARGET_SHARE_HOME@
    … …  
    6972# define C_TARGET_STATIC_LIB_HOME @C_TARGET_STATIC_LIB_HOME@
    7073#endif
     74#ifndef C_TARGET_DLL_EXTENSION
     75# define C_TARGET_DLL_EXTENSION @C_TARGET_DLL_EXTENSION@
     76#endif

  • chicken/chicken-more-macros.scm

    r3241 r3839  
    123123          ,@(with-input-from-file path
    124124              (lambda ()
    125                 (do ([x (read) (read)]
    126                      [xs '() (cons x xs)] )
    127                     ((eof-object? x)
    128                      (reverse xs))) ) ) ) ) ) ) )
     125                (fluid-let ((##sys#current-source-filename path))
     126                  (do ([x (read) (read)]
     127                       [xs '() (cons x xs)] )
     128                      ((eof-object? x)
     129                       (reverse xs))) ) ) ) ) ) ) ) )
    129130
    130131(##sys#register-macro

  • chicken/chicken-setup.scm

    r3241 r3839  
    4444          create-directory test-compile try-compile copy-file run-verbose
    4545          required-chicken-version required-extension-version
    46           cross-chicken) )
     46          cross-chicken ##sys#current-source-filename) )
    4747
    4848#>
    … …  
    530530    (set! *temporary-directory* tmpdir) ) )
    531531
    532 (define (copy-file from to)
     532(define (copy-file from to #!optional (err #t))
    533533  (let ((from (if (pair? from) (car from) from))
    534534        (to (if (pair? from) (make-pathname to (cadr from)) to)) )
    535535    (ensure-directory to)
    536     (run (,*copy-command* ,(quotewrap from) ,(quotewrap to)) ) ) )
     536    (cond ((file-exists? from)
     537           (run (,*copy-command* ,(quotewrap from) ,(quotewrap to))) )
     538          (err (error "file does not exist" from))
     539          (else (warning "file does not exist" from)))))
    537540
    538541(define (move-file from to)
    … …  
    586589                         (let ((from (if (pair? f) (car f) f))
    587590                               (to (make-dest-pathname rpathd f)) )
    588                            (when (and (not *windows*) (equal? "so" (pathname-extension to)))
     591                           (when (and (not *windows*)
     592                                      (equal? "so" (pathname-extension to)))
    589593                             (run (,*remove-command* ,to)) )
    590594                           (copy-file from to)
    … …  
    593597                           (and-let* ((static (assq 'static info)))
    594598                             (when (and (eq? (software-version) 'macosx)
    595                                         (equal? (cadr static) from) )
     599                                        (equal? (cadr static) from)
     600                                        (equal? (pathname-extension to) "a"))
    596601                               (run (ranlib ,to)) ) )
    597602                           (make-dest-pathname rpath f)))
    … …  
    602607          (for-each
    603608           (lambda (f)
    604              (if (file-exists? f)
    605                  (copy-file f (make-pathname docpath f))
    606                  (print "Warning: file " f " doesn't seem to exist") )
    607              (print "  * " <>) (cdr docs))
    608            (newline)
    609            (set! *rebuild-doc-index* #t)) ) )
     609             (copy-file f (make-pathname docpath f) #f) )
     610           (cdr docs))
     611          (newline)
     612          (set! *rebuild-doc-index* #t)) )
    610613      (and-let* ((exs (assq 'examples info)))
    611614        (print "\n* Installing example files in " *example-directory* ":")
    612615        (for-each
    613616         (lambda (f)
    614            (copy-file f (make-pathname *example-directory* f))
     617           (copy-file f (make-pathname *example-directory* f) #f)
    615618           (unless *windows-shell*
    616                    (run (chmod a+rx ,*example-directory*)))
    617 
    618            (print "  * " f) )
     619             (run (chmod a+rx ,*example-directory*))) )
    619620         (cdr exs))
    620621        (newline) )
    … …  
    959960  (make-pathname (repo-path ddir?) "index.html"))
    960961
     962(define (doc-stylesheet #!optional ddir?)
     963  (make-pathname (repo-path ddir?) "style.css"))
     964
    961965(define (extension-documented? rpath fn)
    962966  (let ([pn (make-setup-info-pathname fn rpath)])
    … …  
    972976  (let ((rpath (repository-path))
    973977        (hn (get-host-name)))
     978    (with-output-to-file (doc-stylesheet)
     979      (lambda () (display #<<EOF
     980body, html {
     981  color: #000;
     982  background-color: #fff;
     983  font: 9pt "Lucida Grande", "Verdana", sans-serif;
     984  line-height: 1.6;
     985  margin: 0;
     986  padding: 0;
     987}
     988
     989a {
     990    color: #669;
     991    text-decoration: none;
     992}
     993a:visited { color: #555; }
     994a:active  { color: #966; }
     995a:hover   { color: #bbd; }
     996
     997#title {
     998    border-bottom: 1px solid #669;
     999    background-color: #669;
     1000    margin: 0;
     1001    padding: 0 3em 0.2em;
     1002    float: left;
     1003    color: #fff;
     1004}
     1005
     1006#install-info {
     1007    clear: left;
     1008    padding: 1em;
     1009}
     1010
     1011#official-index {
     1012    padding: 1em;
     1013    float: right;
     1014}
     1015
     1016#egg-index {
     1017    width: 60%;
     1018    margin: auto;
     1019    border-spacing: 0;
     1020}
     1021
     1022/* Everything but the first one is aligned right */
     1023#egg-index tr > * {
     1024    text-align: left;
     1025}
     1026
     1027#egg-index tr > * + * {
     1028    text-align: right;
     1029}
     1030
     1031#egg-index a {
     1032    display: block;
     1033}
     1034
     1035thead tr {
     1036    color: #fff;
     1037    background-color: #669;
     1038}
     1039
     1040th {
     1041    padding: 0.1em 1em 0.3em;
     1042}
     1043
     1044td {
     1045    padding: 0.3em 1em;
     1046}
     1047
     1048tr.even {
     1049    background-color: #eee;
     1050}
     1051tr {
     1052    background-color: white;
     1053}
     1054EOF
     1055                          )))
    9741056    (with-output-to-file (doc-index)
    9751057      (lambda ()
    976         (printf "<html><head><title>Egg documentation index for ~a</title></head>~%" hn)
    977         (printf "<body><font size=\"-1\"><p style=\"text-align: right\"><i><a href=\"http://www.call-with-current-continuation.org/eggs/index.html\">Visit the official egg index</a></i></p></font>~%")
    978         (printf "<font face='Arial, Helvetica'><h1>Egg documentation index:</h1>~%")
    979         (printf "<p>CHICKEN: ~a<br>Host: ~a<br>Repository path: ~a<br><p>~%"
     1058        (printf "<html><head><title>Egg documentation index for ~a</title><link rel=\"stylesheet\" type=\"text/css\" href=\"style.css\"/></head>~%" hn)
     1059        (printf "<body><a id=\"official-index\" href=\"http://www.call-with-current-continuation.org/eggs/index.html\">Visit the official egg index</a>~%")
     1060        (printf "<h1 id=\"title\">Egg documentation index:</h1>~%")
     1061        (printf "<p id=\"install-info\">CHICKEN: ~a<br>Host: ~a<br>Repository path: ~a<br><p>~%"
    9801062                (chicken-version #t)
    9811063                (get-host-name)
    9821064                rpath)
    983         (display "<center><table border='0' width='70%' cellpadding='3' cellspacing='0'>\n")
     1065        (printf "<table id=\"egg-index\">~%")
     1066        (printf "<thead><tr><th>Egg name</th><th>Version</th><th>Release</th></tr></thead>~%<tbody>~%")
    9841067        (let ((c 0))
    9851068          (for-each
    9861069           (lambda (f)
    9871070             (and-let* ((info (extension-information f)))
    988                (printf "<tr style='background-color: #~a'><td>" (if (odd? c) "ffffff" "c6eff7"))
     1071               (printf "<tr~a><td>" (if (even? c) " class=\"even\"" ""))
    9891072               (set! c (add1 c))
    9901073               (let ((doc (assq 'documentation info)))
    … …  
    9921075                     (printf "<a href=\"~a\">~a</a>" (cadr doc) f)
    9931076                     (display f) )
    994                  (display "</td><td align='right'>")
    995                  (and-let* ((v (assq 'version info)))
    996                    (printf "Version: ~A" (cadr v)) )
    997                  (and-let* ((r (assq 'release info)))
    998                    (printf " Release: ~a" (cadr r)))
    999                  (display "</td></tr>\n") ) ) )
     1077                 (printf "</td>~%")
     1078                 (printf "<td>~A</td>" (car (alist-ref 'version info eq? '(""))))
     1079                 (printf "<td>~A</td>" (car (alist-ref 'release info eq? '(""))))
     1080                 (printf "</tr>~%") ) ) )
    10001081           (delete-undocumented-extensions
    10011082            rpath
    … …  
    10031084                   (grep "^[^.].*\\.*$" (map pathname-file (directory rpath))) string=?)
    10041085                  string<?) ) )
    1005           (display "</table></center></body></font></html>\n") ) ) ) ) )
     1086          (display "</tbody></table></body></font></html>\n") ) ) ) ) )
    10061087
    10071088(define (format-string str cols #!optional right (padc #\space))

  • chicken/chicken.h

    r3241 r3839  
    7878#define C_externimport             C_extern
    7979#define C_externexport             C_extern
    80 #if !(defined(C_NO_PIC_NO_DLL) && !defined(PIC))
     80#if defined(PIC)
    8181# if defined(__CYGWIN__) || defined(__MINGW32__)
    8282#  ifndef C_BUILDING_LIBCHICKEN
    … …  
    10781078C_varextern C_TLS void (C_fcall *C_restart_trampoline)(void *proc) C_regparm C_noret;
    10791079C_varextern C_TLS void (*C_post_gc_hook)(int mode);
     1080C_varextern C_TLS void (*C_panic_hook)(C_char *msg);
    10801081
    10811082C_varextern C_TLS int

  • chicken/compiler.scm

    r3033 r3839  
    7878; (keep-shadowed-macros)
    7979; (import <symbol-or-string> ...)
     80; (unused <symbol> ...)
    8081;
    8182;   <type> = fixnum | generic
    … …  
    276277  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub
    277278  expand-foreign-lambda* data-declarations emit-control-file-item expand-foreign-primitive
    278   process-declaration external-protos-first basic-literal? emit-line-info
     279  process-declaration external-protos-first basic-literal?
    279280  transform-direct-lambdas! expand-foreign-callback-lambda* debugging emit-unsafe-marker
    280281  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
    … …  
    286287  pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
    287288  topological-sort print-version print-usage initialize-analysis-database export-list csc-control-file
    288   estimate-foreign-result-location-size compressed-literals-initializer
     289  estimate-foreign-result-location-size compressed-literals-initializer unused-variables
    289290  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
    290291  units-used-by-default words-per-flonum disable-stack-overflow-checking
    … …  
    374375(define inline-max-size -1)
    375376(define emit-closure-info #t)
    376 (define emit-line-info #f)
    377377(define export-file-name #f)
    378378(define import-table #f)
    … …  
    430430(define file-requirements #f)
    431431(define postponed-initforms '())
     432(define unused-variables '())
    432433
    433434
    … …  
    476477      [x x] ) )
    477478
     479  (define (resolve-atom x ae me dest)
     480    (cond [(and constants-used (##sys#hash-table-ref constant-table x))
     481           => (lambda (val) (walk (car val) ae me dest)) ]
     482          [(and inline-table-used (##sys#hash-table-ref inline-table x))
     483           => (lambda (val) (walk val ae me dest)) ]
     484          [(assq x foreign-variables)
     485           => (lambda (fv)
     486                (let* ([t (second fv)]
     487                       [ft (final-foreign-type t)]
     488                       [body `(##core#inline_ref (,(third fv) ,t))] )
     489                  (foreign-type-convert-result
     490                   (finish-foreign-result ft body)
     491                   t) ) ) ]
     492          [(assq x location-pointer-map)
     493           => (lambda (a)
     494                (let* ([t (third a)]
     495                       [ft (final-foreign-type t)]
     496                       [body `(##core#inline_loc_ref (,t) ,(second a))] )
     497                  (foreign-type-convert-result
     498                   (finish-foreign-result ft body)
     499                   t) ) ) ]
     500          [else #f] ) )
     501
    478502  (define (walk x ae me dest)
    479503    (cond ((symbol? x)
    480            (cond [(assq x ae)
    481                   => (lambda (n)
    482                        (walk (##sys#macroexpand-1-local (cdr n) me) ae me dest) ) ]
    483                  [(and constants-used (##sys#hash-table-ref constant-table x))
    484                   => (lambda (val) (walk (car val) ae me dest)) ]
    485                  [(and inline-table-used (##sys#hash-table-ref inline-table x))
    486                   => (lambda (val) (walk val ae me dest)) ]
    487                  [(assq x foreign-variables)
    488                   => (lambda (fv)
    489                        (let* ([t (second fv)]
    490                               [ft (final-foreign-type t)]
    491                               [body `(##core#inline_ref (,(third fv) ,t))] )
    492                          (foreign-type-convert-result
    493                           (finish-foreign-result ft body)
    494                           t) ) ) ]
    495                  [(assq x location-pointer-map)
    496                   => (lambda (a)
    497                        (let* ([t (third a)]
    498                               [ft (final-foreign-type t)]
    499                               [body `(##core#inline_loc_ref (,t) ,(second a))] )
    500                          (foreign-type-convert-result
    501                           (finish-foreign-result ft body)
    502                           t) ) ) ]
    503                  [else x] ) )
     504           (cond ((assq x ae) =>
     505                  (lambda (a)
     506                    (let ((alias (cdr a)))
     507                      (or (resolve-atom alias ae me dest)
     508                          alias) ) ) )
     509                 ((resolve-atom x ae me dest))
     510                 (else (##sys#alias-global-hook x))) )
    504511          ((and (not-pair? x) (constant? x)) `(quote ,x))
    505512          ((not-pair? x) (syntax-error "illegal atomic form" x))
    … …  
    668675                                [ln (get-line x)]
    669676                                [val (walk (caddr x) ae me var0)] )
    670                            (when (and safe-globals-flag (eq? var var0))
    671                              (set! always-bound-to-procedure
    672                                (lset-adjoin eq? always-bound-to-procedure var))
    673                              (set! always-bound (lset-adjoin eq? always-bound var)) )
    674677                           (when (eq? var var0) ; global?
     678                             (set! var (##sys#alias-global-hook var))
     679                             (when safe-globals-flag
     680                               (set! always-bound-to-procedure
     681                                 (lset-adjoin eq? always-bound-to-procedure var))
     682                               (set! always-bound (lset-adjoin eq? always-bound var)) )
    675683                             (when (macro? var)
    676684                               (compiler-warning
    … …  
    910918                                            `(let ()
    911919                                               ,@(match rtype
    912                                                    ((or '(const nonnull-c-string) 'nonnull-c-string)
     920                                                   ((or '(const nonnull-c-string)
     921                                                        '(const nonnull-unsigned-c-string)
     922                                                        'nonnull-unsigned-c-string
     923                                                        'nonnull-c-string)
    913924                                                    `((##sys#make-c-string (let () ,@(cddr lam)))))
    914                                                    ((or '(const c-string*) 'c-string*)
     925                                                   ((or '(const c-string*)
     926                                                        '(const unsigned-c-string*)
     927                                                        'unsigned-c-string*
     928                                                        'c-string*
     929                                                        'c-string-list
     930                                                        'c-string-list*)
    915931                                                    (syntax-error
    916                                                      "`c-string*' is not a valid result type for callback procedures"
     932                                                     "not a valid result type for callback procedures"
     933                                                     rtype
    917934                                                     name) )
    918                                                    ((or 'c-string '(const c-string))
     935                                                   ((or 'c-string
     936                                                        '(const unsigned-c-string)
     937                                                        'unsigned-c-string
     938                                                        '(const c-string))
    919939                                                    `((let ((r (let () ,@(cddr lam))))
    920940                                                        (and r (##sys#make-c-string r)) ) ) )
    … …  
    10861106       ((separate) (set! block-compilation #f))
    10871107       ((keep-shadowed-macros) (set! undefine-shadowed-macros #f))
     1108       ((unused)
     1109        (set! unused-variables (append (cdr spec) unused-variables)))
    10881110       ((not)
    10891111        (check-decl spec 1)
    … …  
    16421664         ;; If this is the first analysis and the variable is global and has no references and we are
    16431665         ;;  in block mode, then issue warning:
    1644          (when (and first-analysis global (null? references))
     1666         (when (and first-analysis
     1667                    global
     1668                    (null? references)
     1669                    (not (memq sym unused-variables)))
    16451670           (when assigned-locally
    16461671             (compiler-warning 'var "local assignment to unused variable `~S' may be unintended" sym) )

  • chicken/configure.in

    r3241 r3839  
    215215fi
    216216
    217 CFLAGS="$CFLAGS -DC_NO_PIC_NO_DLL"
    218217AC_MSG_RESULT($CFLAGS)
    219218
    … …  
    262261
    263262AC_SUBST(TARGET_CFLAGS)
    264 
    265263AM_CONDITIONAL(USE_TARGET_PREFIX, [test "$TARGET_PREFIX" != ""])
    266264AC_SUBST(TARGET_PREFIX)
     265AM_CONDITIONAL(USE_TARGET_RUN_PATH, [test "$TARGET_RUN_PATH" != ""])
     266AC_SUBST(TARGET_RUN_PATH)
    267267
    268268AM_CONDITIONAL(USE_TARGET_MORE_LIBS, [test "$TARGET_MORE_LIBS" != ""])
    … …  
    270270AM_CONDITIONAL(USE_TARGET_MORE_STATIC_LIBS, [test "$TARGET_MORE_STATIC_LIBS" != ""])
    271271AC_SUBST(TARGET_MORE_STATIC_LIBS)
     272
     273if test "$TARGET_DLL_EXTENSION" = ""; then
     274  TARGET_DLL_EXTENSION="NULL"
     275fi
     276
     277AC_SUBST(TARGET_DLL_EXTENSION)
    272278
    273279dnl Checking for generating "...-static" executables.

  • chicken/csc-trans

    r2769 r3839  
    1010# check for options
    1111COLOR="--color"
    12 MODE=ansi
     12MODE=""
    1313OUTPUT=-
    1414ALL=0
    … …  
    1616   case $opt in
    1717      a ) ALL="1";;
    18       h ) MODE="html";;
    19       p ) MODE="PostScript";;
    20       r ) MODE="rtf";;
     18      h ) MODE="--language=html";;
     19      p ) MODE="--language=PostScript";;
     20      r ) MODE="--language=rtf";;
    2121      t ) NOENSCRIPT="1";;
    2222      c ) COLOR="";; # disable color (on by default)
    … …  
    4646fi
    4747if type $ENSCRIPT >/dev/null 2>&1; then
    48   PASS3="$ENSCRIPT $ENSCRIPT_OPTS --language=$MODE $COLOR -o $OUTPUT"
     48  PASS3="$ENSCRIPT $ENSCRIPT_OPTS $MODE $COLOR -o $OUTPUT"
    4949else
    5050  PASS3=cat
    … …  
    6060  $CSC $CSC_OPTS $FILE |\
    6161  perl -an000e 'print if /C_trace/&&!/##sys#implicit/ || (/\/\* [-!%\w]+ in k\d+ / && ! /\/\* k\d+ /)' |\
    62   $PASS2 2>/dev/null | $PASS3 2>/dev/null
     62  $PASS2 | $PASS3
    6363fi

  • chicken/csc.scm

    r3033 r3839  
    7272# define C_TARGET_SHARE_HOME  C_INSTALL_SHARE_HOME
    7373#endif
     74
     75#ifndef C_TARGET_RUN_LIB_HOME
     76# define C_TARGET_RUN_LIB_HOME    C_TARGET_LIB_HOME
     77#endif
     78
     79#ifndef C_TARGET_DLL_EXTENSION
     80# define C_TARGET_DLL_EXTENSION    NULL
     81#endif
    7482<#
    7583
    … …  
    94102(define-foreign-variable TARGET_INCLUDE_HOME c-string "C_TARGET_INCLUDE_HOME")
    95103(define-foreign-variable TARGET_STATIC_LIB_HOME c-string "C_TARGET_STATIC_LIB_HOME")
     104(define-foreign-variable TARGET_RUN_LIB_HOME c-string "C_TARGET_RUN_LIB_HOME")
     105(define-foreign-variable TARGET_DLL_EXTENSION c-string "C_TARGET_DLL_EXTENSION")
    96106
    97107
    … …  
    168178      (define compile-output-flag "-o ")
    169179      (define nonstatic-compilation-options '())
    170       (define shared-library-extension (cond ((or cygwin mingw) "dll")
    171                                              ;(hpux-hppa "sl")
    172                                              (else "so")))))
     180      (define shared-library-extension
     181        (let ()
     182          (define (getext)
     183            (cond ((or cygwin mingw) "dll")
     184                  ;;((hpux) "sl")
     185                  (else ##sys#load-dynamic-extension) ) )
     186          (if host-mode
     187              (or TARGET_DLL_EXTENSION (getext))
     188              (getext))))))
    173189
    174190(define default-translation-optimization-options '())
    … …  
    353369  (if win
    354370      (if (not cmake-build)
    355           (cons* "/I%CHICKEN_HOME%" "/DC_NO_PIC_NO_DLL" (if (eq? (c-runtime) 'dynamic) '("/MD") '()))
     371          (cons* "/I%CHICKEN_HOME%" (if (eq? (c-runtime) 'dynamic) '("/MD") '()))
    356372          (cons* (string-append
    357373                  "/I"
    358374                  (if host-mode INSTALL_INCLUDE_HOME TARGET_INCLUDE_HOME)
    359                  "/DC_NO_PIC_NO_DLL" (if (eq? (c-runtime) 'dynamic) '("/MD") '())) ) )
     375                 (if (eq? (c-runtime) 'dynamic) '("/MD") '())) ) )
    360376      (if include-dir (list "-I" include-dir) '())) )
    361377
    … …  
    376392                                       TARGET_LIB_HOME)) )))]
    377393        [else
    378          (let ((p (quotewrap (prefix "" "lib"
    379                                      (if host-mode
    380                                          INSTALL_LIB_HOME
    381                                          TARGET_LIB_HOME)))))
    382            (list (conc "-L" p " -Wl,-R" p) ) ) ] ) )
     394         (list (conc "-L" (quotewrap (prefix "" "lib"
     395                                             (if host-mode
     396                                                 INSTALL_LIB_HOME
     397                                                 TARGET_LIB_HOME))))
     398               (conc " -Wl,-R" (quotewrap (prefix "" "lib"
     399                                                  (if host-mode
     400                                                      INSTALL_LIB_HOME
     401                                                      TARGET_RUN_LIB_HOME))))) ] ) )
    383402
    384403(define target-filename #f)
    … …  
    755774                  (set! rest (cdr rest)) ) ]
    756775               [(-host) #f]
     776               [(-)
     777                (set! target-filename (make-pathname #f "a" executable-extension))
     778                (set! scheme-files (cons "-" scheme-files))]
    757779               [else
    758780                (when (memq s '(-unsafe -benchmark-mode))
    … …  
    9991021    (if dry-run
    10001022        0
    1001         (system str)) )
     1023        (if (zero? (system str))
     1024            0
     1025            1)))
    10021026  (unless (zero? last-exit-code)
    10031027    (printf "*** Shell command terminated with exit status ~S: ~A~%" last-exit-code str) )

  • chicken/cscbench.scm

    r2710 r3839  
    4545(define (compile-and-run file extras decls options coptions unsafe)
    4646  (system* "~A ~A -quiet -no-warnings -heap-size 8m -output-file tmpfile.c ~A ~A ~A" chicken file extras decls options)
    47   (system* "~a ~a -I.. ~a -DC_NO_PIC_NO_DLL tmpfile.c -o tmpfile ../.libs/lib~achicken.a -lm ~a"
     47  (system* "~a ~a -I.. ~a tmpfile.c -o tmpfile ../.libs/lib~achicken.a -lm ~a"
    4848           cc coptions
    4949           (if (eq? (software-version) 'macosx) "" "-static")

  • chicken/debian/control

    r3241 r3839  
    1515 CHICKEN is a Scheme compiler which compiles a subset of R5RS into C.
    1616 It uses the ideas presented in Baker's paper "Cheney on the MTA", and
    17  is small and easily extendable, although not a production quality or
    18  high-performance Scheme system.
     17 has a small core and is easily extendable.
    1918 .
    2019 This package contains the compiler.
    … …  
    3231 CHICKEN is a Scheme compiler which compiles a subset of R5RS into C.
    3332 It uses the ideas presented in Baker's paper "Cheney on the MTA", and
    34  is small and easily extendable, although not a production quality or
    35  high-performance Scheme system.
     33 has a small core and is easily extendable.
    3634 .
    3735 This package contains the shared library needed to run programs using
    … …  
    5048 CHICKEN is a Scheme compiler which compiles a subset of R5RS into C.
    5149 It uses the ideas presented in Baker's paper "Cheney on the MTA", and
    52  is small and easily extendable, although not a production quality or
    53  high-performance Scheme system.
     50 has a small core and is easily extendable.
    5451 .
    5552 This package contains the header file and static library for developing

  • chicken/debian/copyright

    r3241 r3839  
    88<felix@call-with-current-continuation.org>.
    99
    10 Copyright (c) 2000-2002, Felix L. Winkelmann
     10Copyright (c) 2000-2007, Felix L. Winkelmann
    1111All rights reserved.
    1212

  • chicken/distribution/manifest

    r3033 r3839  
    4242benchmarks/puzzle.scm
    4343benchmarks/scheme.scm
    44 benchmarks/stack-size.cmake
    4544benchmarks/tak.scm
    4645benchmarks/takl.scm

  • chicken/eval.scm

    r3241 r3839  
    7272     ##sys#number? ##sys#symbol->qualified-string ##sys#decorate-lambda ##sys#string-append
    7373     ##sys#ensure-heap-reserve ##sys#syntax-error-hook ##sys#read-prompt-hook
    74      ##sys#repl-eval-hook ##sys#append ##sys#eval-decorator
     74     ##sys#repl-eval-hook ##sys#append ##sys#eval-decorator ##sys#alias-global-hook
    7575     open-output-string get-output-string make-parameter software-type software-version machine-type
    7676     build-platform getenv set-extensions-specifier! ##sys#string->symbol list->vector
    … …  
    579579(define ##sys#unbound-in-eval #f)
    580580(define ##sys#eval-debug-level 1)
     581(define (##sys#alias-global-hook s) s)
    581582
    582583(define ##sys#compile-to-closure
    … …  
    650651               (receive (i j) (lookup x e)
    651652                 (cond [(not i)
    652                         (if ##sys#eval-environment
    653                             (let ([loc (##sys#hash-table-location ##sys#eval-environment x #t)])
    654                               (unless loc (##sys#syntax-error-hook "reference to undefined identifier" x))
    655                               (cond-expand
    656                                [unsafe (lambda v (##sys#slot loc 1))]
     653                        (let ((x (##sys#alias-global-hook x)))
     654                          (if ##sys#eval-environment
     655                              (let ([loc (##sys#hash-table-location ##sys#eval-environment x #t)])
     656                                (unless loc (##sys#syntax-error-hook "reference to undefined identifier" x))
     657                                (cond-expand
     658                                 [unsafe (lambda v (##sys#slot loc 1))]
     659                                 [else
     660                                  (lambda v
     661                                    (let ([val (##sys#slot loc 1)])
     662                                      (if (eq? unbound val)
     663                                          (##sys#error "unbound variable" x)
     664                                          val) ) ) ] ) )
     665                              (cond-expand
     666                               [unsafe (lambda v (##core#inline "C_slot" x 0))]
    657667                               [else
    658                                 (lambda v
    659                                   (let ([val (##sys#slot loc 1)])
    660                                     (if (eq? unbound val)
    661                                         (##sys#error "unbound variable" x)
    662                                         val) ) ) ] ) )
    663                             (cond-expand
    664                              [unsafe (lambda v (##core#inline "C_slot" x 0))]
    665                              [else
    666                               (when (and ##sys#unbound-in-eval (not (##sys#symbol-has-toplevel-binding? x)))
    667                                 (set! ##sys#unbound-in-eval (cons (cons x cntr) ##sys#unbound-in-eval)) )
    668                               (lambda v (##core#inline "C_retrieve" x))] ) ) ]
     668                                (when (and ##sys#unbound-in-eval (not (##sys#symbol-has-toplevel-binding? x)))
     669                                  (set! ##sys#unbound-in-eval (cons (cons x cntr) ##sys#unbound-in-eval)) )
     670                                (lambda v (##core#inline "C_retrieve" x))] ) ) ) ]
    669671                       [(zero? i) (lambda (v) (##sys#slot (##sys#slot v 0) j))]
    670672                       [else (lambda (v) (##sys#slot (##core#inline "C_u_i_list_ref" v i) j))] ) ) ]
    … …  
    749751                             [(set! ##core#set!)
    750752                              (##sys#check-syntax 'set! x '(_ variable _) #f)
    751                               (let ([var (cadr x)])
     753                              (let ((var (cadr x)))
    752754                                (receive (i j) (lookup var e)
    753                                   (let ([val (compile (caddr x) e var tf cntr)])
     755                                  (let ((val (compile (caddr x) e var tf cntr)))
    754756                                    (cond [(not i)
    755                                            (if ##sys#eval-environment
    756                                                (let ([loc (##sys#hash-table-location
    757                                                            ##sys#eval-environment
    758                                                            var
    759                                                            ##sys#environment-is-mutable) ] )
    760                                                  (unless loc (##sys#error "assignment of undefined identifier" var))
    761                                                  (if (##sys#slot loc 2)
    762                                                      (lambda (v) (##sys#setslot loc 1 (##core#app val v)))
    763                                                      (lambda v (##sys#error "assignment to immutable variable" var)) ) )
    764                                                (lambda (v) (##sys#setslot j 0 (##core#app val v))) ) ]
     757                                           (let ([var (##sys#alias-global-hook var)])
     758                                             (if ##sys#eval-environment
     759                                                 (let ([loc (##sys#hash-table-location
     760                                                             ##sys#eval-environment
     761                                                             var
     762                                                             ##sys#environment-is-mutable) ] )
     763                                                   (unless loc (##sys#error "assignment of undefined identifier" var))
     764                                                   (if (##sys#slot loc 2)
     765                                                       (lambda (v) (##sys#setslot loc 1 (##core#app val v)))
     766                                                       (lambda v (##sys#error "assignment to immutable variable" var)) ) )
     767                                                 (lambda (v)
     768                                                   (##sys#setslot var 0 (##core#app val v))) ) ) ]
    765769                                          [(zero? i) (lambda (v) (##sys#setslot (##sys#slot v 0) j (##core#app val v)))]
    766770                                          [else
    … …  
    10821086
    10831087(define (##sys#abort-load) #f)
    1084 (define ##sys#current-load-file #f)
     1088(define ##sys#current-source-filename #f)
    10851089(define ##sys#current-load-path "")
    10861090
    … …  
    11551159             (lambda (abrt)
    11561160               (fluid-let ([##sys#read-error-with-line-number #t]
    1157                            [##sys#current-load-file fname]
     1161                           [##sys#current-source-filename fname]
    11581162                           [##sys#current-load-path
    11591163                            (and fname

  • chicken/extras.scm

    r3033 r3839  
    17051705
    17061706(define hash-table-delete!
    1707   (let ([eq0 eq?]
    1708         [floor floor])
     1707  (let ([eq0 eq?])
    17091708    (lambda (ht key)
    17101709      (##sys#check-structure ht 'hash-table 'hash-table-delete!)
    … …  
    17181717          (if (eq? eq0 test)
    17191718              ;; Fast path (eq? test):
    1720               (let loop ((prev '())
     1719              (let loop ((prev #f)
    17211720                         (bucket bucket0))
    17221721                (if (null? bucket)
    … …  
    17251724                      (if (eq? key (##sys#slot b 0))
    17261725                          (begin
    1727                             (if (null? prev)
     1726                            (if (not prev)
    17281727                                (##sys#setslot vec k (##sys#slot bucket 1))
    17291728                                (##sys#setslot prev 1 (##sys#slot bucket 1)))
    … …  
    17311730                            #t)
    17321731                          (loop bucket (##sys#slot bucket 1))))))
    1733               (let loop ((prev '())
     1732              (let loop ((prev #f)
    17341733                         (bucket bucket0))
    17351734                (if (null? bucket)
    … …  
    17381737                      (if (test key (##sys#slot b 0))
    17391738                          (begin
    1740                             (if (null? prev)
     1739                            (if (not prev)
    17411740                                (##sys#setslot vec k (##sys#slot bucket 1))
    17421741                                (##sys#setslot prev 1 (##sys#slot bucket 1)))
    … …  
    17441743                            #t)
    17451744                          (loop bucket (##sys#slot bucket 1))))))))))))
     1745
     1746(define (hash-table-remove! ht proc)
     1747  (##sys#check-structure ht 'hash-table 'hash-table-remove!)
     1748  (let* ((vec (##sys#slot ht 1))
     1749         (len (##sys#size vec))
     1750         (c (##sys#slot ht 2)) )
     1751    (do ((i 0 (fx+ i 1)))
     1752        ((fx>= i len) (##sys#setislot ht 2 c))
     1753      (let loop ((prev #f)
     1754                 (bucket (##sys#slot vec i)) )
     1755        (unless (null? bucket)
     1756          (let ((b (##sys#slot bucket 0)))
     1757            (when (proc (##sys#slot b 0) (##sys#slot b 1))
     1758              (if prev
     1759                  (##sys#setslot prev 1 (##sys#slot bucket 1))
     1760                  (##sys#setslot vec i (##sys#slot bucket 1)) )
     1761              (set! c (fx- c 1)) )
     1762            (loop bucket (##sys#slot bucket 1) ) ) ) ) ) ) )
    17461763
    17471764(define hashtab-rehash

  • chicken/hen.el

    r3241 r3839  
    3535;;     - the user has chicken.info install
    3636;;     - the csi executable can be launch as "csi"
    37 ;;     - the #csi##oblist and co are available from oblist library
    3837
    3938;;
    … …  
    5756;; to keep srfi-1 and regex out of her csi environment.
    5857
     58;; Changes by felix:
     59;;
     60;; * removed hen-describe-symbol
     61;; * various cleaning up
     62;; * still pretty bad...
     63
    5964
    6065;;; Code:
    … …  
    6368 "$Id: hen.el,v 1.13 2004/11/22 22:36:11 flw Exp $
    6469
    65 Report bugs to: Linh Dang <linhd@>")
     70Report bugs to: Felix Winkelmann <bunny351@gmail.com>")
    6671(defvar hen-load-hook nil
    6772 "*Hooks run after loading hen.")
    6873
    6974(require 'scheme)
    70 (require 'info-look)
    7175(require 'compile)
    7276
    … …  
    114118                           "define-constant"
    115119                           "define-datatype"
    116                            "define-external-variable"
    117120                           "define-foreign-type"
    118121                           "define-foreign-variable"
    119122                           "define-foreign-record"
    120                            "define-functor"
    121123                           "define-generic"
    122                            "define-handy-method"
    123124                           "define-inline"
    124                            "define-internal-meroon-macro"
    125125                           "define-macro"
    126126                           "define-method"
    127                            "define-optionals"
    128127                           "define-reader-ctor"
    129128                           "define-record"
    … …  
    131130                           "define-record-printer"
    132131                           "define-record-type"
    133                            "define-record-scheme"
    134                            "define-signature"
    135                            "define-structure"
    136132                           "define-syntax"
    137133                           "define-for-syntax"
    138                            "define-syntax-form"
    139                            "define-optimizer"
    140134                           "define-values") 1) "\\)"
    141135                           "\\s-+(?\\(\\(\\sw\\|\\s_\\)+\\)")
    … …  
    154148      (concat
    155149       "\\<" (regexp-opt
    156             '("begin" "begin0" "begin-form" "else"
    157               "call-with-current-continuation" "call/cc"
    158               "call-with-input-pipe" "call-with-output-pipe"
    159               "call-with-input-file" "call-with-output-file"
    160               "call-with-input-string" "call-with-output-string"
    161               "call-with-values"
     150            '("begin" "begin0" "else"
    162151              "else"
    163152              "foreign-lambda*" "foreign-safe-lambda*" "foreign-primitive"
    164               "foreign-declare"
     153              "foreign-declare" "foreign-parse" "foreign-parse/declare"
    165154              "foreign-lambda" "foreign-safe-lambda" "foreign-code"
    166155              "match" "match-lambda" "match-lambda*" "match-define" "match-let" "match-let*"
    … …  
    168157              "case" "case-lambda" "cond" "cond-expand" "condition-case" "switch"
    169158              "handle-exceptions"
    170               "record-compose"
    171159              "cut" "cute" "time" "regex-case"
    172160
    173               "do" "else" "for-each" "if" "lambda" "when" "while" "if*" "unless"
     161              "do" "else" "if" "lambda" "when" "while" "if*" "unless"
    174162
    175163              "let-location" "location" "rec"
    176164              "let" "let*" "let-syntax" "letrec" "letrec-syntax" "set!-values"
    177               "and-let*" "let-optionals" "let-optionals*" "let-macro"
     165              "and-let*" "let-optionals" "let-optionals*"
    178166              "fluid-let" "let-values" "let*-values" "letrec-values"
    179167              "parameterize"
    180168              "module" "import-only" "import" "import*"
    181169
    182               "and" "or" "delay" "andmap" "ormap" "receive"
    183 
    184               "assert" "ignore-errors" "critical-section" "ensure" "eval-when"
    185 
    186               "with-input-from-file" "with-output-to-file"
    187               "with-input-from-pipe" "with-output-to-pipe"
    188               "with-input-from-string" "with-output-to-string"
    189 
    190               "loop"
     170              "and" "or" "delay" "receive"
     171
     172              "assert" "ignore-errors" "ensure" "eval-when"
     173
     174              "loop" "sc-macro-transformer"
    191175
    192176              "declare" "include" "require-extension" "require" "require-for-syntax" "use" "quasiquote"
    193177
    194               "map" "syntax" "with-syntax" "syntax-case" "identifier-syntax" "syntax-rules") t)
     178              "syntax" "with-syntax" "syntax-case" "identifier-syntax" "syntax-rules") t)
    195179       "\\>") 'font-lock-keyword-face)
    196180     '("\\<set!" . font-lock-keyword-face)
    … …  
    210194(mapc (lambda (cell)
    211195       (put (car cell) 'scheme-indent-function (cdr cell)))
    212      '((begin0 . 0) (begin-form . 0)
     196     '((begin0 . 0)
    213197
    214198       (when . 1) (while . 1) (unless . 1)
    … …  
    254238                   (lambda (ignored) "*csc*")))
    255239
    256 (defun hen-build-unit ()
     240(defun hen-build-extension ()
    257241 (interactive)
    258242 (let* ((file-name (file-name-nondirectory
    259                      (buffer-file-name)))
    260         (base-name (file-name-sans-extension file-name)))
    261    (hen-build "csc" (list "-s" file-name "-o" (concat base-name ".so")) )))
     243                    (buffer-file-name))))
     244   (hen-build "csc" (list "-s" file-name))))
    262245
    263246(defun hen-build-program ()
    264247 (interactive)
    265248 (let* ((file-name (file-name-nondirectory
    266                      (buffer-file-name)))
    267         (base-name (file-name-sans-extension file-name)))
     249                     (buffer-file-name))))
    268250   (hen-build "csc" (list file-name) )))
    269251
    … …  
    275257\\[hen-csi-apropos] lists the csi's symbols matching a regex.
    276258\\[hen-csi-send] reads a s-exp from the user and evaluates it csi.
    277 \\[hen-describe-symbol] looks up info documentation for a symbol from.
    278 the R5RS and Chicken info files.
    279 \\[hen-build-unit] compiles the current file as a shared object
    280 \\[hen-describe-symbol] compiles the current file as a program
     259\\[hen-build-extension] compiles the current file as a shared object
     260\\[hen-build-program] compiles the current file as a program
    281261"
    282262
    … …  
    288268 (define-key hen-mode-map (kbd "C-c C-r") 'hen-csi-eval-region)
    289269 (define-key hen-mode-map (kbd "C-c C-a") 'hen-csi-apropos)
    290  (define-key hen-mode-map (kbd "C-c C-h") 'hen-describe-symbol)
    291270 (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-unit)
    292271 (define-key hen-mode-map (kbd "C-c C-x") 'hen-csi-send)
    293  (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-unit)
     272 (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-extension)
    294273 (define-key hen-mode-map (kbd "C-c C-c") 'hen-build-program)
    295274
    … …  
    297276 (define-key hen-mode-map [menu-bar shared build-prog] '("Compile File" hen-build-program))
    298277 (define-key hen-mode-map [menu-bar shared send-to-csi] '("Evaluate" . hen-csi-send))
    299  (define-key hen-mode-map [menu-bar scheme build-as-unit] '("Compile File as Unit" . hen-build-unit))
    300  (define-key hen-mode-map [menu-bar scheme describe-sym] '("Lookup Documentation for Symbol" . hen-describe-symbol))
     278 (define-key hen-mode-map [menu-bar scheme build-as-extension]
     279   '("Compile File as Extension" . hen-build-extension))
    301280 (define-key hen-mode-map [menu-bar scheme apropos] '("Symbol Apropos" . hen-csi-apropos))
    302281 (define-key hen-mode-map [menu-bar scheme eval-region] '("Eval Region" . hen-csi-eval-region))
    303  (define-key hen-mode-map [menu-bar scheme eval-last-sexp] '("Eval Last S-Expression" . hen-csi-eval-last-sexp))
     282 (define-key hen-mode-map [menu-bar scheme eval-last-sexp]
     283   '("Eval Last S-Expression" . hen-csi-eval-last-sexp))
    304284
    305285 (setq font-lock-defaults
    … …  
    376356            (eq (process-status proc) 'run))
    377357       proc
    378      (setq proc (start-process "csi" (hen-csi-buffer) "csi" "-no-init" "-quiet"))
     358     (setq proc (start-process "csi" (hen-csi-buffer) "csi" "-no-init" "-quiet" "-:c"))
    379359     (with-current-buffer (hen-csi-buffer)
    380360       (hen-proc-wait-prompt proc hen-prompt-pattern)
    381        ;(hen-proc-send "(require 'oblist)" proc hen-prompt-pattern)
    382361       proc))))
    383362
    … …  
    435414(defun hen-csi-completions-alist (prefix)
    436415 (read (hen-csi-send
    437         ;; this used to not work because srfi-1 and regex were needed. I don't want to
    438         ;; require them inside this expression because that would pollute the namespace and
    439         ;; the user will have no choice but to develop his programs with those libs in the
    440         ;; environment.
    441         ;; I should check the csi compilation code - why it doesn't statically link in regex
    442         ;; and srfi-1, since it seems to rely on them.
    443         (concat "(begin (require 'regex) (require 'srfi-1)"
    444                 ;; TODO: this is an ugly hack that pollutes the namespace. should be done
    445                 ;; in a seperate process, but process-fork requires posix, which would pollute the namespace too.
    446                 ;; The solution is to statically link the required routines (either posix or srfi-1+regex) into the csi
    447                 ;; executable.
    448                 "(pp (map list (delete-duplicates (##csi#name-of-symbols-starting-with \""
     416        (concat "(pp (map list (delete-duplicates (##csi#name-of-symbols-starting-with \""
    449417                prefix
    450                 "\")))))"))))
     418                "\"))))"))))
    451419
    452420(defun hen-complete-symbol (thing)
    … …  
    493461                        nil nil nil 'hen-lookup-history (hen-identifier-at-point))))
    494462
    495 (defun hen-describe-symbol (name)
    496  "Lookup documentation for symbol NAME."
    497  (interactive (hen-csi-symbol-completing-read "Describe symbol: "))
    498  (info-lookup-symbol name 'hen-mode))
    499 
    500463(defun hen-csi-apropos (regex)
    501464 "List the symbols matching REGEX."
    … …  
    510473                         "  (delete-duplicates! (##csi#symbols-matching \"" regex  "\"))))"))
    511474          (results-alist (read (hen-csi-send query))))
    512      (if (display-mouse-p)
    513          (insert "If moving the mouse over text changes the text's color,\n"
    514                  (substitute-command-keys
    515                   "you can click \\[apropos-mouse-follow] on that text to get more information.\n")))
    516      (insert "In this buffer, go to the name of the command, or function,"
    517              " or variable,\n"
    518              (substitute-command-keys
    519               "and type \\[apropos-follow] to get full documentation.\n\n"))
    520 
    521475     (dolist (item results-alist)
    522476       (let ((name (car item))
    523477             (obj (cdr item)))
    524478         (insert (car item) " ")
    525          (add-text-properties (line-beginning-position) (1- (point))
    526                               `(item ,name action hen-describe-symbol
    527                                      face bold mouse-face highlight
    528                                      help-echo "mouse-2: display help on this item"))
    529479         (indent-to-column 40)
    530480         (insert (cdr item) "\n")))
    … …  
    532482     (apropos-mode)))
    533483 (pop-to-buffer "*Chicken Apropos*" t))
    534 
    535 (info-lookup-add-help
    536 :mode 'hen-mode
    537 :regexp "[^()'\" \t\n]+"
    538 :ignore-case t
    539 ;; Aubrey Jaffer's rendition from <URL:ftp://ftp-swiss.ai.mit.edu/pub/scm>
    540 :doc-spec '(("(chicken)Index" nil
    541              "^[ \t]+- [^:\n]+:[ \t]*" "")
    542             ("(r5rs)Index" nil
    543              "^[ \t]+- [^:\n]+:[ \t]*" "")))
    544484
    545485(provide 'hen)

  • chicken/library.scm

    r3156 r3839  
    6666#define C_peek_c_string(b, i, to, len) (C_memcpy(C_data_pointer(to), (C_char *)C_block_item(b, C_unfix(i)), C_unfix(len)), C_SCHEME_UNDEFINED)
    6767#define C_free_mptr(p, i)     (C_free((void *)C_block_item(p, C_unfix(i))), C_SCHEME_UNDEFINED)
     68#define C_free_sptr(p, i)     (C_free((void *)(((C_char **)C_block_item(p, 0))[ C_unfix(i) ])), C_SCHEME_UNDEFINED)
    6869
    6970#define C_direct_continuation(dummy)  t1
    … …  
    338339(define (system cmd)
    339340  (##sys#check-string cmd 'system)
    340   (##core#inline "C_execute_shell_command" cmd) )
     341  (let ((r (##core#inline "C_execute_shell_command" cmd)))
     342    (cond ((fx< r 0)
     343           (##sys#update-errno)
     344           (##sys#signal-hook #:process-error 'system "`system' invocation failed" cmd) )
     345          (else r) ) ) )
    341346
    342347
    … …  
    13411346               (##sys#check-symbol x 'char-name)
    13421347               (##sys#check-char chr 'char-name)
     1348               (when (fx< (##sys#size (##sys#slot x 1)) 2)
     1349                 (##sys#signal-hook #:type-error 'char-name "invalid character name" x) )
    13431350               (let ([a (lookup-char chr)])
    13441351                 (if a
    … …  
    15701577; 5:  (flush-output PORT)
    15711578; 6:  (char-ready? PORT) -> BOOL
    1572 ; 7:  (read-string! PORT STRING COUNT START) -> COUNT'
     1579; 7:  (read-string! PORT COUNT STRING START) -> COUNT'
    15731580; 8:  (read-line PORT LIMIT) -> STRING | EOF
    15741581
    … …  
    22272234         
    22282235          (define (r-char)
     2236            ;; Code contributed by Alex Shinn
    22292237            (let* ([c (##sys#peek-char-0 port)]
    2230                    [tk (r-token)] )
    2231               (cond [(char-name (##sys#intern-symbol tk))]
    2232                     [(fx> (string-length tk) 1)
     2238                   [tk (r-token)]
     2239                   [len (##sys#size tk)])
     2240              (cond [(fx> len 1)
    22332241                     (cond [(and (or (char=? #\x c) (char=? #\u c) (char=? #\U c))
    2234                                  (string->number (##sys#substring tk 1 (##sys#size tk)) 16) )
     2242                                 (##sys#string->number (##sys#substring tk 1 len) 16) )
    22352243                            => (lambda (n) (integer->char n)) ]
     2244                           [(and-let* ((c0 (char->integer (##core#inline "C_subchar" tk 0)))
     2245                                       ((fx<= #xC0 c0)) ((fx<= c0 #xF7))
     2246                                       (n0 (fxand (fxshr c0 4) 3))
     2247                                       (n (fx+ 2 (fxand (fxior n0 (fxshr n0 1)) (fx- n0 1))))
     2248                                       ((fx= len n))
     2249                                       (res (fx+ (fxshl (fxand c0 (fx- (fxshl 1 (fx- 8 n)) 1)) 6)
     2250                                                 (fxand (char->integer
     2251                                                         (##core#inline "C_subchar" tk 1))
     2252                                                        #b111111))))
     2253                              (cond ((fx>= n 3)
     2254                                     (set! res (fx+ (fxshl res 6)
     2255                                                    (fxand
     2256                                                     (char->integer
     2257                                                      (##core#inline "C_subchar" tk 2))
     2258                                                     #b111111)))
     2259                                     (if (fx= n 4)
     2260                                         (set! res (fx+ (fxshl res 6)
     2261                                                        (fxand (char->integer
     2262                                                                (##core#inline "C_subchar" tk 3))
     2263                                                               #b111111))))))
     2264                              (integer->char res))]
     2265                           [(char-name (##sys#intern-symbol tk))]
    22362266                           [else (##sys#read-error port "unknown named character" tk)] ) ]
    22372267                    [(memq c terminating-characters) (##sys#read-char-0 port)]
    … …  
    25492579     (and t1 (##sys#grow-vector t1 (##sys#size t1) #f) ) )
    25502580   (let ((t2 (##sys#slot rt 2)))
    2551      (and t2 (##sys#grow-vector t2 (##sys#size t2) #f) ) ) ))
     2581     (and t2 (##sys#grow-vector t2 (##sys#size t2) #f) ) )
     2582   (let ((t3 (##sys#slot rt 3)))
     2583     (and t3 (##sys#grow-vector t3 (##sys#size t3) #f) ) ) ))
    25522584
    25532585
    … …  
    37153747                  '() ) ) ) ) ) ) )
    37163748
     3749(define ##sys#peek-and-free-c-string-list
     3750  (let ((fetch (foreign-lambda c-string "C_peek_c_string_at" c-pointer int))
     3751        (free (foreign-lambda void "C_free" c-pointer)))
     3752    (lambda (ptr n)
     3753      (let ((lst (let loop ((i 0))
     3754                   (if (and n (fx>= i n))
     3755                       '()
     3756                       (let ((s (fetch ptr i)))
     3757                         (cond (s
     3758                                (##core#inline "C_free_sptr" ptr i)
     3759                                (cons s (loop (fx+ i 1))) )
     3760                               (else '() ) ) ) ) ) ) )
     3761        (free ptr)
     3762        lst) ) ) )
     3763
    37173764(define (##sys#vector->closure! vec addr)
    37183765  (##core#inline "C_vector_to_closure" vec)

  • chicken/lolevel.scm

    r3033 r3839  
    429429          p)
    430430        (##sys#error 'static-byte-vector->pointer "can not coerce non-static bytevector" bv) ) ) )
     431
     432(define (byte-vector-move! src src-start src-end dst dst-start)
     433  (let ((from (make-locative src src-start))
     434        (to   (make-locative dst dst-start)) )
     435    (move-memory! from to (- src-end src-start)) ) )
     436
     437(define (byte-vector-append . vectors)
     438  (define (append-rest-at i vectors)
     439    (if (pair? vectors)
     440        (let* ((src (car vectors))
     441               (len (byte-vector-length src))
     442               (dst (append-rest-at (+ i len) (cdr vectors))) )
     443          (byte-vector-move! src 0 len dst i)
     444          dst )
     445        (make-byte-vector i) ) )
     446  (append-rest-at 0 vectors) )
    431447
    432448

  • chicken/misc/makedoc

    r2926 r3839  
    44|#
    55
    6 ;;; usage: misc/makehtmldoc [-pdf] [PAGE]
     6;;; usage: misc/makedoc [-pdf] [PAGE]
    77
    88(use html-stream stream-ext srfi-40 stream-wiki utils srfi-13 url posix)
    … …  
    162162
    163163
    164 ;;; Here come the conversions
     164
     165;;; Check for help command line options
     166(let ((args (command-line-arguments)))
     167  (when (and (not (null? args)) (member (car args) '("-h" "-help" "--help" "-?")))
     168    (print "Usage: misc/makedoc [-h | --help | -?]\n"
     169           "       misc/makedoc [-pdf] [PAGE]")
     170    (exit)))
     171
     172;;; Here come the conversions         
    165173(when *generate-pdf*
    166174  (chapters-sanity-check))

  • chicken/posixunix.scm

    r3241 r3839  
    175175#define C_setuid(id)        C_fix(setuid(C_unfix(id)))
    176176#define C_setgid(id)        C_fix(setgid(C_unfix(id)))
     177#define C_seteuid(id)       C_fix(seteuid(C_unfix(id)))
     178#define C_setegid(id)       C_fix(setegid(C_unfix(id)))
    177179#define C_setsid(dummy)     C_fix(setsid())
    178180#define C_setpgid(x, y)     C_fix(setpgid(C_unfix(x), C_unfix(y)))
    … …  
    12351237        (posix-error #:file-error 'change-file-owner "cannot change file owner" fn uid gid) ) ) )
    12361238
    1237   (define current-effective-user-id (foreign-lambda int "C_geteuid"))
    1238   (define current-effective-group-id (foreign-lambda int "C_getegid"))
     1239  (define current-effective-user-id
     1240    (getter-with-setter
     1241     (foreign-lambda int "C_geteuid")
     1242     (lambda (id)
     1243      (when (fx< (##core#inline "C_seteuid" id) 0)
     1244        (##sys#update-errno)
     1245        (##sys#error
     1246         'effective-user-id!-setter "cannot set effective user ID" id) ) ) ) )
     1247
     1248  (define current-effective-group-id
     1249    (getter-with-setter
     1250     (foreign-lambda int "C_getegid")
     1251     (lambda (id)
     1252      (when (fx< (##core#inline "C_setegid" id) 0)
     1253        (##sys#update-errno)
     1254        (##sys#error
     1255         'effective-group-id!-setter "cannot set effective group ID" id) ) ) ) )
    12391256
    12401257  (define set-user-id!                  ; DEPRECATED

  • chicken/posixwin.scm

    r2926 r3839  
    14521452      (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm) ) )
    14531453
    1454 
     1454(define local-timezone-abbreviation
     1455  (foreign-lambda* c-string ()
     1456   "char *z = (daylight ? _tzname[1] : _tzname[0]);"
     1457   "return(z);") )
    14551458
    14561459;;; Other things:
    … …  
    16141617          int)])
    16151618    (lambda (loc cmd args env stdoutf stdinf stderrf)
    1616       (let (
    1617           [commandline
    1618             (if args
    1619               (let loop ([args args] [cmdlin cmd])
    1620                 (if (null? args)
    1621                   cmdlin
    1622                   (loop (cdr args) (conc cmdlin " " (car args)))))
    1623               cmd)])
     1619      (let ([commandline (if args (string-intersperse (cons cmd args)) cmd)])
    16241620        (let-location ([handle int -1] [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])
    16251621          (let (
    … …  
    16531649            (##sys#check-list env loc)
    16541650            (for-each (cut ##sys#check-string <> loc) env) )
    1655           (receive [in out pid err]
    1656                       (##sys#process loc cmd args env #t #t err?)
     1651          (receive [in out pid err] (##sys#process loc cmd args env #t #t err?)
    16571652            (if err?
    16581653              (values in out pid err)
    … …  
    17701765(define-unimplemented group-information)
    17711766(define-unimplemented initialize-groups)
    1772 (define-unimplemented local-timezone-abbreviation)
    17731767(define-unimplemented memory-mapped-file-pointer)
    17741768(define-unimplemented parent-process-id)

  • chicken/regex.scm

    r3033 r3839  
    4343  (disable-interrupts)
    4444  (export regexp string-match string-search string-match-positions string-search-positions regexp-escape
    45           string-split-fields string-substitute string-substitute* glob->regexp grep regexp?)
     45          string-split-fields string-substitute string-substitute* glob->regexp grep regexp?
     46          glob?)
    4647  (bound-to-procedure
    4748   get-output-string open-output-string ##sys#write-char-0 string-search string->list list->string
    … …  
    103104  (foreign-lambda void "pcre_free" c-pointer) )
    104105
     106(define re-compile/verify
     107  (lambda (regexp flags loc)
     108    (##sys#check-string regexp loc)
     109    (let ([pcre (re-compile-pattern regexp flags)])
     110      (or pcre
     111          (##sys#error loc (##sys#string-append "can not compile regular expression - " C_regex_error) regexp) ) ) ) )
     112
    105113(define re-compile
    106114  (lambda (regexp loc)
    107     (##sys#check-string regexp loc)
    108     (let ([pcre (re-compile-pattern regexp 0)])
    109       (or pcre
    110           (##sys#error loc (##sys#string-append "can not compile regular expression - " C_regex_error) regexp) ) ) ) )
     115    (re-compile/verify regexp 0 loc)))
    111116
    112117(define (re-compile-options->integer ls)
    … …  
    124129(define (regexp rx . o)
    125130  (##sys#check-string rx 'regexp)
    126   (let ([rt (re-compile-pattern rx (re-compile-options->integer o))])
     131  (let ([rt (re-compile/verify rx (re-compile-options->integer o) 'regexp)])
    127132    (set-finalizer! rt finalizer)
    128133    (##sys#make-structure 'regexp rt) ) )
    … …  
    338343;;; Some useful things:
    339344
     345(define (glob? str)
     346  (let loop ([idx (sub1 (string-length str))])
     347    (and (not (negative? idx))
     348         (case (string-ref str idx)
     349           [(#\* #\[ #\?) #t]
     350           [else (loop (sub1 idx))]) ) ) )
     351
    340352(define glob->regexp
    341353  (let ((list->string list->string)

  • chicken/runtime.c

    r3241 r3839  
    4646#endif
    4747
    48 #if defined(C_NO_PIC_NO_DLL) && !defined(PIC)
     48#if !defined(PIC)
    4949# define NO_DLOAD2
    5050#endif
    … …  
    339339C_TLS void (*C_gc_trace_hook)(C_word *var, int mode);
    340340C_TLS C_word(*C_get_unbound_variable_value_hook)(C_word sym);
     341C_TLS void (*C_panic_hook)(C_char *msg);
    341342
    342343C_TLS void (C_fcall *C_restart_trampoline)(void *proc) C_regparm C_noret;
    … …  
    473474static void barf(int code, char *loc, ...) C_noret;
    474475static void panic(C_char *msg) C_noret;
     476static void usual_panic(C_char *msg) C_noret;
    475477static void horror(C_char *msg) C_noret;
    476478static void C_fcall initial_trampoline(void *proc) C_regparm C_noret;
    … …  
    615617  if(debug_mode) C_printf(C_text("[debug] application startup...\n"));
    616618
     619  C_panic_hook = usual_panic;
    617620  symbol_table_list = NULL;
    618621
    … …  
    12891292void panic(C_char *msg)
    12901293{
     1294  C_panic_hook(msg);
     1295  usual_panic(msg);
     1296}
     1297
     1298
     1299void usual_panic(C_char *msg)
     1300{
    12911301  C_char *dmp = C_dump_trace(0);
    12921302
    … …  
    38363846  if(buf != buffer) C_free(buf);
    38373847
    3838   if(n == -1)
    3839     return C_fix(errno);
    3840 
    3841 #ifdef C_NONUNIX
    38423848  return C_fix(n);
    3843 #else
    3844   return C_fix(WIFEXITED(n) ? WEXITSTATUS(n) : (WIFSIGNALED(n) ? WTERMSIG(n) : WSTOPSIG(n)));
    3845 #endif
    38463849}
    38473850
    … …  
    72727275void C_ccall C_string_to_number(C_word c, C_word closure, C_word k, C_word str, ...)
    72737276{
    7274   int radix, radixpf = 0, sharpf = 0, ratp = 0, exactf, exactpf = 0;
     7277  int radix, radixpf = 0, sharpf = 0, ratp = 0, exactf, exactpf = 0, periodf = 0;
    72757278  C_word n1, n, *a = C_alloc(WORDS_PER_FLONUM);
    72767279  C_char *sptr, *eptr;
    … …  
    72987301  }
    72997302
    7300   if(n >= STRING_BUFFER_SIZE - 1) {
    7301     n = C_SCHEME_FALSE;
    7302     goto fini;
    7303   }
     7303  if(n >= STRING_BUFFER_SIZE - 1) goto fail;
    73047304
    73057305  C_memcpy(sptr = buffer, C_c_string(str), n > (STRING_BUFFER_SIZE - 1) ? STRING_BUFFER_SIZE : n);
    … …  
    73207320  }
    73217321
    7322   /* check for embedded '#'s: */
    7323   while((eptr = C_strchr(sptr, '#')) != NULL) {
    7324     if(eptr[ 1 ] == '\0' || C_strchr("#.0123456789", eptr[ 1 ]) != NULL) {
    7325       sharpf = 1;
    7326       *eptr = '0';
    7327     }
    7328     else {
    7329       n = C_SCHEME_FALSE;
    7330       goto fini;
     7322  /* check for embedded '#'s and double '.'s: */
     7323  for(eptr = sptr; *eptr != '\0'; ++eptr) {
     7324    switch(*eptr) {
     7325    case '.':
     7326      if(periodf) goto fail;
     7327     
     7328      periodf = 1;
     7329      break;
     7330
     7331    case '#':
     7332      if(eptr[ 1 ] == '\0' || C_strchr("#.0123456789", eptr[ 1 ]) != NULL) {
     7333        sharpf = 1;
     7334        *eptr = '0';
     7335      }
     7336      else goto fail;
     7337     
     7338      break;
    73317339    }
    73327340  }
    … …  
    74167424      ln = C_strtoul(str, &eptr, radix);
    74177425     
    7418       if((ln == 0 && errno == EINVAL) || (ln == ULONG_MAX && errno == ERANGE)) return 0;
     7426      if((ln == 0 && errno == EINVAL) || (ln == ULONG_MAX && errno == ERANGE) ||
     7427         *eptr != '\0')
     7428        return 0;
    74197429
    74207430      *flo = (double)ln;
    … …  
    74457455    return 1;
    74467456  }
     7457}
     7458
     7459
     7460static char *to_binary(C_uword num)
     7461{
     7462  char *p;
     7463
     7464  buffer[ 65 ] = '\0';
     7465  p = buffer + 65;
     7466 
     7467  do {
     7468    *(--p) = (num & 1) ? '1' : '0';
     7469    num /= 2;
     7470  } while(num);
     7471
     7472  return p;
    74477473}
    74487474
    … …  
    74717497    switch(radix) {
    74727498    case 2:
    7473       buffer[ 65 ] = '\0';
    7474       p = buffer + 65;
    7475 
    7476       do {
    7477         *(--p) = (num & 1) ? '1' : '0';
    7478         num /= 2;
    7479       } while(num);
    7480 
     7499      p = to_binary(num);
    74817500      break;
    74827501     
    … …  
    75117530    if(C_fits_in_unsigned_int_p(num) == C_SCHEME_TRUE) {
    75127531      switch(radix) {
    7513         case 8:
    7514           C_sprintf(p = buffer, "%o", (unsigned int)f);
    7515           goto fini;
    7516 
    7517         case 16:
    7518           C_sprintf(p = buffer, "%x", (unsigned int)f);
    7519           goto fini;
     7532      case 2:
     7533        p = to_binary((unsigned int)f);
     7534        goto fini;
     7535
     7536      case 8:
     7537        C_sprintf(p = buffer, "%o", (unsigned int)f);
     7538        goto fini;
     7539
     7540      case 16:
     7541        C_sprintf(p = buffer, "%x", (unsigned int)f);
     7542        goto fini;
    75207543      }
    75217544    }
    … …  
    79177940                  tmt->tm_isdst > 0 ? C_SCHEME_TRUE : C_SCHEME_FALSE,
    79187941#ifdef C_MACOSX
    7919                   C_fix(tmt->tm_gmtoff)
     7942                  /* negative for west of UTC, but we want positive */
     7943                  C_fix(-tmt->tm_gmtoff)
     7944#elif defined(__CYGWIN__) || defined(__MINGW32__) || defined(_WIN32) || defined(__WINNT__)
     7945                  C_fix(_timezone)
    79207946#else
    7921                   C_fix(timezone)
     7947                  C_fix(timezone)
    79227948#endif
    79237949                  );

  • chicken/site/index.html

    r3241 r3839  
    147147<h3>DOWNLOAD</h3>
    148148<p>
    149 <a href="http://www.call-with-current-continuation.org/chicken-2.5.tar.gz">chicken-2.5.tar.gz</a> (UNIX, Mac OS X and Windows sources)<br>
    150 <a href="http://www.call-with-current-continuation.org/chicken-2.5.zip">chicken-2.5.zip</a> (the sources as a zip archive)<br>
    151 <!--<a href="http://www.call-with-current-continuation.org/chicken-2.5-osx-ppc.dmg">chicken-2.5-osx-ppc.dmg</a> (Mac OS X PowerPC binaries)<br>-->
    152 <!-- <a href="http://www.call-with-current-continuation.org/chicken-2.5-win32-msvc.zip">chicken-2.5-win32-msvc.zip</a> (Windows x86 binaries)<br> -->
     149<a href="http://www.call-with-current-continuation.org/chicken-2.6.tar.gz">chicken-2.6.tar.gz</a> (UNIX, Mac OS X and Windows sources)<br>
     150<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>
    153151
    154152Latest development snapshot: <a
    155 href="http://www.call-with-current-continuation.org/chicken-2.6rc1.tar.gz">chicken-2.6rc1.tar.gz</a>
     153href="http://www.call-with-current-continuation.org/chicken-2.608.tar.gz">chicken-2.608.tar.gz</a>
    156154and <a href="http://www.call-with-current-continuation.org/ChangeLog.txt">(Change log)</a>
    157155

  • chicken/srfi-13.scm

    r1186 r3839  
    347347(define (%string-map! proc s start end)
    348348  (do ((i (- end 1) (- i 1)))
    349       ((< i start))
     349      ((< i start) s)
    350350    (string-set! s i (proc (string-ref s i)))))
    351351

  • chicken/support.scm

    r3033 r3839  
    485485           (cond [(and val (not (eq? val 'unknown)))
    486486                  (printf "\tval=~s" (cons (node-class val) (node-parameters val))) ]
    487                  [pval (printf "\tpval=~s" (cons (node-class val) (node-parameters val)))] )
     487                 [(and pval (not (eq? pval 'unknown)))
     488                  (printf "\tpval=~s" (cons (node-class pval) (node-parameters pval)))] )
    488489           (when (pair? refs) (printf "\trefs=~s" (length refs)))
    489490           (when (pair? csites) (printf "\tcss=~s" (length csites)))
    … …  
    542543                   (list (if (and (pair? arg) (eq? 'quote (car arg))) (cadr arg) arg))
    543544                   (map walk (cddr x)) ) ) )
    544                ((set! ##core#inline ##core#callunit)
     545               ((##core#inline ##core#callunit)
    545546                (make-node (car x) (list (cadr x)) (map walk (cddr x))) )
    546547               ((##core#proc)
    547548                (make-node '##core#proc (list (cadr x) #t) '()) )
    548                ((##core#set!) (make-node 'set! (list (cadr x)) (map walk (cddr x))))
     549               ((set! ##core#set!)
     550                (make-node
     551                 'set! (list (cadr x))
     552                 (map walk (cddr x))))
    549553               ((##core#foreign-callback-wrapper)
    550554                (let ([name (cadr (second x))])
    … …  
    559563                (make-node '##core#call '(#t) (map walk (cdr x))) )
    560564               (else
    561                 (receive
    562                     (name ln) (get-line-2 x)
     565                (receive (name ln) (get-line-2 x)
    563566                  (make-node
    564567                   '##core#call
    … …  
    939942                  param
    940943                  `(##sys#foreign-unsigned-integer-argument ,param) ) ]
    941              [(c-pointer)
     944             [(c-pointer c-string-list c-string-list*)
    942945              (let ([tmp (gensym)])
    943946                `(let ([,tmp ,param])
    … …  
    10281031              int32 unsigned-int32)
    10291032        0)
    1030        ((c-string nonnull-c-string c-pointer nonnull-c-pointer symbol c-string* nonnull-c-string*)
     1033       ((c-string nonnull-c-string c-pointer nonnull-c-pointer symbol c-string* nonnull-c-string*
     1034                  c-string-list c-string-list*)
    10311035        (words->bytes 3) )
    10321036       ((unsigned-integer long integer unsigned-long integer32 unsigned-integer32)
    … …  
    10561060              c-pointer pointer nonnull-c-pointer unsigned-integer integer float c-string symbol
    10571061              scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer32
    1058               nonnull-c-string c-string* nonnull-c-string*) ; pointer and nonnull-pointer are DEPRECATED
     1062              nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*) ; pointer and nonnull-pointer are DEPRECATED
    10591063        (words->bytes 1) )
    10601064       ((double number)
    … …  
    10811085    [(nonnull-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body '0)]
    10821086    [(symbol) `(##sys#intern-symbol (##sys#peek-c-string ,body '0))]
     1087    [(c-string-list) `(##sys#peek-c-string-list ,body '#f)]
     1088    [(c-string-list*) `(##sys#peek-and-free-c-string-list ,body '#f)]
    10831089    [else
    10841090     (match type
    … …  
    13671373  (##sys#hash-table-for-each
    13681374   (lambda (key val)
    1369      (printf "~S ~S~%" key val) )
     1375     (printf "~S\t~S~%" key val) )
    13701376   real-name-table) )
    13711377

  • chicken/utils.scm

    r2868 r3839  
    8686    (##sys#environment-symbols env
    8787      (lambda (sym)
    88         (not (not (string-search patt (symbol->string sym)))))) ) )
     88        (and (string-search patt (symbol->string sym))
     89             (##sys#symbol-has-toplevel-binding? sym))))))
    8990
    9091(let ([%apropos-list
    9192        (lambda (loc patt args)
    92           (let ([env (if (pair? args) (car args) (interaction-environment))])
     93          (let ([env (:optional args (interaction-environment))])
    9394            (##sys#check-structure env 'environment loc)
    9495            (unless (or (string? patt) (symbol? patt) (regexp? patt))
    … …  
    275276                (call-with-output-file pn (lambda (p) pn)) ) ) ) ) ) ) )
    276277
     278;; Directory string or list only contains path-separators
     279;; and/or current-directory names.
     280
     281(define (directory-null? dir)
     282  (let loop ([lst
     283              (if (list? dir)
     284                  dir ; Don't bother to check for strings here
     285                  (begin
     286                    (##sys#check-string dir 'directory-null?)
     287                    (string-split dir "/\\" #t)))])
     288    (or (null? lst)
     289        (and (member (car lst) '("" "."))
     290             (loop (cdr lst)) ) ) ) )
    277291
    278292;;; Handy I/O procedures:
    … …  
    352366              (reverse xs)
    353367              (loop (cons (fn x) xs))))))))
     368
     369(define (port-fold fn acc thunk)
     370  (let loop ([acc acc])
     371    (let ([x (thunk)])
     372      (if (eq? x #!eof)
     373        acc
     374        (loop (fn x acc))) ) ) )
     375
     376;;;; funky-ports
     377
     378(define (make-broadcast-port . ports)
     379  (make-output-port
     380   (lambda (s) (for-each (cut write-string s #f <>) ports))
     381   noop
     382   (lambda () (for-each flush-output ports)) ) )
     383
     384(define (make-concatenated-port p1 . ports)
     385  (let ((ports (cons p1 ports)))
     386    (make-input-port
     387     (lambda ()
     388       (let loop ()
     389         (if (null? ports)
     390             #!eof
     391             (let ((c (read-char (car ports))))
     392               (cond ((eof-object? c)
     393                      (set! ports (cdr ports))
     394                      (loop) )
     395                     (else c) ) ) ) ) )
     396     (lambda ()
     397       (and (not (null? ports))
     398            (char-ready? (car ports))))
     399     noop
     400     (lambda ()
     401       (let loop ()
     402         (if (null? ports)
     403             #!eof
     404             (let ((c (peek-char (car ports))))
     405               (cond ((eof-object? c)
     406                      (set! ports (cdr ports))
     407                      (loop) )
     408                     (else c))))))
     409     (lambda (p n dest start)
     410       (let loop ((n n) (c 0))
     411         (cond ((null? ports) c)
     412               ((fx<= n 0) c)
     413               (else
     414                (let ((m (read-string! n dest (car ports) (fx+ start c))))
     415                  (when (fx< m n)
     416                    (set! ports (cdr ports)) )
     417                  (loop (fx- n m) (fx+ c m))))))))))

  • chicken/wiki/Acknowledgements

    r3241 r3839  
    1616Goulart, Andreas Gustafsson, Sven Hartrumpf, Jun-ichiro itojun Hagino,
    1717Matthias Heiler, Karl M. Hegbloom, William P. Heinemann, Bill Hoffman,
    18 Bruce Hoult, Hans HÃŒbner, Markus HÃŒlsmann, Goetz Isenmann, David
    19 Janssens, Christian Jaeger, Dale Jordan, Valentin Kamyshenko, Daishi
    20 Kato, Peter Keller, Brad Kind, Ron Kneusel, Matthias Koeppe, Krysztof
    21 Kowa&#322;czyk, Todd R. Kueny Sr, Goran Krampe, Micky Latowicki, John
    22 Lenz, Kirill Lisovsky, Kon Lovett, Dennis Marti, Charles Martin, Bob
    23 McIsaac, Alain Mellan, Eric Merrit, Perry Metzger, Scott G. Miller,
    24 Mikael, Bruce Mitchener, Chris Moline, Eric E. Moore, Julian Morrison,
    25 Dan Muresan, Lars Nilsson, Ian Oversby, o.t., Gene Pavlovsky, Levi
    26 Pearson, Nicolas Pelletier, Carlos Pita, Robin Lee Powell, Pupeno,
    27 Davide Puricelli, Doug Quale, Eric Raible, Joel Reymont, Andreas
    28 Rottman, David Rush, Lars Rustemeier, Daniel Sadilek, Oskar Schirmer,
    29 Burton Samograd, Reed Sheridan, Ronald Schröder, Spencer Schumann,
    30 Alex Shinn, Shmul, Tony Sidaway, Jeffrey B. Siegal, Andrey Sidorenko,
    31 Michele Simionato, Volker Stolz, Dorai Sitaram, Robert Skeels, Jason
    32 Songhurst, Clifford Stein, Sunnan, Zbigniew Szadkowski, Mike Thomas,
    33 Minh Thu, Christian Tismer, Andre van Tonder, John Tobey, Henrik
    34 Tramberend, Vladimir Tsichevsky, Neil van Dyke, Sander Vesik,
    35 Panagiotis Vossos, Shawn Wagner, Peter Wang, Ed Watkeys, Thomas
    36 Weidner, Goeran Weinholt, Matthew Welland, Joerg Wittenberger, Peter
    37 Wright, Mark Wutka, Richard Zidlicky and Houman Zolfaghari for
    38 bug-fixes, tips and suggestions.
     18Bruce Hoult, Hans HÃŒbner, Markus HÃŒlsmann, Goetz Isenmann, Paulo
     19Jabardo, David Janssens, Christian Jaeger, Dale Jordan, Valentin
     20Kamyshenko, Daishi Kato, Peter Keller, Brad Kind, Ron Kneusel,
     21Matthias Koeppe, Krysztof Kowa&#322;czyk, Todd R. Kueny Sr, Goran
     22Krampe, Micky Latowicki, John Lenz, Kirill Lisovsky, Kon Lovett,
     23Dennis Marti, Charles Martin, Bob McIsaac, Alain Mellan, Eric Merrit,
     24Perry Metzger, Scott G. Miller, Mikael, Bruce Mitchener, Chris Moline,
     25Eric E. Moore, Julian Morrison, Dan Muresan, Lars Nilsson, Ian
     26Oversby, o.t., Gene Pavlovsky, Levi Pearson, Nicolas Pelletier, Carlos
     27Pita, Robin Lee Powell, Pupeno, Davide Puricelli, Doug Quale, Eric
     28Raible, Joel Reymont, Andreas Rottman, David Rush, Lars Rustemeier,
     29Daniel Sadilek, Oskar Schirmer, Burton Samograd, Reed Sheridan, Ronald
     30Schröder, Spencer Schumann, Alex Shinn, Shmul, Tony Sidaway, Jeffrey
     31B. Siegal, Andrey Sidorenko, Michele Simionato, Volker Stolz, Dorai
     32Sitaram, Robert Skeels, Jason Songhurst, Clifford Stein, Sunnan,
     33Zbigniew Szadkowski, Mike Thomas, Minh Thu, Christian Tismer, Andre
     34van Tonder, John Tobey, Henrik Tramberend, Vladimir Tsichevsky, Neil
     35van Dyke, Sander Vesik, Panagiotis Vossos, Shawn Wagner, Peter Wang,
     36Ed Watkeys, Thomas Weidner, Goeran Weinholt, Matthew Welland, Joerg
     37Wittenberger, Peter Wright, Mark Wutka, Richard Zidlicky and Houman
     38Zolfaghari for bug-fixes, tips and suggestions.
    3939
    4040CHICKEN uses the PCRE regular expression package ([[http://www.pcre.org]]),
Note: See TracChangeset for help on using the changeset viewer.