Changeset 14954 in project for chicken


Ignore:
Timestamp:
06/09/09 16:59:58 (10 years ago)
Author:
felix winkelmann
Message:

merged trunk rev. 14940 into prerelease branch

Location:
chicken/branches/prerelease
Files:
4 deleted
69 edited
13 copied

Legend:

Unmodified
Added
Removed
  • chicken/branches/prerelease

  • chicken/branches/prerelease/ANNOUNCE

    r13879 r14954  
    22
    33Version 4.0.0 of CHICKEN, the portable and practical Scheme system has
    4 been released. In addition to many bugfixes and cleaning up, it
    5 provides the following significant changes:
    6 
    7 - PCRE has been replaced by Alex Shinn's excellent "IrRegex" regular
    8   expression package (while still being API compatible to the old
    9   regular expression subsystem)
    10 
    11 - New implementations of tools to download, build and install
    12   extension libraries, which are easier to use and provide more
    13   flexibility (like download extensions via Subversion or install       
    14   from a local tree)
     4been released. In addition to many bugfixes and cleaning up, it provides
     5the following significant changes:
    156
    167- The macro system has been completely rewritten and is now fully
     
    2213  macros and still integrates with separate and cross compilation
    2314
    24 - A new optimization mode "local" enables inlining of definitions that
    25   are still visible from other compilation units
     15- The PCRE-based regular regex code has been replaced by Alex Shinn's
     16  excellent "IrRegex" regular expression package (while still being
     17  API compatible to the old regular expression subsystem)
    2618
    27 - Better support for building and using CHICKEN on Windows (mingw and
    28   msys)
     19- New implementations of the tools for download, build and install
     20  extension libraries, which are easier to use and provide more
     21  flexibility than the old `chicken-setup'
     22
     23- A new optimization mode "local" enables inlining of definitions
     24  that are still visible from other compilation units
     25
     26- Better support for build and use on Windows (mingw and msys)
    2927
    3028- Experimental support for cross-module inlining
     
    3937  http://mail.nongnu.org/mailman/listinfo/chicken-hackers
    4038
    41 To follow the latest development, check out
    42 
    43   https://galinha.ucpel.tche.br/svn/chicken-eggs
    44 
    45 Many thanks to Alaric for providing this read-only mirror (updated
    46 daily):
    47 
    48   http://chicken.kitten-technologies.co.uk/svn
    49 
    5039Send bug reports to to <chicken-janitors@nongnu.org> or use the
    5140`chicken-bug' program.
  • chicken/branches/prerelease/Makefile

    r13240 r14954  
    4747        @echo "  $(MAKE) PLATFORM=solaris"
    4848        @echo "  $(MAKE) PLATFORM=cross-linux-mingw"
    49         @echo "  $(MAKE) PLATFORM=msvc"
    5049        @echo ""
    5150        @echo "For more information, consult the README file."
     
    8180bench:
    8281        $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bench
     82scrutiny:
     83        $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) scrutiny
    8384endif
  • chicken/branches/prerelease/Makefile.bsd

    r13240 r14954  
    5454include $(SRCDIR)/defaults.make
    5555
     56# These may be useful for NetBSD:
     57#
     58#C_COMPILER_OPTIONS += -I/usr/pkg/lib
     59#LINKER_OPTIONS += -L/usr/pkg/lib -Wl,-R/usr/pkg/lib
     60
    5661chicken-config.h: chicken-defaults.h
    5762        echo "#define HAVE_DIRENT_H 1" >$@
  • chicken/branches/prerelease/Makefile.macosx

    r13240 r14954  
    5858APPLY_HACK_OBJECT = apply-hack.$(ARCH)$(O)
    5959
     60# architectures
     61
     62ifeq ($(ARCH),x86-64)
     63C_COMPILER_OPTIONS += -m64
     64LINKER_OPTIONS += -m64
     65else
     66
     67ifeq ($(ARCH),universal)
     68C_COMPILER_OPTIONS += -arch ppc -arch i386 -isysroot /Developer/SDKs/MacOSX10.4u.sdk
     69LINKER_OPTIONS += -arch ppc -arch i386 -isysroot /Developer/SDKs/MacOSX10.4u.sdk
     70
     71ifneq ($(HACKED_APPLY),)
     72# We undefine HACKED_APPLY in order to override rules.make.
     73HACKED_APPLY=
     74apply-hack.ppc.darwin$(O): apply-hack.ppc.darwin.s
     75        as -arch ppc -o $@ $<
     76apply-hack.x86$(O): apply-hack.x86.s
     77        as -arch i386 -o $@ $<
     78$(APPLY_HACK_OBJECT): apply-hack.x86$(O) apply-hack.ppc.darwin$(O)
     79        lipo -create -output $(APPLY_HACK_OBJECT) $^
     80endif
     81endif
     82endif
     83
    6084# select default and internal settings
    6185
     
    103127        cat chicken-defaults.h >>$@
    104128
    105 # architectures
    106 
    107 ifeq ($(ARCH),x86-64)
    108 C_COMPILER_OPTIONS += -m64
    109 LINKER_OPTIONS += -m64
    110 else
    111 
    112 ifeq ($(ARCH),universal)
    113 C_COMPILER_OPTIONS += -arch ppc -arch i386 -isysroot /Developer/SDKs/MacOSX10.4u.sdk
    114 LINKER_OPTIONS += -arch ppc -arch i386 -isysroot /Developer/SDKs/MacOSX10.4u.sdk
    115 
    116 ifneq ($(HACKED_APPLY),)
    117 # We undefine HACKED_APPLY in order to override rules.make.
    118 HACKED_APPLY=
    119 apply-hack.ppc.darwin$(O): apply-hack.ppc.darwin.s
    120         as -arch ppc -o $@ $<
    121 apply-hack.x86$(O): apply-hack.x86.s
    122         as -arch i386 -o $@ $<
    123 $(APPLY_HACK_OBJECT): apply-hack.x86$(O) apply-hack.ppc.darwin$(O)
    124         lipo -create -output $(APPLY_HACK_OBJECT) $^
    125 endif
    126 
    127 endif
    128 endif
    129 
    130129include $(SRCDIR)/rules.make
  • chicken/branches/prerelease/Makefile.mingw

    r13859 r14954  
    3333DLLSINPATH = 1
    3434ARCH = x86
    35 HACKED_APPLY = 1
    3635WINDOWS = 1
    3736WINDOWS_SHELL = 1
    3837UNAME_SYS = MinGW
     38
     39ifeq ($(ARCH),x86)
     40HACKED_APPLY = 1
     41else
     42HACKED_APPLY =
     43endif
    3944
    4045# file extensions
  • chicken/branches/prerelease/NEWS

    r13859 r14954  
     14.0.1
     2
     3- Added `er-macro-transformer'; Low-level syntax definitions should use
     4  this procedure to generate transformers from now on
     5
    164.0.0
    27
  • chicken/branches/prerelease/README

    r14094 r14954  
    44  (c) 2008-2009, The Chicken Team
    55
    6   version 4.0.0x5
     6  version 4.0.7
    77
    88
     
    6565        Enter "make" without any options to see a list of supported
    6666        platforms.
     67
     68        Note that parallel builds (using the "-j" make(1) option) is
     69        *not* supported.
    6770
    6871        If you build CHICKEN directly from the development sources out
     
    236239          % unlimit datasize
    237240
     241        - Using external libraries on NetBSD may also be easier, if
     242          you add the following definitions to `Makefile.bsd':
     243
     244            C_COMPILER_OPTIONS += -I/usr/pkg/lib
     245            LINKER_OPTIONS += -L/usr/pkg/lib -Wl,-R/usr/pkg/lib
     246
     247          Note that this may cause build-problems, if you already have
     248          an existing CHICKEN installation in the /usr/pkg prefix.
     249
    238250        - For Mac OS X, Chicken requires libdl, for loading compiled
    239251          code dynamically. This library is available on Mac OS X 10.4
     
    259271            make PLATFORM=macosx ARCH=x86-64
    260272
    261         - On Windows, mingw32, <http://mingw.sourceforge.net/>,
    262           Cygwin, and Visual C/C++ (PLATFORM=msvc) are supported.
     273        - On Windows, mingw32, <http://mingw.sourceforge.net/> and
     274          Cygwin are supported (Microsoft Visual Studio is *NOT*).
    263275          Makefiles for mingw under MSYS and Windows shell are provided
    264276          (`Makefile.mingw-msys' and `Makefile.mingw'). Please also
    265           read the notes below:
     277          read the notes below.
    266278
    267279        - When installing under the mingw-msys platform, PREFIX must be an
     
    286298          when compiling the system or compiled Scheme files. These
    287299          warnings are bogus and can be ignored.
    288 
    289         - The Visual C build requires GNU make and other POSIX
    290           utilities.  Both cygwin and msys (with the Developer's
    291           Toolkit) have the necessary utilities. When setting PREFIX,
    292           use forward slashes:
    293 
    294           make PLATFORM=msvc PREFIX=c:/development/chicken
    295 
    296           The build has been tested with Visual Studio 2003 and 2008.  If
    297           you are able to build Chicken with other versions, please let
    298           us know.
    299 
    300           The following additional issues apply when using Chicken with
    301           Visual C:
    302 
    303           - Add the /DPIC flag when compiling your source files.  Otherwise
    304             you will encounter undefined symbols when linking.  Note that csc
    305             does this automatically for dlls but NOT for programs.
    306 
    307           - csc generates dynamics libraries with a .so extension, not .dll.
    308300
    309301 6. Emacs support:
  • chicken/branches/prerelease/TODO

    r13876 r14954  
    1616*** check in foreign.import.scm and compiler.import.scm whether the import
    1717    took place in the compiler
     18*** -prologue, -epilogue, -prelude, -postlude should check for argument being directory
     19    (reported by Eduardo Cavazos)
    1820
    1921** expander
     
    2628    at all
    2729**** a possible solution is to use internal forms, provided by the "scheme" module.
     30*** need way to force generating module-registration code for standalone executables.
    2831
    2932** modules
     
    4649    reverted original patch, see patches/finalizer-closures.diff
    4750
     51** tools
     52*** chicken-bug: SMTP servers not accessible
     53
     54** build
     55*** somehow get SONAME to work
     56*** integrate and build/install chicken-base.scm
     57
     58** tests
     59*** should run without installation
     60
     61** setting nursery default size doesn't seem to work properly (reported by Zbigniew)
     62
    4863
    4964* tasks
     
    5166** branches
    5267*** try to improve performance in lazy-gensyms
    53 
    54 ** expander
    55 *** test new implementation of `define-for-syntax'
    56 **** test "numbers" egg
    57 **** is s48-modules still working?
    58 *** at some stage remove debug-output in expand.scm
    5968
    6069** module issues
     
    7382
    7483** compiler
    75 *** test define-rewrite-rule
    7684*** (csc) generate object-files in /tmp (or TMPDIR)?
    7785
     
    8189**** handle redirects in http-fetch
    8290**** option in chicken-install to list available eggs
    83 *** automatically update db after extension installation?
    84 *** test sudo
    8591
    8692** library units
     
    99105    then tell Toby Butzon about it
    100106*** test DESTDIR and proper linking
    101 *** test special status of setup-api.import.scm and setup-download.import.scm
    102     touching .c files caused chicken-install to be rebuilt; did using
    103     .SECONDARY help?
    104107*** using "touch" with WINDOWS_SHELL won't work (need alternative)
    105108*** extend scripts/guess-platforms.sh for more platforms
     
    107110** documentation
    108111*** document qs, normalize-pathname
     112
     113** scrutiny
     114*** allow giving toplevel procedure names to `scrutinize' option?
     115*** write test file to trigger every type of warning (diff with result file in test-suite)
     116*** add support for keyword arguments and check even length and available keywords
     117
     118
     119* wiki
     120
     121** compatibility page
     122
     123
     124* extensions
     125
     126** check status of `s48-modules'
    109127
    110128
     
    115133*** fully compiled ec-tests
    116134** 3-stage bootstrap with compiler-output comparison
    117 
    118 
    119 * documentation
    120 
    121 ** document new .meta entries in tutorials on wiki
    122    depends, test-depends
    123 ** chicken.texi needs to be regenerated
    124135
    125136
  • chicken/branches/prerelease/batch-driver.scm

    r13859 r14954  
    3535  compiler-arguments process-command-line dump-nodes dump-undefined-globals
    3636  default-standard-bindings default-extended-bindings
    37   foldable-bindings
     37  foldable-bindings dump-defined-globals apply-pre-cps-rewrite-rules!
    3838  compiler-cleanup-hook disabled-warnings local-definitions inline-output-file
    3939  file-io-only undefine-shadowed-macros profiled-procedures
    40   unit-name insert-timer-checks used-units inline-max-size inline-locally
     40  unit-name insert-timer-checks used-units inline-max-size mark-variable inline-locally
    4141  debugging perform-lambda-lifting! disable-stack-overflow-checking
    4242  foreign-declarations emit-trace-info block-compilation line-number-database-size
     
    6464  default-declarations units-used-by-default words-per-flonum default-debugging-declarations
    6565  default-profiling-declarations default-optimization-passes
    66   file-requirements import-libraries inline-globally
     66  file-requirements import-libraries inline-globally scrutinize do-scrutinize enable-inline-files
    6767  foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators
    6868  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
     
    7070  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
    7171  do-lambda-lifting compiler-warning emit-global-inline-file load-inline-file
    72   foreign-argument-conversion foreign-result-conversion)
     72  foreign-argument-conversion foreign-result-conversion
     73  load-identifier-database load-type-database
     74  no-bound-checks no-argc-checks no-procedure-checks)
    7375
    7476
     
    8284(define user-preprocessor-pass (make-parameter #f))
    8385(define user-pass (make-parameter #f))
    84 (define user-pass-2 (make-parameter #f))
    8586(define user-post-analysis-pass (make-parameter #f))
    8687
     
    229230           (collect-options 'emit-import-library)))
    230231    (when (memq 'lambda-lift options) (set! do-lambda-lifting #t))
     232    (when (memq 'scrutinize options) (set! do-scrutinize #t))
    231233    (when (memq 't debugging-chicken) (##sys#start-timer))
    232234    (when (memq 'b debugging-chicken) (set! time-breakdown #t))
     
    242244      (set! local-definitions #t))
    243245    (when (memq 'inline-global options)
     246      (set! enable-inline-files #t)
    244247      (set! inline-locally #t)
    245248      (set! inline-globally #t))
     
    303306    (when (memq 'keep-shadowed-macros options)
    304307      (set! undefine-shadowed-macros #f) )
     308    (when (memq 'no-argc-checks options)
     309      (set! no-argc-checks #t) )
     310    (when (memq 'no-bound-checks options)
     311      (set! no-bound-checks #t) )
     312    (when (memq 'no-procedure-checks options)
     313      (set! no-procedure-checks #t) )
     314    (when (memq 'no-procedure-checks-for-usual-bindings options)
     315      (for-each
     316       (lambda (v)
     317         (mark-variable v '##compiler#always-bound-to-procedure)
     318         (mark-variable v '##compiler#always-bound) )
     319       default-standard-bindings)
     320      (for-each
     321       (lambda (v)
     322         (mark-variable v '##compiler#always-bound-to-procedure)
     323         (mark-variable v '##compiler#always-bound) )
     324       default-extended-bindings) )
    305325
    306326    ;; Handle feature options:
     
    378398
    379399    ;;*** hardcoded "modules.db" is bad (also used in chicken-install.scm)
    380     (and-let* ((rp (repository-path))
    381                (dbfile (file-exists? (make-pathname rp "modules.db"))))
    382       (dribble "loading database ~a ..." dbfile)
    383       (for-each
    384        (lambda (e)
    385          (##sys#put!
    386           (car e) '##core#db
    387           (append (or (##sys#get (car e) '##core#db) '()) (list (cdr e))) ))
    388        (read-file dbfile)))
     400    (load-identifier-database "modules.db")
    389401
    390402    (cond ((memq 'version options)
     
    502514                 (end-time "user pass") ) )
    503515
    504              (let ((req (concatenate (vector->list file-requirements))))
    505                (when (debugging 'M "; requirements:")
    506                  (pp req))
    507                (when inline-globally
    508                  (for-each
    509                   (lambda (id)
    510                     (and-let* ((ifile (##sys#resolve-include-filename
    511                                        (make-pathname #f (symbol->string id) "inline")
    512                                        #f #t))
    513                                ((file-exists? ifile)))
    514                       (dribble "Loading inline file ~a ..." ifile)
    515                       (load-inline-file ifile)))
    516                   (concatenate (map cdr req)))))
    517 
    518              (let* ([node0 (make-node
    519                             'lambda '(())
    520                             (list (build-node-graph
    521                                    (canonicalize-begin-body exps) ) ) ) ]
    522                     [proc (user-pass-2)] )
    523                (when proc
    524                  (dribble "Secondary user pass...")
     516             (let ((node0 (make-node
     517                           'lambda '(())
     518                           (list (build-node-graph
     519                                  (canonicalize-begin-body exps) ) ) ) )
     520                   (db #f))
     521
     522               (when do-scrutinize
     523                 ;;;*** hardcoded database file name
     524                 (unless (memq 'ignore-repository options)
     525                   (load-type-database "types.db"))
     526                 (for-each (cut load-type-database <> #f) (collect-options 'types))
    525527                 (begin-time)
    526528                 (set! first-analysis #f)
    527                  (let ([db (analyze 'user node0)])
    528                    (print-db "analysis (u)" '|0| db 0)
    529                    (end-time "pre-analysis (u)")
    530                    (begin-time)
    531                    (proc node0)
    532                    (end-time "secondary user pass")
    533                    (print-node "secondary user pass" '|U| node0) )
     529                 (set! db (analyze 'scrutiny node0))
     530                 (print-db "analysis" '|0| db 0)
     531                 (end-time "pre-analysis")
     532                 (begin-time)
     533                 (debugging 'p "performing scrutiny")
     534                 (scrutinize node0 db)
     535                 (end-time "scrutiny")
    534536                 (set! first-analysis #t) )
    535537
    536538               (when do-lambda-lifting
    537539                 (begin-time)
     540                 (unless do-scrutinize  ; no need to do analysis if already done above
     541                   (set! first-analysis #f)
     542                   (set! db (analyze 'lift node0))
     543                   (print-db "analysis" '|0| db 0)
     544                   (end-time "pre-analysis (lambda-lift)"))
     545                 (begin-time)
     546                 (perform-lambda-lifting! node0 db)
     547                 (end-time "lambda lifting")
     548                 (print-node "lambda lifted" '|L| node0)
     549                 (set! first-analysis #t) )
     550
     551               #;(begin
     552                 (begin-time)
    538553                 (set! first-analysis #f)
    539                  (let ([db (analyze 'lift node0)])
    540                    (print-db "analysis" '|0| db 0)
    541                    (end-time "pre-analysis")
    542                    (begin-time)
    543                    (perform-lambda-lifting! node0 db)
    544                    (end-time "lambda lifting")
    545                    (print-node "lambda lifted" '|L| node0) )
     554                 (set! db (analyze 'rewrite node0))
     555                 (print-db "analysis" '|0| db 0)
     556                 (end-time "pre-analysis (rewrite)")
     557                 (begin-time)
     558                 (apply-pre-cps-rewrite-rules! node0 db)
     559                 (end-time "applying pre-CPS rewrite rules")
     560                 (print-node "applied pre-CPS rewrite rules" '|R| node0)
    546561                 (set! first-analysis #t) )
     562
     563               (let ((req (concatenate (vector->list file-requirements))))
     564                 (when (debugging 'M "; requirements:")
     565                   (pp req))
     566                 (when enable-inline-files
     567                   (for-each
     568                    (lambda (id)
     569                      (and-let* ((ifile (##sys#resolve-include-filename
     570                                         (make-pathname #f (symbol->string id) "inline")
     571                                         #f #t))
     572                                 ((file-exists? ifile)))
     573                        (dribble "Loading inline file ~a ..." ifile)
     574                        (load-inline-file ifile)))
     575                    (concatenate (map cdr req))) )
     576                 (let ((ifs (collect-options 'consult-inline-file)))
     577                   (unless (null? ifs)
     578                     (set! inline-globally #t)
     579                     (set! inline-locally #t)
     580                     (for-each
     581                      (lambda (ilf)
     582                        (dribble "Loading inline file ~a ..." ilf)
     583                        (load-inline-file ilf) )
     584                      ifs))))
    547585
    548586               (set! ##sys#line-number-database #f)
     
    564602                     (when first-analysis
    565603                       (when (memq 'u debugging-chicken)
    566                          (dump-undefined-globals db)) )
     604                         (dump-undefined-globals db))
     605                       (when (memq 'd debugging-chicken)
     606                         (dump-defined-globals db)) )
    567607                     (set! first-analysis #f)
    568608                     (end-time "analysis")
  • chicken/branches/prerelease/buildversion

    r13249 r14954  
    1 4.0.0
     14.0.7
  • chicken/branches/prerelease/c-backend.scm

    r13240 r14954  
    11921192      [(f32vector nonnull-f32vector) (str "float *")]
    11931193      [(f64vector nonnull-f64vector) (str "double *")]
    1194       [(nonnull-c-string c-string nonnull-c-string* c-string*
    1195                          nonnull-unsigned-c-string nonnull-unsigned-c-string* unsigned-c-string*
    1196                          symbol) (str "char *")]
     1194      [(nonnull-c-string c-string nonnull-c-string* c-string* symbol)
     1195       (str "char *")]
     1196      [(nonnull-unsigned-c-string nonnull-unsigned-c-string* unsigned-c-string unsigned-c-string*)
     1197       (str "unsigned char *")]
    11971198      [(void) (str "void")]
    11981199      [else
  • chicken/branches/prerelease/c-platform.scm

    r13859 r14954  
    116116  '(-help h help version verbose explicit-use
    117117          quiet                         ; DEPRECATED
    118           no-trace no-warnings unsafe block
     118          no-trace no-warnings unsafe block 
    119119    check-syntax to-stdout no-usual-integrations case-insensitive no-lambda-info
    120120    profile inline keep-shadowed-macros ignore-repository
     
    123123    disable-stack-overflow-checks disable-c-syntax-checks unsafe-libraries raw
    124124    emit-external-prototypes-first release local inline-global
    125     analyze-only dynamic
     125    analyze-only dynamic scrutinize no-argc-checks no-procedure-checks
     126    no-bound-checks no-procedure-checks-for-usual-bindings
    126127    no-parentheses-synonyms no-symbol-escape r5rs-syntax) )
    127128
     
    129130  '(debug output-file include-path heap-size stack-size unit uses keyword-style require-extension
    130131          inline-limit profile-name disable-warning parenthesis-synonyms
    131     prelude postlude prologue epilogue nursery extend feature
    132     emit-import-library emit-inline-file static-extension
     132    prelude postlude prologue epilogue nursery extend feature types
     133    emit-import-library emit-inline-file static-extension consult-inline-file
    133134    heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path) )
    134135
  • chicken/branches/prerelease/chicken-bug.scm

    r13876 r14954  
    3535(define-constant +destination+ "chicken-janitors@nongnu.org")
    3636(define-constant +mxservers+ (list "mx10.gnu.org" "mx20.gnu.org"))
     37(define-constant +send-tries+ 3)
    3738
    3839(define-foreign-variable +cc+ c-string "C_TARGET_CC")
     
    239240
    240241(define (send-mail serv msg hdrs fname)
    241   (print "connecting to " serv " ...")
    242     (receive (i o)
    243         (tcp-connect serv 25)
    244         (call-with-current-continuation
    245             (lambda (k)
    246                 (mail-check i o (mail-read i o) 220 k)
    247                 (mail-check i o (mail-write i o "HELO callcc.org\r\n") 250 k)
    248                 (mail-check i o (mail-write i o "MAIL FROM:<chicken-bug-command@callcc.org>\r\n") 250 k)
    249                 (mail-check i o (mail-write i o "RCPT TO:<chicken-janitors@nongnu.org>\r\n") 250 k)
    250                 (mail-check i o (mail-write i o "DATA\r\n") 354 k)
    251                 (mail-check i o (mail-write i o (string-append hdrs fname "\r\n\r\n" msg "\r\n.\r\n")) 250 k)
    252                 (display "QUIT" o)
    253                 (close-input-port i)
    254                 (close-output-port o)
    255                 (print "Bug report successfully mailed to the Chicken maintainers.\nThank you very much!\n\n")
    256                 #t))))
     242  (call/cc
     243   (lambda (return)
     244     (do ((try 1 (add1 try)))
     245         ((> try +send-tries+))
     246       (print* "connecting to " serv ", try #" try " ...")
     247       (receive (i o)
     248           (tcp-connect serv 25)
     249         (call-with-current-continuation
     250          (lambda (k)
     251            (mail-check i o (mail-read i o) 220 k)
     252            (mail-check i o (mail-write i o "HELO callcc.org\r\n") 250 k)
     253            (mail-check i o (mail-write i o "MAIL FROM:<chicken-bug-command@callcc.org>\r\n") 250 k)
     254            (mail-check i o (mail-write i o "RCPT TO:<chicken-janitors@nongnu.org>\r\n") 250 k)
     255            (mail-check i o (mail-write i o "DATA\r\n") 354 k)
     256            (mail-check i o (mail-write i o (string-append hdrs fname "\r\n\r\n" msg "\r\n.\r\n")) 250 k)
     257            (display "QUIT" o)
     258            (close-input-port i)
     259            (close-output-port o)
     260            (print "ok.\n\nBug report successfully mailed to the Chicken maintainers.\nThank you very much!\n\n")
     261            (return #t))))
     262       (print " failed.")))))
    257263
    258264(main (command-line-arguments))
  • chicken/branches/prerelease/chicken-install.scm

    r13859 r14954  
    2828(require-library srfi-1 posix data-structures utils regex ports extras
    2929                 srfi-13 files)
     30(require-library chicken-syntax)        ; in case an import library reexports chicken syntax
    3031
    3132
     
    129130               (if a
    130131                   (->string (cadr a))
    131                    "1.0.0"))))
     132                   "0.0.0"))))
    132133          (else #f)))
    133134
     
    152153                     (let ((v (ext-version (car dep))))
    153154                       (cond ((not v)
    154                               (warning
    155                                "installed extension has unknown version - assuming it is outdated"
    156                                (car dep))
    157                               (loop rest missing
    158                                     (alist-cons
    159                                      (->string (car dep))
    160                                      (->string (cadr dep))
    161                                      upgrade)))
    162                              ((version>=? (->string (cadr dep)) v)
     155                              (loop rest (cons (->string (car dep)) missing) upgrade))
     156                             ((not (version>=? v (->string (cadr dep))))
     157                              (when (string=? "chicken" (->string (car dep)))
     158                                (error
     159                                 (string-append
     160                                  "Your CHICKEN version is not recent enough to use this extension - version "
     161                                  (cadr dep)
     162                                  " or newer is required")))
    163163                              (loop rest missing
    164164                                    (alist-cons
     
    318318           (dbfile (make-pathname tmpdir +module-db+))
    319319           (rx (regexp ".*/([^/]+)\\.import\\.(scm|so)")))
     320      (print "loading import libraries ...")
    320321      (fluid-let ((##sys#warnings-enabled #f))
    321322        (for-each
    322323         (lambda (f)
    323324           (let ((m (string-match rx f)))
    324              (eval `(import ,(string->symbol (cadr m))))))
     325             (handle-exceptions ex
     326                 (print-error-message
     327                  ex (current-error-port)
     328                  (sprintf "Failed to import from `~a'" f))
     329               (eval `(import ,(string->symbol (cadr m)))))))
    325330         files))
    326331      (print "generating database")
     
    493498
    494499  (register-feature! 'chicken-install)
    495   (define ##compiler#compiler-macro-environment '()) ; only to make `compiler' import work
    496500
    497501  (handle-exceptions ex
  • chicken/branches/prerelease/chicken-primitive-object-inlines.scm

    r13859 r14954  
    671671                 (find-elm (%cdr ls) ls) ) ) ) )
    672672
    673 (define-inline (%list-fold-1 func init ls0)
     673(define-inline (%list-fold/1 func init ls0)
    674674  ;(assert (and (proper-list? ls0) (procedure? func)))
    675675  (let loop ((ls ls0) (acc init))
     
    677677        (loop (%cdr ls) (func (%car ls) acc)) ) ) )
    678678
    679 (define-inline (%list-map-1 func ls0)
     679(define-inline (%list-map/1 func ls0)
    680680  ;(assert (and (proper-list? ls0) (procedure? func)))
    681681  (let loop ((ls ls0))
     
    683683        (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
    684684
    685 (define-inline (%list-for-each-1 proc ls0)
     685(define-inline (%list-for-each/1 proc ls0)
    686686  ;(assert (and (proper-list? ls0) (procedure? proc)))
    687687  (let loop ((ls ls0))
     
    689689      (proc (%car ls))
    690690      (loop (%cdr ls)) ) ) )
     691
     692(define-inline (%list/1 obj) (%cons obj '()))
     693
     694(define-inline (%list . objs)
     695  (let loop ((objs objs))
     696    (if (%null? objs) '()
     697        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     698
     699(define-inline (%make-list n e)
     700  (let loop ((n n) (ls '()))
     701    (if (%fxzero? n) ls
     702        (loop (%fxsub1 n) (%cons e ls)) ) ) )
     703
     704(define-inline (%list-take ls0 n)
     705  (let loop ((ls ls0) (n n))
     706    (if (%fxzero? n) '()
     707        (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
     708
     709(define-inline (%list-drop ls0 n)
     710  (let loop ((ls ls0) (n n))
     711    (if (%fxzero? n) ls
     712        (loop (%cdr ls) (%fxsub1 n)) ) ) )
     713
     714(define-inline (%any/1 pred? ls)
     715  (let loop ((ls ls))
     716    (and (not (%null? ls))
     717         (or (pred? (%car ls))
     718             (loop (%cdr ls)) ) ) ) )
     719
     720(define-inline (%list-length ls0)
     721  (let loop ((ls ls0) (n 0))
     722    (if (%null? ls) n
     723        (loop (%cdr ls) (%fxadd1 n)) ) ) )
    691724
    692725;; Structure (wordblock)
     
    723756
    724757(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    725 (define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
    726 (define-inline (%port-class port) (%wordblock-ref? port 2))
    727 (define-inline (%port-name port) (%wordblock-ref? port 3))
    728 (define-inline (%port-row port) (%wordblock-ref? port 4))
    729 (define-inline (%port-column port) (%wordblock-ref? port 5))
    730 (define-inline (%port-eof? port) (%wordblock-ref? port 6))
    731 (define-inline (%port-type port) (%wordblock-ref? port 7))
    732 (define-inline (%port-closed? port) (%wordblock-ref? port 8))
    733 (define-inline (%port-data port) (%wordblock-ref? port 9))
     758(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
     759(define-inline (%port-class port) (%wordblock-ref port 2))
     760(define-inline (%port-name port) (%wordblock-ref port 3))
     761(define-inline (%port-row port) (%wordblock-ref port 4))
     762(define-inline (%port-column port) (%wordblock-ref port 5))
     763(define-inline (%port-eof? port) (%wordblock-ref port 6))
     764(define-inline (%port-type port) (%wordblock-ref port 7))
     765(define-inline (%port-closed? port) (%wordblock-ref port 8))
     766(define-inline (%port-data port) (%wordblock-ref port 9))
     767
     768(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
     769(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
    734770
    735771(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
     
    818854    (##core#inline "C_vector_to_closure" v)
    819855    v ) )
     856
     857(define-inline (%procedure? x) (%closure? x))
    820858
    821859(define-inline (%vector->closure! v a)
     
    9651003(define-inline (%number? x) (or (%fixnum? x) (%flonum? x)))
    9661004(define-inline (%integer? x) (##core#inline "C_i_integerp" x))
    967 
    968 (define-inline (%= x y) ((##core#primitive "C_i_eqvp") x y))
    969 (define-inline (%< x y) ((##core#primitive "C_i_lessp") x y))
    970 (define-inline (%<= x y) ((##core#primitive "C_i_less_or_equalp") x y))
    971 (define-inline (%> x y) ((##core#primitive "C_i_greaterp") x y))
    972 (define-inline (%>= x y) ((##core#primitive "C_i_greater_or_equalp") x y))
     1005(define-inline (%exact? x) (##core#inline "C_i_exactp" x))
     1006(define-inline (%inexact? x) (##core#inline "C_i_inexactp" x))
     1007
     1008(define-inline (%= x y) (##core#inline "C_i_eqvp" x y))
     1009(define-inline (%< x y) (##core#inline "C_i_lessp" x y))
     1010(define-inline (%<= x y) (##core#inline "C_i_less_or_equalp" x y))
     1011(define-inline (%> x y) (##core#inline "C_i_greaterp" x y))
     1012(define-inline (%>= x y) (##core#inline "C_i_greater_or_equalp" x y))
    9731013
    9741014(define-inline (%zero? n) (##core#inline "C_i_zerop" n))
    9751015(define-inline (%positive? n) (##core#inline "C_i_positivep" n))
    9761016(define-inline (%negative? n) (##core#inline "C_i_negativep" n))
    977 (define-inline (%cardinal? n) (and (%integer? n) (%<= 0 n)))
     1017(define-inline (%cardinal? fx) (%<= 0 fx))
     1018
    9781019(define-inline (%odd? n) (##core#inline "C_i_oddp" n))
    9791020(define-inline (%even? n) (##core#inline "C_i_evenp" n))
  • chicken/branches/prerelease/chicken-syntax.scm

    r13240 r14954  
    770770                                             (if (zero? a2)
    771771                                                 #t
    772                                                  `(,(r 'fx>=) ,lvar ,a2) )
    773                                              `(,(r 'fx=) ,lvar ,a2) ) )
     772                                                 `(,(r '>=) ,lvar ,a2) )
     773                                             `(,(r 'eq?) ,lvar ,a2) ) )
    774774                                      ,(receive (vars1 vars2)
    775775                                           (split-at! (take vars argc) mincount)
  • chicken/branches/prerelease/chicken.h

    r13414 r14954  
    829829# define C_fputc                    fputc
    830830# define C_putchar                  putchar
     831# if (defined getc_unlocked || _POSIX_C_SOURCE >= 199506L)
     832#  define C_getc                    getc_unlocked
     833# else
     834#  define C_getc                    getc
     835# endif
    831836# define C_fgetc                    fgetc
    832837# define C_fgets                    fgets
     
    857862
    858863#define C_return(x)                return(x)
    859 
    860 #ifdef C_DEFAULT_TARGET_STACK_SIZE
    861 # define C_resize_stack(n)           C_do_resize_stack(C_DEFAULT_TARGET_STACK_SIZE)
    862 #else
    863 # define C_resize_stack(n)           C_do_resize_stack(n)
    864 #endif
    865 
     864#define C_resize_stack(n)          C_do_resize_stack(n)
    866865#define C_memcpy_slots(t, f, n)    C_memcpy((t), (f), (n) * sizeof(C_word))
    867866#define C_block_header(x)          (((C_SCHEME_BLOCK *)(x))->header)
     
    10381037#define C_words(n)                      C_fix(C_bytestowords(C_unfix(n)))
    10391038#define C_bytes(n)                      C_fix(C_wordstobytes(C_unfix(n)))
    1040 #define C_random_fixnum(n)              C_fix(rand() % C_unfix(n))
     1039#define C_random_fixnum(n)              C_fix((int)(((double)rand())/(RAND_MAX + 1.0) * C_unfix(n)))
    10411040#define C_randomize(n)                  (srand(C_unfix(n)), C_SCHEME_UNDEFINED)
    10421041#define C_block_size(x)                 C_fix(C_header_size(x))
  • chicken/branches/prerelease/chicken.import.scm

    r13859 r14954  
    169169   remprop!
    170170   rename-file
     171   repl
     172   repl-prompt
    171173   repository-path
    172174   require
     
    200202   void
    201203   warning
     204   eval-handler
     205   dynamic-load-libraries
    202206   with-exception-handler)
    203207 ##sys#chicken-macro-environment)       ;*** incorrect - won't work in compiled executable
  • chicken/branches/prerelease/chicken.scm

    r13240 r14954  
    2727
    2828(declare
    29   (uses chicken-syntax srfi-1 srfi-4 utils files support compiler optimizer driver
     29  (uses chicken-syntax srfi-1 srfi-4 utils files support compiler optimizer scrutinizer driver
    3030        platform backend srfi-69)
    3131  (run-time-macros) )                   ;*** later: compile-syntax
  • chicken/branches/prerelease/compiler.scm

    r13859 r14954  
    6969; (safe-globals)
    7070; (separate)
     71; (type (<symbol> <typespec>) ...)
    7172; (unit <unitname>)
    7273; (unsafe)
    7374; (unused <symbol> ...)
    7475; (uses {<unitname>})
     76; (scrutinize)
    7577;
    7678;   <type> = fixnum | generic
     
    8991;   ##compiler#unused -> BOOL
    9092;   ##compiler#foldable -> BOOL
     93;   ##compiler#rewrite -> PROCEDURE (see `apply-rewrite-rules!')
    9194
    9295; - Source language:
     
    142145; (define-compiled-syntax (<symbol> . <llist>) <expr> ...)
    143146; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
    144 ; (##core#define-rewrite-rule <symbol> <expr>)
    145147
    146148; - Core language:
     
    294296  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
    295297  make-random-name final-foreign-type real-name-table real-name set-real-name! safe-globals-flag
    296   location-pointer-map literal-rewrite-hook inline-globally
    297   local-definitions export-variable variable-mark intrinsic?
     298  location-pointer-map inline-globally enable-inline-files
     299  local-definitions export-variable variable-mark intrinsic? do-scrutinize
    298300  undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info
    299301  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
     
    302304  big-fixnum? import-libraries unlikely-variables)
    303305
     306
     307(define (d arg1 . more)
     308  (if (null? more)
     309      (pp arg1)
     310      (apply print arg1 more)))
     311
     312(define-syntax d (syntax-rules () ((_ . _) (void))))
    304313
    305314(include "tweaks")
     
    368377(define inline-locally #f)
    369378(define inline-output-file #f)
     379(define do-scrutinize #f)
     380(define enable-inline-files #f)
    370381
    371382
     
    414425(define file-requirements #f)
    415426(define postponed-initforms '())
    416 (define literal-rewrite-hook #f)
    417427
    418428
     
    474484        x) )
    475485
    476   (define (resolve-variable x0 se dest)
     486  (define (resolve-variable x0 e se dest)
    477487    (let ((x (lookup x0 se)))
     488      (d `(RESOLVE-VARIABLE: ,x0 ,x ,(map car se)))
    478489      (cond ((not (symbol? x)) x0)      ; syntax?
    479490            [(and constants-used (##sys#hash-table-ref constant-table x))
    480              => (lambda (val) (walk (car val) se dest)) ]
     491             => (lambda (val) (walk (car val) e se dest)) ]
    481492            [(and inline-table-used (##sys#hash-table-ref inline-table x))
    482              => (lambda (val) (walk val se dest)) ]
     493             => (lambda (val) (walk val e se dest)) ]
    483494            [(assq x foreign-variables)
    484495             => (lambda (fv)
     
    490501                      (finish-foreign-result ft body)
    491502                      t)
    492                      se dest)))]
     503                     e se dest)))]
    493504            [(assq x location-pointer-map)
    494505             => (lambda (a)
     
    500511                      (finish-foreign-result ft body)
    501512                      t)
    502                      se dest))) ]
    503             ((not (assq x0 se)) (##sys#alias-global-hook x #f)) ; only if global
     513                     e se dest))) ]
    504514            ((##sys#get x '##core#primitive))
     515            ((not (memq x e)) (##sys#alias-global-hook x #f)) ; only if global
    505516            (else x))))
    506517 
     
    514525       '() ) ))
    515526
    516   (define (walk x se dest)
     527  (define (walk x e se dest)
    517528    (cond ((symbol? x)
    518529           (cond ((keyword? x) `(quote ,x))
     
    521532                   'var
    522533                   "reference to variable `~s' possibly unintended" x) ))
    523            (resolve-variable x se dest))
     534           (resolve-variable x e se dest))
    524535          ((not-pair? x)
    525536           (if (constant? x)
     
    538549                    (xexpanded (##sys#expand x se)))
    539550               (cond ((not (eq? x xexpanded))
    540                       (walk xexpanded se dest))
     551                      (walk xexpanded e se dest))
    541552                     
    542553                     [(and inline-table-used (##sys#hash-table-ref inline-table name))
    543554                      => (lambda (val)
    544                            (walk (cons val (cdr x)) se dest)) ]
     555                           (walk (cons val (cdr x)) e se dest)) ]
    545556                     
    546557                     [else
     
    551562                         (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
    552563                         `(if
    553                            ,(walk (cadr x) se #f)
    554                            ,(walk (caddr x) se #f)
     564                           ,(walk (cadr x) e se #f)
     565                           ,(walk (caddr x) e se #f)
    555566                           ,(if (null? (cdddr x))
    556567                                '(##core#undefined)
    557                                 (walk (cadddr x) se #f) ) ) )
     568                                (walk (cadddr x) e se #f) ) ) )
    558569
    559570                        ((quote syntax)
     
    564575                         (if unsafe
    565576                             ''#t
    566                              (walk (cadr x) se dest) ) )
     577                             (walk (cadr x) e se dest) ) )
    567578
    568579                        ((##core#immutable)
     
    585596                         `(##core#inline_loc_ref
    586597                           ,(##sys#strip-syntax (cadr x))
    587                            ,(walk (caddr x) se dest)))
     598                           ,(walk (caddr x) e se dest)))
    588599
    589600                        ((##core#require-for-syntax)
     
    613624                                         'ext "extension `~A' is currently not installed" id))
    614625                                      `(begin ,exp ,(loop (cdr ids))) ) ) ) )
    615                             se dest) ) )
     626                            e se dest) ) )
    616627
    617628                        ((let ##core#let)
     
    624635                           `(let
    625636                             ,(map (lambda (alias b)
    626                                      (list alias (walk (cadr b) se (car b))) )
     637                                     (list alias (walk (cadr b) e se (car b))) )
    627638                                   aliases bindings)
    628639                             ,(walk (##sys#canonicalize-body (cddr x) se2)
     640                                    (append aliases e)
    629641                                    se2 dest) ) ) )
    630642
    631                          ((letrec ##core#letrec)
    632                           (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
    633                           (let ((bindings (cadr x))
    634                                 (body (cddr x)) )
    635                             (walk
    636                              `(##core#let
    637                                ,(##sys#map (lambda (b)
    638                                              (list (car b) '(##core#undefined)))
    639                                            bindings)
    640                                ,@(##sys#map (lambda (b)
    641                                               `(##core#set! ,(car b) ,(cadr b)))
    642                                             bindings)
    643                                (##core#let () ,@body) )
    644                             se dest)))
     643                        ((letrec ##core#letrec)
     644                         (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
     645                         (let ((bindings (cadr x))
     646                               (body (cddr x)) )
     647                           (walk
     648                            `(##core#let
     649                              ,(map (lambda (b)
     650                                      (list (car b) '(##core#undefined)))
     651                                    bindings)
     652                              ,@(map (lambda (b)
     653                                       `(##core#set! ,(car b) ,(cadr b)))
     654                                     bindings)
     655                              (##core#let () ,@body) )
     656                            e se dest)))
    645657
    646658                        ((lambda ##core#lambda)
     
    659671                                     (se2 (append (map cons vars aliases) se))
    660672                                     (body0 (##sys#canonicalize-body obody se2))
    661                                      (body (walk body0 se2 #f))
     673                                     (body (walk body0 (append aliases e) se2 #f))
    662674                                     (llist2
    663675                                      (build-lambda-list
     
    703715                           (walk
    704716                            (##sys#canonicalize-body (cddr x) se2)
    705                             se2
     717                            e se2
    706718                            dest) ) )
    707719                               
     
    722734                          (walk
    723735                           (##sys#canonicalize-body (cddr x) se2)
    724                            se2 dest)))
     736                           e se2 dest)))
    725737                               
    726738                       ((define-syntax)
     
    748760                                 (##sys#er-transformer ,body)) ;*** possibly wrong se?
    749761                               '(##core#undefined) )
    750                            se dest)) )
     762                           e se dest)) )
    751763
    752764                       ((define-compiled-syntax)
     
    773785                             (##sys#er-transformer
    774786                              ,body)) ;*** possibly wrong se?
    775                            se dest)))
    776 
    777                        ((##core#define-rewrite-rule)
    778                         (let ((name (##sys#strip-syntax (cadr x) se #t))
    779                               (re (caddr x)))
    780                           (##sys#put! name '##compiler#intrinsic 'rewrite)
    781                           (rewrite
    782                            name 8
    783                            (eval/meta re))
    784                           '(##core#undefined)))
     787                           e se dest)))
    785788
    786789                       ((##core#module)
     
    850853                                                 (cons (walk
    851854                                                        (car body)
     855                                                        e ;?
    852856                                                        (##sys#current-environment)
    853857                                                        #f)
     
    859863                                (map
    860864                                 (lambda (x)
    861                                    (walk x (##sys#current-meta-environment) #f) )
     865                                   (walk
     866                                    x
     867                                    e   ;?
     868                                    (##sys#current-meta-environment) #f) )
    862869                                 mreg))
    863870                              body)))))
    864871
    865872                       ((##core#named-lambda)
    866                         (walk `(,(macro-alias 'lambda se) ,@(cddr x)) se (cadr x)) )
     873                        (walk `(,(macro-alias 'lambda se) ,@(cddr x)) e se (cadr x)) )
    867874
    868875                       ((##core#loop-lambda)
     
    874881                                (walk
    875882                                 (##sys#canonicalize-body obody se2)
     883                                 (append aliases e)
    876884                                 se2 #f) ] )
    877885                          (set-real-names! aliases vars)
     
    898906                                               (,(third fv) ,type)
    899907                                               ,(foreign-type-check tmp type) ) )
    900                                            se #f))))
     908                                           e se #f))))
    901909                                 ((assq var location-pointer-map)
    902910                                  => (lambda (a)
     
    909917                                              ,(second a)
    910918                                              ,(foreign-type-check tmp type) ) )
    911                                           se #f))))
    912                                  (else
    913                                   (when (eq? var var0) ; global?
    914                                     (set! var (##sys#alias-global-hook var #t))
     919                                          e se #f))))
     920                                 (else
     921                                  (unless (memq var e) ; global?
     922                                    (set! var (or (##sys#get var '##core#primitive)
     923                                                  (##sys#alias-global-hook var #t)))
    915924                                    (when safe-globals-flag
    916925                                      (mark-variable var '##compiler#always-bound-to-procedure)
    917                                       (mark-variable var '##compiler#always-bound))
    918                                     (when (##sys#macro? var)
    919                                       (compiler-warning
    920                                        'var "assigned global variable `~S' is a macro ~A"
    921                                        var
    922                                        (if ln (sprintf "in line ~S" ln) "") )
    923                                       (when undefine-shadowed-macros (##sys#undefine-macro! var) ) ) )
     926                                      (mark-variable var '##compiler#always-bound)))
     927                                  (when (##sys#macro? var)
     928                                    (compiler-warning
     929                                     'var "assigned global variable `~S' is a macro ~A"
     930                                     var
     931                                     (if ln (sprintf "in line ~S" ln) "") )
     932                                    (when undefine-shadowed-macros (##sys#undefine-macro! var) ) )
    924933                                  (when (keyword? var)
    925934                                    (compiler-warning 'syntax "assignment to keyword `~S'" var) )
     
    927936                                    (syntax-error
    928937                                     'set! "assignment to syntactic identifier" var))
    929                                   `(set! ,var ,(walk val se var0))))))
     938                                  `(set! ,var ,(walk val e se var0))))))
    930939
    931940                        ((##core#inline)
    932                          `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) se)))
     941                         `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se)))
    933942
    934943                        ((##core#inline_allocate)
    935944                         `(##core#inline_allocate
    936945                           ,(map (cut unquotify <> se) (second x))
    937                            ,@(mapwalk (cddr x) se)))
     946                           ,@(mapwalk (cddr x) e se)))
    938947
    939948                        ((##core#inline_update)
    940                          `(##core#inline_update ,(cadr x) ,(walk (caddr x) se #f)) )
     949                         `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f)) )
    941950
    942951                        ((##core#inline_loc_update)
    943952                         `(##core#inline_loc_update
    944953                           ,(cadr x)
    945                            ,(walk (caddr x) se #f)
    946                            ,(walk (cadddr x) se #f)) )
     954                           ,(walk (caddr x) e se #f)
     955                           ,(walk (cadddr x) e se #f)) )
    947956
    948957                        ((##core#compiletimetoo ##core#elaborationtimetoo)
    949958                         (let ((exp (cadr x)))
    950959                           (eval/meta exp)
    951                            (walk exp se dest) ) )
     960                           (walk exp e se dest) ) )
    952961
    953962                        ((##core#compiletimeonly ##core#elaborationtimeonly)
     
    963972                                      [r (cdr xs)] )
    964973                                  (if (null? r)
    965                                       (list (walk x se dest))
    966                                       (cons (walk x se #f) (fold r)) ) ) ) )
     974                                      (list (walk x e se dest))
     975                                      (cons (walk x e se #f) (fold r)) ) ) ) )
    967976                             '(##core#undefined) ) )
    968977
    969978                        ((foreign-lambda)
    970                          (walk (expand-foreign-lambda x) se dest) )
     979                         (walk (expand-foreign-lambda x #f) e se dest) )
    971980
    972981                        ((foreign-safe-lambda)
    973                          (walk (expand-foreign-callback-lambda x) se dest) )
     982                         (walk (expand-foreign-lambda x #t) e se dest) )
    974983
    975984                        ((foreign-lambda*)
    976                          (walk (expand-foreign-lambda* x) se dest) )
     985                         (walk (expand-foreign-lambda* x #f) e se dest) )
    977986
    978987                        ((foreign-safe-lambda*)
    979                          (walk (expand-foreign-callback-lambda* x) se dest) )
     988                         (walk (expand-foreign-lambda* x #t) e se dest) )
    980989
    981990                        ((foreign-primitive)
    982                          (walk (expand-foreign-primitive x) se dest) )
     991                         (walk (expand-foreign-primitive x) e se dest) )
    983992
    984993                        ((define-foreign-variable)
    985994                         (let* ([var (##sys#strip-syntax (second x))]
    986                                 [type (third x)]
     995                                [type (##sys#strip-syntax (third x))]
    987996                                [name (if (pair? (cdddr x))
    988997                                          (fourth x)
     
    9981007                        ((define-foreign-type)
    9991008                         (let ([name (second x)]
    1000                                [type (third x)]
     1009                               [type (##sys#strip-syntax (third x))]
    10011010                               [conv (cdddr x)] )
    10021011                           (cond [(pair? conv)
     
    10141023                                         ,ret
    10151024                                         ,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
    1016                                      se dest) ) ]
     1025                                     e se dest) ) ]
    10171026                                 [else
    10181027                                  (##sys#hash-table-set! foreign-type-table name type)
     
    10351044                        ((##core#let-location)
    10361045                         (let* ([var (second x)]
    1037                                 [type (third x)]
     1046                                [type (##sys#strip-syntax (third x))]
    10381047                                [alias (gensym)]
    10391048                                [store (gensym)]
     
    10561065                                      '() )
    10571066                                ,(if init (fifth x) (fourth x)) ) )
    1058                             (alist-cons var alias se)
     1067                            e (alist-cons var alias se)
    10591068                            dest) ) )
    10601069
     
    10891098                                    (mark-variable var '##compiler#constant)
    10901099                                    (mark-variable var '##compiler#always-bound)
    1091                                     (walk `(define ,var ',val) se #f) ) ] ) ) )
     1100                                    (walk `(define ,var ',val) e se #f) ) ] ) ) )
    10921101
    10931102                        ((##core#declare)
     
    10971106                                      (process-declaration d se))
    10981107                                    (cdr x) ) )
    1099                           '() #f) )
     1108                          e '() #f) )
    11001109             
    11011110                        ((##core#foreign-callback-wrapper)
     
    11171126                                vars atypes) )
    11181127                             `(##core#foreign-callback-wrapper
    1119                                ,@(mapwalk args se)
     1128                               ,@(mapwalk args e se)
    11201129                               ,(walk `(##core#lambda
    11211130                                        ,vars
     
    11721181                                                (else (cddr lam)) ) )
    11731182                                           rtype) ) )
    1174                                       se #f) ) ) ) )
     1183                                      e se #f) ) ) ) )
    11751184
    11761185                        (else
    11771186                         (let ([handle-call
    11781187                                (lambda ()
    1179                                   (let* ([x2 (mapwalk x se)]
     1188                                  (let* ([x2 (mapwalk x e se)]
    11801189                                         [head2 (car x2)]
    11811190                                         [old (##sys#hash-table-ref line-number-database-2 head2)] )
     
    11951204                                                    (walk
    11961205                                                     `(##sys#make-locative ,(second a) 0 #f 'location)
    1197                                                      se #f) ) ]
     1206                                                     e se #f) ) ]
    11981207                                              [(assq sym external-to-pointer)
    1199                                                => (lambda (a) (walk (cdr a) se #f)) ]
     1208                                               => (lambda (a) (walk (cdr a) e se #f)) ]
    12001209                                              [(memq sym callback-names)
    12011210                                               `(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
    12021211                                              [else
    1203                                                (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ] )
    1204                                         (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ) ) ]
     1212                                               (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ] )
     1213                                        (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ) ) ]
    12051214                                 
    12061215                                 [else (handle-call)] ) ) ) ) ] ) ) ) )
     
    12121221           (emit-syntax-trace-info x #f)
    12131222           (compiler-warning 'syntax "literal in operator position: ~S" x)
    1214            (mapwalk x se) )
     1223           (mapwalk x e se) )
    12151224
    12161225          ((and (pair? (car x))
     
    12241233               (if (and (proper-list? llist) (= (llist-length llist) (length args)))
    12251234                   (walk `(,(macro-alias 'let se)
    1226                            ,(map list llist args) ,@(cddr lexp)) se dest)
     1235                           ,(map list llist args) ,@(cddr lexp))
     1236                         e se dest)
    12271237                   (let ((var (gensym 't)))
    12281238                     (walk
     
    12301240                        ((,var ,(car x)))
    12311241                        (,var ,@(cdr x)) )
    1232                       se dest) ) ) ) ) )
     1242                      e se dest) ) ) ) ) )
    12331243         
    12341244          (else
    12351245           (emit-syntax-trace-info x #f)
    1236            (mapwalk x se)) ) )
     1246           (mapwalk x e se)) ) )
    12371247 
    1238   (define (mapwalk xs se)
    1239     (map (lambda (x) (walk x se #f)) xs) )
     1248  (define (mapwalk xs e se)
     1249    (map (lambda (x) (walk x e se #f)) xs) )
    12401250
    12411251  (when (memq 'c debugging-chicken) (newline) (pretty-print exp))
     
    12501260         (set! extended-bindings (append internal-bindings extended-bindings))
    12511261         exp) )
    1252    (##sys#current-environment)
     1262   '() (##sys#current-environment)
    12531263   #f) )
    12541264
     
    13791389                    (set! extended-bindings (lset-difference eq? default-extended-bindings syms)) ) ] ) ]
    13801390          ((inline-global)
     1391           (set! enable-inline-files #t)
    13811392           (if (null? (cddr spec))
    13821393               (set! inline-globally #f)
     
    14571468                (stripa (cdr spec))))))
    14581469       ((inline-global)
     1470        (set! enable-inline-files #t)
     1471        (set! inline-locally #t)
    14591472        (if (null? (cdr spec))
    14601473            (set! inline-globally #t)
     
    14621475             (cut mark-variable <> '##compiler#inline-global 'yes)
    14631476             (stripa (cdr spec)))))
     1477       ((type)
     1478        (for-each
     1479         (lambda (spec)
     1480           (cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
     1481                  (##sys#put! (car spec) '##core#type (cadr spec))
     1482                  (##sys#put! (car spec) '##core#declared-type #t))
     1483                 (else
     1484                  (compiler-warning 'syntax "illegal `type' declaration item `~s'" spec))))
     1485         (cdr spec)))
     1486       ((scrutinize)
     1487        (set! do-scrutinize #t))
    14641488       (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) )
    14651489     '(##core#undefined) ) ) )
     
    14811505
    14821506(define (create-foreign-stub rtype sname argtypes argnames body callback cps)
    1483   (let* ([params (list-tabulate (length argtypes) (lambda (x) (gensym 'a)))]
     1507  (let* ((rtype (##sys#strip-syntax rtype))
     1508         (argtypes (##sys#strip-syntax argtypes))
     1509         [params (list-tabulate (length argtypes) (lambda (x) (gensym 'a)))]
    14841510         [f-id (gensym 'stub)]
    14851511         [bufvar (gensym)]
     
    15061532                     rtype) ) ) ) ) ) ) )
    15071533
    1508 (define (expand-foreign-lambda exp)
     1534(define (expand-foreign-lambda exp callback?)
    15091535  (let* ([name (third exp)]
    1510          [sname (cond ((symbol? name) (symbol->string name))
     1536         [sname (cond ((symbol? name) (symbol->string (##sys#strip-syntax name)))
    15111537                      ((string? name) name)
    15121538                      (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
    15131539         [rtype (second exp)]
    15141540         [argtypes (cdddr exp)] )
    1515     (create-foreign-stub rtype sname argtypes #f #f #f #f) ) )
    1516 
    1517 (define (expand-foreign-callback-lambda exp)
    1518   (let* ([name (third exp)]
    1519          [sname (cond ((symbol? name) (symbol->string name))
    1520                       ((string? name) name)
    1521                       (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
    1522          [rtype (second exp)]
    1523          [argtypes (cdddr exp)] )
    1524     (create-foreign-stub rtype sname argtypes #f #f #t #t) ) )
    1525 
    1526 (define (expand-foreign-lambda* exp)
     1541    (create-foreign-stub rtype sname argtypes #f #f callback? callback?) ) )
     1542
     1543(define (expand-foreign-lambda* exp callback?)
    15271544  (let* ([rtype (second exp)]
    15281545         [args (third exp)]
    15291546         [body (apply string-append (cdddr exp))]
    15301547         [argtypes (map car args)]
    1531          [argnames (map cadr args)] )
    1532     (create-foreign-stub rtype #f argtypes argnames body #f #f) ) )
    1533 
    1534 (define (expand-foreign-callback-lambda* exp)
    1535   (let* ([rtype (second exp)]
    1536          [args (third exp)]
    1537          [body (apply string-append (cdddr exp))]
    1538          [argtypes (map car args)]
    1539          [argnames (map cadr args)] )
    1540     (create-foreign-stub rtype #f argtypes argnames body #t #t) ) )
    1541 
     1548         ;; C identifiers aren't hygienically renamed inside body strings
     1549         [argnames (map cadr (##sys#strip-syntax args))] )
     1550    (create-foreign-stub rtype #f argtypes argnames body callback? callback?) ) )
     1551
     1552;; TODO: Try to fold this procedure into expand-foreign-lambda*
    15421553(define (expand-foreign-primitive exp)
    15431554  (let* ([hasrtype (and (pair? (cddr exp)) (not (string? (caddr exp))))]
    15441555         [rtype (if hasrtype (second exp) 'void)]
    1545          [args (if hasrtype (third exp) (second exp))]
     1556         [args (##sys#strip-syntax (if hasrtype (third exp) (second exp)))]
    15461557         [body (apply string-append (if hasrtype (cdddr exp) (cddr exp)))]
    15471558         [argtypes (map car args)]
    1548          [argnames (map cadr args)] )
     1559         ;; C identifiers aren't hygienically renamed inside body strings
     1560         [argnames (map cadr (##sys#strip-syntax args))] )
    15491561    (create-foreign-stub rtype #f argtypes argnames body #f #t) ) )
    15501562
  • chicken/branches/prerelease/csc.scm

    r13859 r14954  
    127127    -check-syntax -case-insensitive -benchmark-mode -shared -compile-syntax -no-lambda-info
    128128    -lambda-lift -dynamic -disable-stack-overflow-checks -local
    129     -emit-external-prototypes-first -inline -release
     129    -emit-external-prototypes-first -inline -release -scrutinize
    130130    -analyze-only -keep-shadowed-macros -inline-global -ignore-repository
    131     -no-symbol-escape -no-parentheses-synonyms -r5rs-syntax))
     131    -no-symbol-escape -no-parentheses-synonyms -r5rs-syntax
     132    -no-argc-checks -no-bound-checks -no-procedure-checks
     133    -no-procedure-checks-for-usual-bindings))
    132134
    133135(define-constant complex-options
    134136  '(-debug -output-file -heap-size -nursery -stack-size -compiler -unit -uses -keyword-style
    135137    -optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue
    136     -inline-limit -profile-name -disable-warning -emit-inline-file
    137     -feature -debug-level -heap-growth -heap-shrinkage -heap-initial-size
     138    -inline-limit -profile-name -disable-warning -emit-inline-file -types
     139    -feature -debug-level -heap-growth -heap-shrinkage -heap-initial-size -consult-inline-file
    138140    -emit-import-library -static-extension))
    139141
     
    141143  '((-h "-help")
    142144    (-s "-shared")
     145    (-S "-scrutinize")
    143146    (|-P| "-check-syntax")
    144147    (|-V| "-version")
     
    157160
    158161(define short-options
    159   (string->list "PHhsfiENxubvwAOeWkctg") )
     162  (string->list "PHhsfiENxubvwAOeWkctgS") )
    160163
    161164
     
    278281    -h  -help                      display this text and exit
    279282    -v                             show intermediate compilation stages
    280     -v2  -verbose                  display information about translation
     283    -vv  -verbose                  display information about translation
    281284                                    progress
    282     -v3                            display information about all compilation
     285    -vvv                           display information about all compilation
    283286                                    stages
    284287    -V  -version                   display Scheme compiler version and exit
     
    332335    -profile-name FILENAME         name of the generated profile information
    333336                                    file
     337    -S  -scrutinize                perform local flow analysis
     338    -types FILENAME                load additional type database
    334339
    335340  Optimization options:
     
    356361    -n -emit-inline-file FILENAME  generate file with globally inlinable
    357362                                    procedures (implies -inline -local)
     363    -consult-inline-file FILENAME  explicitly load inline file
     364    -no-argc-checks                disable argument count checks
     365    -no-bound-checks               disable bound variable checks
     366    -no-procedure-checks           disable procedure call checks
     367    -no-procedure-checks-for-usual-bindings
     368                                   disable procedure call checks only for usual
     369                                    bindings
    358370
    359371  Configuration options:
     
    395407    -c                             stop after compilation to object files
    396408    -t                             stop after translation to C
    397     -cc COMPILER                   select other C compiler than the default one
    398     -cxx COMPILER                  select other C++ compiler than the default one
    399     -ld COMPILER                   select other linker than the default one
     409    -cc COMPILER                   select other C compiler than the default
     410    -cxx COMPILER                  select other C++ compiler than the default
     411    -ld COMPILER                   select other linker than the default
    400412    -lLIBNAME                      link with given library
    401413                                    (`libLIBNAME' on UNIX,
     
    432444    -raw                           do not generate implicit init- and exit code
    433445    -emit-external-prototypes-first
    434                                    emit protoypes for callbacks before foreign
     446                                   emit prototypes for callbacks before foreign
    435447                                    declarations
    436448    -ignore-repository             do not refer to repository for extensions
     
    560572                (set! show-libs #t) ]
    561573               [(-v)
    562                 (set! verbose #t) ]
    563                [(-v2 -verbose)
     574                (when (and (number? verbose) (not msvc))
     575                  (set! compile-options (cons* "-v" "-Q" compile-options))
     576                  (set! link-options (cons (if msvc "-VERBOSE" "-v") link-options)) )
     577                (cond (verbose
     578                       (t-options "-verbose")
     579                       (set! verbose 2))
     580                      (else (set! verbose #t))) ]
     581               [(-v2 -verbose)          ; DEPRECATED
    564582                (set! verbose #t)
    565583                (t-options "-verbose") ]
    566                [(-w -no-warnings)
    567                 (set! compile-options (cons "-w" compile-options))
    568                 (t-options "-no-warnings") ]
    569                [(-v3)
     584               [(-v3)                   ; DEPRECATED
    570585                (set! verbose #t)
    571586                (t-options "-verbose")
     
    573588                    (set! compile-options (cons* "-v" "-Q" compile-options)))
    574589                (set! link-options (cons (if msvc "-VERBOSE" "-v") link-options)) ]
     590               [(-w -no-warnings)
     591                (set! compile-options (cons "-w" compile-options))
     592                (t-options "-no-warnings") ]
    575593               [(|-A| -analyze-only)
    576594                (set! translate-only #t)
  • chicken/branches/prerelease/defaults.make

    r13859 r14954  
    133133TARGET_LIBRARIES ?= $(LIBRARIES)
    134134TARGET_LINKER_OPTIONS ?= $(LINKER_OPTIONS)
     135TARGET_LINKER_OPTIMIZATION_OPTIONS ?= $(LINKER_OPTIMIZATION_OPTIONS)
    135136
    136137ifneq ($(TARGET_C_COMPILER),$(C_COMPILER))
     
    279280# Scheme compiler flags
    280281
    281 CHICKEN_OPTIONS = \
    282         -no-trace -optimize-level 2 \
    283         -include-path . -include-path $(SRCDIR)
     282CHICKEN_OPTIONS = -no-trace -optimize-level 2 -include-path . -include-path $(SRCDIR)
    284283ifdef DEBUGBUILD
    285284CHICKEN_OPTIONS += -feature debugbuild
     
    288287CHICKEN_PROGRAM_OPTIONS = $(CHICKEN_OPTIONS) -no-lambda-info -inline -local
    289288CHICKEN_COMPILER_OPTIONS = $(CHICKEN_PROGRAM_OPTIONS) -extend private-namespace.scm
     289CHICKEN_SCRUTINY_OPTIONS = -types $(SRCDIR)types.db -analyze-only -scrutinize -ignore-repository
    290290CHICKEN_UNSAFE_OPTIONS = -unsafe -no-lambda-info
    291291CHICKEN_DYNAMIC_OPTIONS = $(CHICKEN_OPTIONS) -feature chicken-compile-shared -dynamic
     
    299299CHICKEN_PROFILE_PROGRAM = $(PROGRAM_PREFIX)chicken-profile$(PROGRAM_SUFFIX)
    300300CHICKEN_INSTALL_PROGRAM = $(PROGRAM_PREFIX)chicken-install$(PROGRAM_SUFFIX)
     301CHICKEN_SETUP_PROGRAM = $(PROGRAM_PREFIX)chicken-setup$(PROGRAM_SUFFIX)
    301302CHICKEN_UNINSTALL_PROGRAM = $(PROGRAM_PREFIX)chicken-uninstall$(PROGRAM_SUFFIX)
    302303CHICKEN_STATUS_PROGRAM = $(PROGRAM_PREFIX)chicken-status$(PROGRAM_SUFFIX)
    303304CHICKEN_BUG_PROGRAM = $(PROGRAM_PREFIX)chicken-bug$(PROGRAM_SUFFIX)
    304305IMPORT_LIBRARIES = chicken lolevel srfi-1 srfi-4 data-structures ports files posix srfi-13 srfi-69 extras \
    305         regex srfi-14 tcp foreign compiler scheme srfi-18 utils csi irregex
     306        regex srfi-14 tcp foreign scheme srfi-18 utils csi irregex
    306307IMPORT_LIBRARIES += setup-api setup-download
     308SCRUTINIZED_LIBRARIES = library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
     309       srfi-14 srfi-18 srfi-69 $(POSIXFILE) regex scheduler \
     310       profiler stub expand chicken-syntax
    307311
    308312ifdef STATICBUILD
     
    326330        $(CSI_SHARED_EXECUTABLE) $(CHICKEN_PROFILE_PROGRAM)$(EXE) \
    327331        $(CSC_PROGRAM)$(EXE) $(CHICKEN_INSTALL_PROGRAM)$(EXE) $(CHICKEN_UNINSTALL_PROGRAM)$(EXE) \
     332        $(CHICKEN_SETUP_PROGRAM)$(EXE) \
    328333        $(CHICKEN_STATUS_PROGRAM)$(EXE) setup-download.so setup-api.so \
    329334        $(CHICKEN_BUG_PROGRAM)$(EXE) \
  • chicken/branches/prerelease/distribution/manifest

    r13859 r14954  
    6464lolevel.c
    6565optimizer.c
     66scrutinizer.c
    6667regex.c
    6768posixunix.c
     
    178179lolevel.scm
    179180optimizer.scm
     181scrutinizer.scm
    180182regex.scm
    181183irregex.scm
     
    250252Makefile.cygwin
    251253Makefile.cross-linux-mingw
    252 Makefile.msvc
    253254rules.make
    254255defaults.make
    255256private-namespace.scm
    256257scripts/scheme
     258scripts/tools.scm
     259scripts/test-dist.sh
     260scripts/wiki2html.scm
     261scripts/make-egg-index.scm
     262scripts/makedist.scm
     263scripts/README
     264scripts/henrietta.scm
     265scripts/henrietta.cgi
    257266svnrevision.sh
    258267synrules.scm
     
    310319chicken-install.scm
    311320chicken-install.c
     321chicken-setup.scm
     322chicken-setup.c
    312323chicken-uninstall.scm
    313324chicken-uninstall.c
     
    320331setup-api.import.c
    321332setup-download.import.c
     333types.db
  • chicken/branches/prerelease/eval.scm

    r13859 r14954  
    3939      (apply print arg1 more)))
    4040
    41 (cond-expand
    42  (hygienic-macros
    43   (define-syntax d (syntax-rules () ((_ . _) (void)))) )
    44  (else
    45   (define-macro (d . _) '(void))))      ;*** remove later
     41(define-syntax d (syntax-rules () ((_ . _) (void))))
    4642
    4743#>
     
    13121308           ((number? x) (##sys#number->string x))
    13131309           (else (error "invalid extension version" x)) ) )
    1314    (if (and (list spec) (fx= 3 (length spec)))
     1310   (if (and (list? spec) (fx= 3 (length spec)))
    13151311       (let* ((info (extension-information (cadr spec)))
    13161312              (vv (and info (assq 'version info))) )
  • chicken/branches/prerelease/expand.scm

    r13859 r14954  
    4949(cond-expand
    5050 ((not debugbuild)
    51   (declare
    52     (no-bound-checks)
    53     (no-procedure-checks))
    54   (cond-expand
    55    (hygienic-macros
    56     (define-syntax dd (syntax-rules () ((_ . _) (void)))))
    57    (else                                        ;*** remove later
    58     (define-macro (dd . _) '(void))))
    59   (cond-expand
    60    (hygienic-macros
    61     (define-syntax dm (syntax-rules () ((_ . _) (void)))))
    62    (else                                        ;*** remove later
    63     (define-macro (dm . _) '(void)))))
     51  (begin
     52    (declare
     53      (no-bound-checks)
     54      (no-procedure-checks))
     55    (define-syntax dd (syntax-rules () ((_ . _) (void))))
     56    (define-syntax dm (syntax-rules () ((_ . _) (void))))))
    6457 (else))
    6558
     
    9285        alias) ) )
    9386
     87#+debugbuild
    9488(define (map-se se)
    9589  (map (lambda (a)
     
    9892
    9993(define (##sys#strip-syntax exp #!optional se alias)
    100   ;; if se is given, retain bound vars
    101   (let walk ((x exp))
    102     (cond ((symbol? x)
    103            (let ((x2 (if se
    104                          (lookup x se)
    105                          (get x '##core#macro-alias) ) ) )
    106              (cond ((get x '##core#real-name))
    107                    ((and alias (not (assq x se)))
    108                     (##sys#alias-global-hook x #f))
    109                    ((not x2) x)
    110                    ((pair? x2) x)
    111                    (else x2))))
    112           ((pair? x)
    113            (cons (walk (car x))
    114                  (walk (cdr x))))
    115           ((vector? x)
    116            (list->vector (map walk (vector->list x))))
    117           (else x))))
     94 ;; if se is given, retain bound vars
     95 (let ((seen '()))
     96   (let walk ((x exp))
     97     (cond ((assq x seen) => cdr)
     98           ((symbol? x)
     99            (let ((x2 (if se
     100                          (lookup x se)
     101                          (get x '##core#macro-alias) ) ) )
     102              (cond ((get x '##core#real-name))
     103                    ((and alias (not (assq x se)))
     104                     (##sys#alias-global-hook x #f))
     105                    ((not x2) x)
     106                    ((pair? x2) x)
     107                    (else x2))))
     108           ((pair? x)
     109            (let ((cell (cons #f #f)))
     110              (set! seen (cons (cons x cell) seen))
     111              (set-car! cell (walk (car x)))
     112              (set-cdr! cell (walk (cdr x)))
     113              cell))
     114           ((vector? x)
     115            (let* ((len (##sys#size x))
     116                   (vec (make-vector len)))
     117              (set! seen (cons (cons x vec) seen))
     118              (do ((i 0 (fx+ i 1)))
     119                  ((fx>= i len) vec)
     120                (##sys#setslot vec i (##sys#slot x i)))))
     121           (else x)))))
    118122
    119123(define strip-syntax ##sys#strip-syntax)
     
    391395            (%let-optionals* (macro-alias 'let-optionals* se))
    392396            (%let (macro-alias 'let se)))
    393         (let loop ([mode 0]             ; req, opt, rest, key, end
     397        (let loop ([mode 0]             ; req=0, opt=1, rest=2, key=3, end=4
    394398                   [req '()]
    395399                   [opt '()]
     
    428432                     (err "rest argument list specified more than once")
    429433                     (begin
    430                        (if (not rvar) (set! rvar llist))
     434                       (unless rvar (set! rvar llist))
    431435                       (set! hasrest llist)
    432436                       (loop 4 req opt '() '()) ) ) ]
     
    435439                [else
    436440                 (let* ((var (car llist))
    437                         (x (or (and (symbol? var) (lookup var se)) var))
     441                        (x (or (and (symbol? var) (not (eq? 3 mode)) (lookup var se)) var))
    438442                        (r (cdr llist)))
    439443                   (case x
    440444                     [(#!optional)
    441                       (if (not rvar) (set! rvar (macro-alias 'tmp se)))
     445                      (unless rvar (set! rvar (macro-alias 'tmp se)))
    442446                      (if (eq? mode 0)
    443447                          (loop 1 req '() '() r)
     
    531535                     (cdr body)
    532536                     (cons (if (pair? (cadr def))
    533                                `(define-syntax ,(caadr def) (,(macro-alias 'lambda se) ,(cdadr def) ,@(cddr def)))
     537                               `(define-syntax ,(caadr def)
     538                                  (,(macro-alias 'lambda se) ,(cdadr def) ,@(cddr def)))
    534539                               def)
    535540                           defs)
     
    728733
    729734;;; explicit-renaming transformer
     735
     736(define (er-macro-transformer x) x)
    730737
    731738(define ((##sys#er-transformer handler) form se dse)
     
    915922                (and-let* ((a (assq id (import-env)))
    916923                           ((not (eq? aid (cdr a)))))
    917                   (##sys#warn "re-importing already imported identfier" id))))
     924                  (##sys#warn "re-importing already imported identifier" id))))
    918925            vsv)
    919926           (for-each
     
    12571264    `(##core#module
    12581265      ,(cadr x)
    1259       ,(if (c (r '*) (caddr x))
     1266      ,(if (eq? '* (strip-syntax (caddr x)))
    12601267           #t
    12611268           (caddr x))
     
    15251532  (define (find-reexport name)
    15261533    (let ((a (assq name (##sys#macro-environment))))
    1527       (if (pair? (cdr a))
     1534      (if (and a (pair? (cdr a)))
    15281535          a
    15291536          (##sys#error
  • chicken/branches/prerelease/extras.scm

    r13859 r14954  
    8686;;; Random numbers:
    8787
    88 (define random-seed
    89     (let ((srand   (foreign-lambda void "srand" unsigned-integer)))
     88(cond-expand
     89  (unix
     90
     91    (define random-seed)
     92    (define randomize)
     93
     94    (let ((srandom (foreign-lambda void "srandom" unsigned-integer)))
     95
     96      (set! random-seed
     97        (lambda (#!optional (seed (current-seconds)))
     98          (##sys#check-integer seed 'random-seed)
     99          (srandom seed) ) )
     100
     101      (set! randomize
     102        (lambda (#!optional (seed (##sys#fudge 2)))
     103          (##sys#check-exact seed 'randomize)
     104          (srandom seed) ) ) )
     105
     106    (define (random n)
     107      (##sys#check-integer n 'random)
     108      (if (eq? 0 n)
     109          0
     110          ((foreign-lambda* long ((integer64 n)) "return( random() % ((uint64_t) n) );") n) ) ) )
     111  (else
     112
     113    (define random-seed
     114      (let ((srand (foreign-lambda void "srand" unsigned-integer)))
    90115        (lambda n
    91             (and (> (length n) 1)
    92                  (##sys#error 'random-seed "too many arguments" (length n) 1))
    93             (let ((t   (if (null? n)
    94                            (current-seconds)
    95                            (car n))))
    96                 (##sys#check-integer t 'random-seed)
    97                 (srand t)))))
    98 
    99 (define (random n)
    100   (##sys#check-exact n 'random)
    101   (if (eq? n 0)
    102       0
    103       (##core#inline "C_random_fixnum" n) ) )
    104 
    105 (define (randomize . n)
    106   (##core#inline
    107    "C_randomize"
    108    (if (##core#inline "C_eqp" n '())
    109        (##sys#fudge 2)
    110        (let ((nn (##sys#slot n 0)))
    111          (##sys#check-exact nn 'randomize)
    112          nn) ) ) )
     116          (let ((t (if (null? n) (current-seconds) (car n))))
     117            (##sys#check-integer t 'random-seed)
     118            (srand t) ) ) ) )
     119
     120    (define (randomize . n)
     121      (let ((nn (if (null? n) (##sys#fudge 2) (car n))))
     122        (##sys#check-exact nn 'randomize)
     123        (##core#inline "C_randomize" nn) ) )
     124
     125    (define (random n)
     126      (##sys#check-exact n 'random)
     127      (if (eq? n 0)
     128          0
     129          (##core#inline "C_random_fixnum" n) ) ) ) )
    113130
    114131
     
    188205           (set! start (fx+ start 1)) )
    189206         (let ((rdstring (##sys#slot (##sys#slot port 2) 7)))
    190            (let loop ((start start) (n n) (m 0))
    191              (let ((n2 (if rdstring
    192                            (rdstring port n dest start) ; *** doesn't update port-position!
    193                            (let ((c (##sys#read-char-0 port)))
     207           (if rdstring
     208               (let loop ((start start) (n n) (m 0))
     209                 (let ((n2 (rdstring port n dest start)))
     210                   (##sys#setislot port 5 ; update port-position
     211                                   (fx+ (##sys#slot port 5) n2))
     212                   (cond ((eq? n2 0) m)
     213                         ((or (not n) (fx< n2 n))
     214                          (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)))
     215                         (else (fx+ n2 m)))))
     216               (let loop ((start start) (n n) (m 0))
     217                 (let ((n2 (let ((c (##sys#read-char-0 port)))
    194218                             (if (eof-object? c)
    195219                                 0
    196220                                 (begin
    197221                                   (##core#inline "C_setsubchar" dest start c)
    198                                    1) ) ) ) ) )
    199                (cond ((eq? n2 0) m)
    200                     ((or (not n) (fx< n2 n))
    201                       (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)) )
    202                      (else (fx+ n2 m))) ) ) ))))
     222                                   1) ) ) ) )
     223                   (cond ((eq? n2 0) m)
     224                        ((or (not n) (fx< n2 n))
     225                          (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)) )
     226                         (else (fx+ n2 m))) )))))))
    203227
    204228(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
     
    211235  (##sys#check-exact start 'read-string!)
    212236  (##sys#read-string! n dest port start) )
     237
     238(define-constant read-string-buffer-size 2048)
    213239
    214240(define ##sys#read-string/port
     
    224250                     (##sys#substring str 0 n2))))
    225251            (else
    226              (let ([str (open-output-string)])
    227                (let loop ([n n])
    228                  (or (and (eq? n 0) (get-output-string str))
    229                      (let ([c (##sys#read-char-0 p)])
    230                        (if (eof-object? c)
    231                            (get-output-string str)
    232                            (begin
    233                              (##sys#write-char/port c str)
    234                              (loop (and n (fx- n 1))) ) ) ) ) ) ) ) ) ) ) )
     252             (let ([out (open-output-string)]
     253                   (buf (make-string read-string-buffer-size)))
     254               (let loop ()
     255                 (let ((n (##sys#read-string! read-string-buffer-size
     256                                              buf p 0)))
     257                   (cond ((eq? n 0)
     258                          (get-output-string out))
     259                         (else
     260                          (write-string buf n out)
     261                          (loop)))))))))))
    235262
    236263(define (read-string #!optional n (port ##sys#standard-input))
  • chicken/branches/prerelease/irregex.import.scm

    r13240 r14954  
    3232    irregex-match-start irregex-match-end irregex-match-substring
    3333    irregex-search irregex-search/matches irregex-match irregex-match-string
    34     irregex-replace irregex-replace/all
     34    irregex-fold irregex-replace irregex-replace/all irregex-apply-match
    3535    irregex-dfa irregex-dfa/search irregex-dfa/extract
    3636    irregex-nfa irregex-flags irregex-submatches irregex-lengths irregex-names))
  • chicken/branches/prerelease/irregex.scm

    r13240 r14954  
    6363(define (irregex-match-data? obj)
    6464  (and (vector? obj)
    65        (>= 5 (vector-length obj))
     65       (>= (vector-length obj) 5)
    6666       (eq? irregex-match-tag (vector-ref obj 0))))
    6767
     
    821821                (else
    822822                 (let* ((c1 (car chars))
    823                         (c2 (string-ref str (+ i 1)))
    824                         (len (if utf8? (utf8-start-char->length c2) 1))
    825                         (c2 (if (and utf8? (<= #x80 (char->integer c2) #xFF))
    826                                 (utf8-string-ref str (+ i 1) len)
    827                                 c2)))
    828                    (if (char<? c2 c1)
    829                        (error "inverted range in char-set" c1 c2)
    830                        (go (+ i 1 len) (cdr chars) (cons (cons c1 c2) ranges))
    831                      )))))
     823                        (c2 (string-ref str (+ i 1))))
     824                   (apply
     825                    (lambda (c2 j)
     826                      (if (char<? c2 c1)
     827                          (error "inverted range in char-set" c1 c2)
     828                          (go j (cdr chars) (cons (cons c1 c2) ranges))))
     829                    (cond
     830                     ((and (eqv? #\\ c2) (assv c2 posix-escape-sequences))
     831                      => (lambda (x) (list (cdr x) (+ i 3))))
     832                     ((and (eqv? #\\ c2)
     833                           (eqv? (string-ref str (+ i 2)) #\x))
     834                      (string-parse-hex-escape str (+ i 3) end))
     835                     ((and utf8? (<= #x80 (char->integer c2) #xFF))
     836                      (let ((len (utf8-start-char->length c2)))
     837                        (list (utf8-string-ref str (+ i 1) len) (+ i 1 len))))
     838                     (else
     839                      (list c2 (+ i 2)))))))))
    832840              ((#\[)
    833841               (let* ((inv? (eqv? #\^ (string-ref str (+ i 1))))
     
    848856                    (error "collating sequences not supported" str))
    849857                   (else
    850                     (error "bad character class" str)))))
     858                    (go (+ i 1) (cons #\[ chars) ranges)))))
    851859              ((#\\)
    852860               (let ((c (string-ref str (+ i 1))))
     
    860868                    (apply
    861869                     (lambda (ch j)
    862                        (go (+ j 1) (cons ch chars) ranges))
     870                       (go j (cons ch chars) ranges))
    863871                     (string-parse-hex-escape str (+ i 2) end)))
    864872                   (else
  • chicken/branches/prerelease/library.scm

    r13876 r14954  
    7878  C_FILEPTR fp = C_port_file(port);
    7979
    80   if ((c = getc(fp)) == EOF)
     80  if ((c = C_getc(fp)) == EOF)
    8181    return C_SCHEME_END_OF_FILE;
    8282
    83   ungetc(c, fp);
     83  C_ungetc(c, fp);
    8484
    8585  for (i = 0; i < n; i++) {
    86     c = getc(fp);
     86    c = C_getc(fp);
    8787    switch (c) {
    88     case '\r':  if ((c = getc(fp)) != '\n') ungetc(c, fp);
     88    case '\r':  if ((c = C_getc(fp)) != '\n') C_ungetc(c, fp);
    8989    case EOF:   clearerr(fp);
    9090    case '\n':  return C_fix(i);
     
    158158     ##sys#set-finalizer! open-output-string get-output-string read ##sys#make-pointer
    159159     ##sys#pointer->address number->string ##sys#flush-output ##sys#break-entry ##sys#step
    160      ##sys#apply-values ##sys#signal-hook ##sys#get-call-chain ##sys#really-print-call-chain
     160     ##sys#apply-values ##sys#get-call-chain ##sys#really-print-call-chain
    161161     string->keyword keyword? string->keyword getenv ##sys#number->string ##sys#copy-bytes
    162162     call-with-current-continuation ##sys#string->number ##sys#inexact->exact ##sys#exact->inexact
     
    177177(define-constant char-name-table-size 37)
    178178(define-constant output-string-initial-size 256)
     179(define-constant read-line-buffer-initial-size 1024)
    179180(define-constant default-parameter-vector-size 16)
    180181(define-constant maximal-string-length #x00ffffff)
     
    17161717    port) )
    17171718
     1719;;; Stream ports:
     1720; Input port slots:
     1721;   12: Static buffer for read-line, allocated on-demand
     1722
    17181723(define ##sys#stream-port-class
    17191724  (vector (lambda (p)                   ; read-char
     
    17321737          (lambda (p)                   ; char-ready?
    17331738            (##core#inline "C_char_ready_p" p) )
    1734           #f                            ; read-string!
    1735           #; ;UNUSED
    1736           (lambda (p n dest start)      ; read-string!
     1739          (lambda (p n dest start)              ; read-string!
    17371740            (let loop ([rem (or n (fx- (##sys#size dest) start))] [act 0] [start start])
    17381741              (let ([len (##core#inline "fast_read_string_from_file" dest p rem start)])
    1739                 (cond [(eof-object? len)
    1740                         (if (eq? 0 act) #!eof act)]
    1741                       [(not len)
    1742                         act]
     1742                (cond [(or (not len)          ; error returns EOF
     1743                           (eof-object? len)) ; EOF returns 0 bytes read
     1744                       act]
    17431745                      [(fx< len rem)
    1744                         (loop (fx- rem len) (fx+ act len) (fx+ start len))]
     1746                       (loop (fx- rem len) (fx+ act len) (fx+ start len))]
    17451747                      [else
    1746                         act ] ) ) ) )
     1748                       (fx+ act len) ] ) )))
    17471749          (lambda (p limit)             ; read-line
    1748             (let* ((buffer-len (if limit limit 256))
    1749                    (buffer (make-string buffer-len)))
    1750               (let loop ([len buffer-len]
    1751                          [buffer buffer]
     1750            (if limit (##sys#check-exact limit 'read-line))
     1751            (let ((sblen read-line-buffer-initial-size))
     1752              (unless (##sys#slot p 12)
     1753                (##sys#setslot p 12 (##sys#make-string sblen)))
     1754              (let loop ([len sblen]
     1755                         [limit (or limit maximal-string-length)]   ; guaranteed fixnum?
     1756                         [buffer (##sys#slot p 12)]
    17521757                         [result ""]
    17531758                         [f #f])
    1754                 (let ([n (##core#inline "fast_read_line_from_file" buffer p len)])
     1759                (let ([n (##core#inline "fast_read_line_from_file" buffer p
     1760                                        (fxmin limit len))])
    17551761                  (cond [(eof-object? n) (if f result #!eof)]
    1756                         [(and limit (not n))
    1757                          (##sys#string-append result (##sys#substring buffer 0 limit))]
    17581762                        [(not n)
    1759                          (loop (fx* len 2) (##sys#make-string (fx* len 2))
    1760                                (##sys#string-append
    1761                                 result
    1762                                 (##sys#substring buffer 0 len))
    1763                                #t) ]
     1763                         (if (fx< limit len)
     1764                             (##sys#string-append result (##sys#substring buffer 0 limit))
     1765                             (loop (fx* len 2)
     1766                                   (fx- limit len)
     1767                                   (##sys#make-string (fx* len 2))
     1768                                   (##sys#string-append result buffer)
     1769                                   #t)) ]
    17641770                        [f (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
    17651771                           (##sys#string-append result (##sys#substring buffer 0 n))]
    17661772                        [else
    17671773                         (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
    1768                          (##sys#substring buffer 0 n)] ) ) ) ) ) ) )
     1774                         (##sys#substring buffer 0 n)] ) ) ) ) )         
     1775 ) )
    17691776
    17701777(define ##sys#open-file-port (##core#primitive "C_open_file_port"))
     
    36283635      (##sys#make-structure
    36293636       'condition
    3630        '(user-interrupt) ) ) ]
     3637       '(user-interrupt)
     3638       '() ) ) ]
    36313639    [(#:warning)
    36323640     (##sys#print "\nWarning: " #f ##sys#standard-error)
     
    37333741  (let ([oldh ##sys#current-exception-handler])
    37343742    (##sys#dynamic-wind
    3735         (lambda () (set! ##sys#current-exception-handler handler))
    3736         thunk
    3737         (lambda () (set! ##sys#current-exception-handler oldh)) ) ) )
     3743      (lambda () (set! ##sys#current-exception-handler handler))
     3744      thunk
     3745      (lambda () (set! ##sys#current-exception-handler oldh)) ) ) )
    37383746
    37393747(define (current-exception-handler) ##sys#current-exception-handler)
     
    43194327(define ##sys#vector->list vector->list)
    43204328(define ##sys#vector-length vector-length)
    4321 (define ##sys#vector-ref vector-length)
    4322 (define ##sys#vector-length vector-length)
     4329(define ##sys#vector-ref vector-ref)
    43234330(define ##sys#>= >=)
    43244331(define ##sys#= =)
  • chicken/branches/prerelease/manual/Acknowledgements

    r13876 r14954  
    99Boucher, Terence Brannon, Roy Bryant, Adam Buchbinder, Hans Bulfone,
    1010Category 5, Taylor Campbell, Naruto Canada, Esteban U. Caamano Castro,
    11 Franklin Chen, Thomas Chust, Gian Paolo Ciceri, Tobia Conforto, John
    12 Cowan, Grzegorz Chrupa&#322;a, James Crippen, Tollef Fog Heen, Drew
    13 Hess, Alejandro Forero Cuervo, Linh Dang, Brian Denheyer, dgym, Don,
    14 Chris Double, Brown Dragon, Jarod Eells, Petter Egesund, Steve Elkins,
    15 Daniel B. Faken, Will Farr, Graham Fawcett, Marc Feeley, Fizzie,
    16 Matthew Flatt, Kimura Fuyuki, Tony Garnock-Jones, Martin Gasbichler,
    17 Joey Gibson, Stephen C. Gilardi, Joshua Griffith, Johannes Groedem,
    18 Damian Gryski, Mario Domenech Goulart, Andreas Gustafsson, Sven
    19 Hartrumpf, Jun-ichiro itojun Hagino, Ahdi Hargo, Matthias Heiler, Karl
    20 M. Hegbloom, William P. Heinemann, Bill Hoffman, Bruce Hoult, Hans
    21 Huebner, Markus Huelsmann, Goetz Isenmann, Paulo Jabardo, Wietse
    22 Jacobs, David Janssens, Christian Jaeger, Dale Jordan, Valentin
    23 Kamyshenko, Daishi Kato, Peter Keller, Brad Kind, Ron Kneusel,
    24 Matthias Koeppe, Krysztof Kowa&#322;czyk, Andre Kuehne, Todd R. Kueny
    25 Sr, Goran Krampe, David Krentzlin, Ben Kurtz, Micky Latowicki, John
    26 Lenz, Kirill Lisovsky, Juergen Lorenz, Kon Lovett, Lam Luu, Dennis
    27 Marti, Charles Martin, Bob McIsaac, Alain Mellan, Eric Merrit, Perry
    28 Metzger, Scott G. Miller, Mikael, Bruce Mitchener, Chris Moline, Eric
    29 E. Moore, Julian Morrison, Dan Muresan, Lars Nilsson, Ian Oversby,
    30 o.t., Gene Pavlovsky, Levi Pearson, Nicolas Pelletier, Carlos Pita,
    31 Robin Lee Powell, Pupeno, Davide Puricelli, Doug Quale, Eric Raible,
     11Franklin Chen, Thomas Chust, Gian Paolo Ciceri, Fulvio Ciriaco, Tobia
     12Conforto, John Cowan, Grzegorz Chrupa&#322;a, James Crippen, Tollef
     13Fog Heen, Drew Hess, Alejandro Forero Cuervo, Linh Dang, Brian
     14Denheyer, dgym, Don, Chris Double, Brown Dragon, Jarod Eells, Petter
     15Egesund, Steve Elkins, Daniel B. Faken, Will Farr, Graham Fawcett,
     16Marc Feeley, Fizzie, Matthew Flatt, Kimura Fuyuki, Tony Garnock-Jones,
     17Martin Gasbichler, Joey Gibson, Stephen C. Gilardi, Joshua Griffith,
     18Johannes Groedem, Damian Gryski, Mario Domenech Goulart, Andreas
     19Gustafsson, Sven Hartrumpf, Jun-ichiro itojun Hagino, Ahdi Hargo,
     20Matthias Heiler, Karl M. Hegbloom, William P. Heinemann, Bill Hoffman,
     21Bruce Hoult, Hans Huebner, Markus Huelsmann, Goetz Isenmann, Paulo
     22Jabardo, Wietse Jacobs, David Janssens, Christian Jaeger, Matt Jones,
     23Dale Jordan, Valentin Kamyshenko, Daishi Kato, Peter Keller, Brad
     24Kind, Ron Kneusel, Matthias Koeppe, Krysztof Kowa&#322;czyk, Andre
     25Kuehne, Todd R. Kueny Sr, Goran Krampe, David Krentzlin, Ben Kurtz,
     26Micky Latowicki, John Lenz, Kirill Lisovsky, Juergen Lorenz, Kon
     27Lovett, Lam Luu, Leonardo Valeri Manera, Dennis Marti, Charles Martin,
     28Bob McIsaac, Alain Mellan, Eric Merrit, Perry Metzger, Scott
     29G. Miller, Mikael, Bruce Mitchener, Chris Moline, Eric E. Moore,
     30Julian Morrison, Dan Muresan, Lars Nilsson, Ian Oversby, o.t., Gene
     31Pavlovsky, Levi Pearson, Nicolas Pelletier, Carlos Pita, Robin Lee
     32Powell, Pupeno, Davide Puricelli, presto, Doug Quale, Eric Raible,
    3233Ivan Raikov, Joel Reymont, Eric Rochester, Andreas Rottman, David
    3334Rush, Lars Rustemeier, Daniel Sadilek, Oskar Schirmer, Burton
  • chicken/branches/prerelease/manual/Callbacks

    r13859 r14954  
    2121do not capture the lexical environment.
    2222
    23 Non-local exits leaving the scope of the invocation of a callback from Scheme into C
    24 will not remove the C call-frame from the stack (and will result in a memory
    25 leak).  '''Note:''' The same applies to
     23Non-local exits leaving the scope of the invocation of a callback from
     24Scheme into C will not remove the C call-frame from the stack (and
     25will result in a memory leak).  '''Note:''' The same applies to
    2626SRFI-18 threading, which is implemented with {{call/cc}};
    2727additionally, if you enter one callback, switch threads and then exit
  • chicken/branches/prerelease/manual/Declarations

    r13859 r14954  
    149149in the current compilation unit.
    150150
     151Enabling global inlining implies {{(declare (inline))}}.
     152
    151153
    152154=== inline-limit
     
    250252
    251253
     254=== scrutinize
     255
     256 [declaration specifier] (scrutinize)
     257
     258Enables scrutiny. This is equivalent to passing the {{-scrutinize}} option to the compiler.
     259
     260
    252261=== standard-bindings
    253262
     
    259268then all but the given standard bindings are assumed to be never
    260269redefined.
     270
     271
     272=== type
     273
     274  [declaration specifier] (type (SYMBOL TYPESPEC) ...)
     275
     276Declares toplevel procedures to have a specific type for scrutiny. {{SYMBOL}} should name
     277a toplevel variable and {{TYPESPEC}} should be a type specification, following the syntax
     278given here:
     279
     280  TYPESPEC --> *
     281            |  ( VAL1 ... )
     282 
     283  VAL --> (or VAL1 ...)
     284       |  (struct NAME)
     285       |  (procedure (VAL1 ... [#!optional VALOPT1 ...] [#!rest [VAL]]) . RESULTS)
     286       |  BASIC
     287       |  deprecated
     288 
     289  BASIC --> *
     290         |  string
     291         |  symbol
     292         |  char
     293         |  number
     294         |  boolean
     295         |  list
     296         |  pair
     297         |  procedure
     298         |  vector
     299         |  null
     300         |  eof
     301         |  port
     302         |  blob
     303         |  pointer
     304         |  locative
     305         |  fixnum
     306         |  float
     307 
     308  RESULTS --> *
     309           |  (RVAL1 ...)
     310
     311  RVAL --> undefined
     312        |  noreturn
     313
     314A type-declaration overrides any previous declaration for the same identifier.
    261315
    262316
  • chicken/branches/prerelease/manual/Modules and macros

    r13859 r14954  
    1818Defines a macro named {{IDENTIFIER}} that will transform an expression
    1919with {{IDENTIFIER}} in operator position according to {{TRANSFORMER}}.
    20 The transformer expression must be a procedure with three arguments or
    21 a {{syntax-rules}} form. If {{syntax-rules}} is used, the usual R5RS
    22 semantics apply. If {{TRANSFORMER}} is a procedure, then it will
    23 be called on expansion with the complete s-expression of the macro
    24 invocation, a rename procedure that hygienically renames identifiers
    25 and a comparison procedure that compares (possibly renamed) identifiers.
     20The transformer expression must be an instance of
     21{{er-macro-transformer}}, called with a procedure of three arguments,
     22or a {{syntax-rules}} form. If {{syntax-rules}} is used, the usual
     23R5RS semantics apply. If {{TRANSFORMER}} is an instance of
     24{{er-macro-transformer}}, then it will be called on expansion with the
     25complete s-expression of the macro invocation, a rename procedure that
     26hygienically renames identifiers and a comparison procedure that
     27compares (possibly renamed) identifiers.
    2628
    2729{{define-syntax}} may be used to define local macros that are visible
     
    4547argument to the {{syntax-rules}} form.
    4648
     49The alternative syntax
     50
     51  (define-syntax (foo . LAMBDALIST) BODY ...)
     52
     53is also allowed and is equivalent to
     54
     55  (define-syntax foo
     56    (er-macro-transformer
     57      (lambda LAMBDALIST BODY ...)))
     58
     59==== er-macro-transformer
     60
     61  [procedure] (er-macro-transformer PROCEDURE)
     62
     63Takes a low-level transformer procedure and returns an explicit renaming
     64syntax transformer. The canonical method of defining a low-level macro is
     65
     66  (define-syntax foo
     67    (er-macro-transformer
     68      (lambda (exp rename compare)
     69        ...)))
    4770
    4871==== define-compiled-syntax
     
    7396
    7497The low-level macro facility that CHICKEN provides is called "explicit
    75 renaming" and allows writing hygienic or nonhygienic macros procedurally.
    76 When given a lambda-expression instead of a {{syntax-rules}} form,
    77 {{define-syntax}} evaluates the procedure in a distinct expansion
    78 environment (initially having access to the exported identifiers
    79 of the {{scheme}} module). The procedure takes an expression and two
    80 other arguments and returns a transformed expression.
    81 
    82 For example, the transformation
    83 procedure for a {{call}} macro such that
    84 {{(call proc arg ...)}} expands
    85 into {{(proc arg ...)}} can be written as
     98renaming" and allows writing hygienic or non-hygienic macros
     99procedurally.  When given a macro-transformer returned by
     100{{er-macro-transformer}} instead of a {{syntax-rules}} form,
     101{{define-syntax}} evaluates the procedure given to it in a distinct
     102expansion environment (initially having access to the exported
     103identifiers of the {{scheme}} module). The procedure takes an
     104expression and two other arguments and returns a transformed
     105expression.
     106
     107For example, the transformation procedure for a {{call}} macro such
     108that {{(call proc arg ...)}} expands into {{(proc arg ...)}} can be
     109written as
    86110
    87111  (lambda (exp rename compare)
    88112    (cdr exp))
    89113
    90 Expressions are represented as lists in the traditional manner,
    91 except that identifiers are represented as special uninterned symbols.
    92 
    93 The second argument to a transformation procedure is a renaming procedure that
    94 takes the representation of an identifier as its argument and returns the
    95 representation of a fresh identifier that occurs nowhere else in the
    96 program.  For example, the transformation procedure for a simplified
    97 version of the {{let}} macro might be written as
     114Expressions are represented as lists in the traditional manner, except
     115that identifiers are represented as special uninterned symbols.
     116
     117The second argument to a transformation procedure is a renaming
     118procedure that takes the representation of an identifier as its
     119argument and returns the representation of a fresh identifier that
     120occurs nowhere else in the program.  For example, the transformation
     121procedure for a simplified version of the {{let}} macro might be
     122written as
    98123
    99124  (lambda (exp rename compare)
     
    104129        ,@inits)))
    105130
    106 This would not be hygienic, however.  A
    107 hygienic {{let}} macro must rename the identifier {{lambda}} to protect it
    108 from being captured by a local binding.  The renaming effectively
    109 creates an fresh alias for {{lambda}}, one that cannot be captured by
    110 any subsequent binding:
     131This would not be hygienic, however.  A hygienic {{let}} macro must
     132rename the identifier {{lambda}} to protect it from being captured by
     133a local binding.  The renaming effectively creates an fresh alias for
     134{{lambda}}, one that cannot be captured by any subsequent binding:
    111135
    112136  (lambda (exp rename compare)
     
    137161in the syntactic environment that will be used to expand the
    138162transformed macro application.  For example, the transformation
    139 procedure for a simplified version of the {{cond}} macro can be written
    140 as
     163procedure for a simplified version of the {{cond}} macro can be
     164written as
    141165
    142166  (lambda (exp rename compare)
     
    160184thing in the syntactic environment of the expression being transformed
    161185as {{else}} denotes in the syntactic environment in which the {{cond}}
    162 macro was defined.  If {{else}} were not renamed before being passed to
    163 the comparison predicate, then it would match a local variable that
     186macro was defined.  If {{else}} were not renamed before being passed
     187to the comparison predicate, then it would match a local variable that
    164188happened to be named {{else}}, and the macro would not be hygienic.
    165189
    166 Some macros are non-hygienic by design.  For example, the
    167 following defines a {{loop}} macro that implicitly binds {{exit}} to an
    168 escape procedure.  The binding of {{exit}} is intended to capture free
     190Some macros are non-hygienic by design.  For example, the following
     191defines a {{loop}} macro that implicitly binds {{exit}} to an escape
     192procedure.  The binding of {{exit}} is intended to capture free
    169193references to {{exit}} in the body of the loop, so {{exit}} is not
    170194renamed.
    171195
    172196  (define-syntax loop
    173      (lambda (x r c)
    174        (let ((body (cdr x)))
    175          `(,(r 'call-with-current-continuation)
    176            (,(r 'lambda) (exit)
    177             (,(r 'let) ,(r 'f) () ,@body (,(r 'f))))))))
     197    (er-macro-transformer
     198      (lambda (x r c)
     199        (let ((body (cdr x)))
     200          `(,(r 'call-with-current-continuation)
     201            (,(r 'lambda) (exit)
     202             (,(r 'let) ,(r 'f) () ,@body (,(r 'f)))))))))
    178203
    179204Suppose a {{while}} macro is implemented using {{loop}}, with the intent
     
    182207
    183208  (define-syntax while
    184     (syntax-rules ()
    185       ((while test body ...)
    186        (loop (if (not test) (exit #f))
    187              body ...))))
     209    (er-macro-transformer
     210      (syntax-rules ()
     211        ((while test body ...)
     212         (loop (if (not test) (exit #f))
     213               body ...)))))
    188214
    189215because the reference to {{exit}} that is inserted by the {{while}} macro
     
    193219
    194220  (define-syntax while
    195      (lambda (x r c)
    196        (let ((test (cadr x))
    197              (body (cddr x)))
    198          `(,(r 'loop)
    199            (,(r 'if) (,(r 'not) ,test) (exit #f))
    200            ,@body))))
     221    (er-macro-transformer
     222      (lambda (x r c)
     223        (let ((test (cadr x))
     224              (body (cddr x)))
     225          `(,(r 'loop)
     226            (,(r 'if) (,(r 'not) ,test) (exit #f))
     227            ,@body)))))
    201228
    202229
     
    267294will export all definitions.
    268295
     296Note that the module system is only a device for controlling the
     297mapping of identifiers to value or syntax bindings. Modules do not
     298instantiate separate environments that contain their own bindings, as
     299do many other module systems. Redefinition of value or syntax bindings
     300will modify the original, imported definition.
     301
     302
    269303==== export
    270304
     
    280314 [syntax] (import IMPORT ...)
    281315
    282 Imports module bindings into the currentl syntactical environment.
     316Imports module bindings into the current syntactical environment.
    283317The visibility of any imported bindings is limited to the current
    284318module, if used inside a module-definition, or to the current
     
    293327
    294328Note that the imported bindings are only visible in the next toplevel
    295 expression (regardless of wether the import appears inside or outside
     329expression (regardless of whether the import appears inside or outside
    296330a module):
    297331
     
    439473  % csc -s hello.scm
    440474
    441 and used in an indentical manner:
     475and used in an identical manner:
    442476
    443477  #;1> ,l hello.so
     
    481515The macro- and module system has been implemented relatively
    482516recently and is likely to contain bugs. Please contact the
    483 maintainers if you encounter behaviour that you think is
     517maintainers if you encounter behavior that you think is
    484518not correct or that triggers an error where there shouldn't
    485519be one.
  • chicken/branches/prerelease/manual/The User's Manual

    r13859 r14954  
    55== The CHICKEN User's Manual
    66
    7 This is the user's manual for the Chicken Scheme compiler, version 4.0.0x5
     7This is the user's manual for the Chicken Scheme compiler, version 4.0.7
    88
    99; [[Getting started]] : What is CHICKEN and how do I use it?
  • chicken/branches/prerelease/manual/Unit data-structures

    r13859 r14954  
    122122
    123123Returns {{LIST}} with its elements sorted in a random order given by
    124 procedure RANDOM.
     124procedure {{RANDOM}}.
    125125
    126126
  • chicken/branches/prerelease/manual/Unit srfi-13

    r13859 r14954  
    1414</enscript>
    1515
     16The {{string-hash}} and {{string-hash-ci}} procedures are
     17not provided in this library unit, [[Unit srfi-69]] has
     18compatible definitions.
     19
     20
    1621---
    1722Previous: [[Unit srfi-4]]
  • chicken/branches/prerelease/manual/Unit srfi-14

    r13859 r14954  
    1616
    1717---
    18 Previous: [[Unit srfi-18]]
     18Previous: [[Unit srfi-13]]
    1919
    20 Next: [[Unit srfi-69]]
     20Next: [[Unit srfi-18]]
  • chicken/branches/prerelease/manual/Unit srfi-18

    r13859 r14954  
    103103Previous: [[Unit srfi-14]]
    104104
    105 Next: [[Unit posix]]
     105Next: [[Unit srfi-69]]
  • chicken/branches/prerelease/manual/Using the compiler

    r13859 r14954  
    3434
    3535; -check-syntax : Aborts compilation process after macro-expansion and syntax checks.
     36
     37; -consult-inline-file FILENAME : load file with definitions for cross-module inlining generated by a previous compiloer invocation via {{-emit-inline-file}}. Implies {{-inline}}.
    3638
    3739; -debug MODES : Enables one or more compiler debugging modes. {{MODES}} is a string of characters that select debugging information about the compiler that will be printed to standard output.
     
    4951     c          print every expression before macro-expansion
    5052     u          lists all unassigned global variable references
     53     d          lists all assigned global variables
    5154     x          display information about experimental features
    5255     D          when printing nodes, use node-tree output
     
    122125; -inline : Enable procedure inlining for known procedures of a size below the threshold (which can be set through the {{-inline-limit}} option).
    123126
    124 ; -inline-global : Enable cross-module inlining (in addition to local inlining).
     127; -inline-global : Enable cross-module inlining (in addition to local inlining). Implies {{-inline}}. For more information, see also [[Declarations]].
    125128
    126129; -inline-limit THRESHOLD : Sets the maximum size of a potentially inlinable procedure. The default threshold is {{20}}.
     
    176179; -require-extension NAME : Loads the extension {{NAME}} before the compilation process commences. This is identical to adding {{(require-extension NAME)}} at the start of the compiled program. If {{-uses NAME}} is also given on the command line, then any occurrences of {{-require-extension NAME}} are replaced with {{(declare (uses NAME))}}. Multiple names may be given and should be separated by {{,}}.
    177180
     181; -scrutinize : Enable simple flow-analysis to catch common type errors and argument/result mismatches. You can also use the {{scrutinize}} declaration to enable scrutiny.
     182
    178183; -static-extension NAME : similar to {{-require-extension NAME}}, but links extension statically (also applies for an explicit {{(require-extension NAME)}}).
     184
     185; -types FILENAME : load additional type database from {{FILENAME}}. Type-definitions in {{FILENAME}} will override previous type-definitions.
    179186
    180187; -compile-syntax : Makes macros also available at run-time. By default macros are not available at run-time.
     
    366373or compiled code specified using the {{-extend}} option are loaded
    367374and evaluated.  The parameters {{user-options-pass, user-read-pass,
    368 user-preprocessor-pass, user-pass, user-pass-2}} and {{user-post-analysis-pass}} can be set
     375user-preprocessor-pass, user-pass}} and {{user-post-analysis-pass}} can be set
    369376to procedures that are called to perform certain compilation passes
    370377instead of the usual processing (for more information about parameters
  • chicken/branches/prerelease/manual/faq

    r13859 r14954  
    472472{{substring=?}} {{substring-ci=?}} {{substring-index}} {{substring-index-ci}}
    473473
     474==== What's the difference betweem "block" and "local" mode?
     475
     476In {{block}} mode, the compiler assumes that definitions in the current file
     477are not visible from outside of the current compilation unit, so unused
     478definitions can be removed and calls can be inlined. In {{local}} mode,
     479definitions are not hidden, but the compiler assumes that they are
     480not modified from other compilation units (or code evaluated at runtime),
     481and thus allows inlining of them.
     482
    474483==== Can I load compiled code at runtime?
    475484
  • chicken/branches/prerelease/optimizer.scm

    r13240 r14954  
    6262  parameter-limit eq-inline-operator optimizable-rest-argument-operators
    6363  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
    64   make-random-name final-foreign-type inline-max-size simplified-ops
     64  make-random-name final-foreign-type inline-max-size simplified-ops apply-pre-cps-rewrite-rules!
    6565  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
    6666  foreign-argument-conversion foreign-result-conversion foreign-type-convert-argument foreign-type-convert-result)
     
    300300                                        (kvar (first (node-parameters k)))
    301301                                        (lval (and (not (test kvar 'unknown)) (test kvar 'value)))
    302                                         (eq? '##core#lambda (node-class lval))
     302                                        ((eq? '##core#lambda (node-class lval)))
    303303                                        (llist (third (node-parameters lval)))
    304304                                        ((or (test (car llist) 'unused)
     
    349349                                                   [(test (car vars) 'unused)
    350350                                                    (touch)
    351                                                     (debugging 'o "removed unused parameter to known procedure" (car vars) var)
     351                                                    (debugging
     352                                                     'o "removed unused parameter to known procedure"
     353                                                     (car vars) var)
    352354                                                    (if (expression-has-side-effects? (car args) db)
    353355                                                        (make-node
     
    17901792            (when (debugging 'l "accessibles:") (pretty-print al))
    17911793            (debugging 'p "eliminating liftables by access-lists and non-liftable callees...")
    1792             (let ([ls (eliminate3 (eliminate4 g2))]) ;(eliminate2 g2 al)))])
     1794            (let ([ls (eliminate3 (eliminate4 g2))]) ;(eliminate2 g2 al)))]) - why isn't this used?
    17931795              (debugging 'o "liftable local procedures" (delay (unzip1 ls)))
    17941796              (debugging 'p "gathering extra parameters...")
     
    18011803                (debugging 'p "moving liftables to toplevel...")
    18021804                (reconstruct! ls extra) ) ) ) ) ) ) ) )
     1805
     1806
     1807;;; Apply rewrite-rules to procedure calls
     1808
     1809(define (apply-pre-cps-rewrite-rules! node db)
     1810  (define (walk n)
     1811    (let ((class (node-class n))
     1812          (params (node-parameters n))
     1813          (subs (node-subexpressions n)))
     1814      (case class
     1815        ((##core#call)
     1816         (let* ((opnode (walk (first subs)))
     1817                (proc (and (eq? '##core#variable (node-class opnode))
     1818                           (first (node-parameters opnode))) )
     1819                (handler (and proc
     1820                              (intrinsic? proc)
     1821                              (##sys#get proc '##compiler#rewrite) ) ) )
     1822           (for-each walk (cdr subs))
     1823           (cond (handler
     1824                  (let ((info (and (pair? (cdr params))
     1825                                   (source-info->line (second params)))))
     1826                    (debugging 'o "applying rule" proc info)
     1827                    (copy-node! (handler proc (cdr subs) db walk) n)))
     1828                 (else n))))
     1829        (else
     1830         (for-each walk subs)))))
     1831  (walk node))
  • chicken/branches/prerelease/posix.import.scm

    r13240 r14954  
    114114   file-permissions
    115115   file-position
     116   set-file-position!
    116117   file-read
    117118   file-read-access?
  • chicken/branches/prerelease/posixunix.scm

    r13414 r14954  
    825825    (foreign-value "C_issock" bool))
    826826
    827 (define file-position
    828   (getter-with-setter
    829    (lambda (port)
    830     (let ([pos (cond [(port? port)
    831                       (if (eq? (##sys#slot port 7) 'stream)
    832                           (##core#inline "C_ftell" port)
    833                           -1) ]
    834                      [(fixnum? port) (##core#inline "C_lseek" port 0 _seek_cur)]
    835                      [else (##sys#signal-hook #:type-error 'file-position "invalid file" port)] ) ] )
    836       (when (fx< pos 0)
    837         (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )
    838       pos) )
     827(define set-file-position!
    839828   (lambda (port pos . whence)
    840829     (let ([whence (if (pair? whence) (car whence) _seek_set)])
     
    847836                     [(fixnum? port) (##core#inline "C_lseek" port pos whence)]
    848837                     [else (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)] )
    849          (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) ) )
     838         (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
     839
     840(define file-position
     841  (getter-with-setter
     842   (lambda (port)
     843     (let ([pos (cond [(port? port)
     844                       (if (eq? (##sys#slot port 7) 'stream)
     845                           (##core#inline "C_ftell" port)
     846                           -1) ]
     847                      [(fixnum? port) (##core#inline "C_lseek" port 0 _seek_cur)]
     848                      [else (##sys#signal-hook #:type-error 'file-position "invalid file" port)] ) ] )
     849       (when (fx< pos 0)
     850         (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )
     851       pos) )
     852   set-file-position!) )                ; doesn't accept WHENCE
    850853
    851854
     
    22052208(define process-run
    22062209  (let ([process-fork process-fork]
    2207         [process-execute process-execute]
    2208         [getenv getenv] )
     2210        [process-execute process-execute])
    22092211    (lambda (f . args)
    22102212      (let ([args (if (pair? args) (car args) #f)]
  • chicken/branches/prerelease/posixwin.scm

    r13240 r14954  
    11201120    (set! stat-socket? (stat-type 'stat-socket?)))
    11211121
    1122 (define file-position
    1123   (lambda (port)
    1124     (let ([pos (cond [(port? port)
    1125                       (if (eq? (##sys#slot port 7) 'stream)
    1126                           (##core#inline "C_ftell" port)
    1127                           -1) ]
    1128                      [(fixnum? port) (##core#inline "C_lseek" port 0 _seek_cur)]
    1129                      [else (##sys#signal-hook #:type-error 'file-position "invalid file" port)] ) ] )
    1130       (when (fx< pos 0)
    1131         (##sys#update-errno)
    1132         (##sys#signal-hook #:file-error 'file-position "cannot retrieve file position of port" port) )
    1133       pos) ) )
    1134 
    11351122(define set-file-position!
    11361123  (lambda (port pos . whence)
     
    11461133        (##sys#update-errno)
    11471134        (##sys#signal-hook #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
     1135
     1136(define file-position
     1137  (getter-with-setter
     1138   (lambda (port)
     1139     (let ([pos (cond [(port? port)
     1140                       (if (eq? (##sys#slot port 7) 'stream)
     1141                           (##core#inline "C_ftell" port)
     1142                           -1) ]
     1143                      [(fixnum? port) (##core#inline "C_lseek" port 0 _seek_cur)]
     1144                      [else (##sys#signal-hook #:type-error 'file-position "invalid file" port)] ) ] )
     1145       (when (fx< pos 0)
     1146         (##sys#update-errno)
     1147         (##sys#signal-hook #:file-error 'file-position "cannot retrieve file position of port" port) )
     1148       pos) )
     1149   set-file-position!) )                ; doesn't accept WHENCE argument
    11481150
    11491151
  • chicken/branches/prerelease/private-namespace.scm

    r13240 r14954  
    2929 (hygienic-macros
    3030  (define-syntax private
     31    ;;XXX use er-macro-transformer
    3132    (lambda (form r c)
    3233      (let ((namespace (cadr form))
  • chicken/branches/prerelease/regex.import.scm

    r13240 r14954  
    3030   glob?
    3131   grep
    32    regex-chardef-table
    33    regex-chardef-table?
    3432   regexp
    3533   regexp-escape
  • chicken/branches/prerelease/regex.scm

    r13859 r14954  
    4848    irregex-match-num-submatches
    4949    irregex-search irregex-search/matches irregex-match irregex-match-string
    50     irregex-replace irregex-replace/all
     50    irregex-fold irregex-replace irregex-replace/all irregex-apply-match
    5151    irregex-dfa irregex-dfa/search irregex-dfa/extract
    5252    irregex-nfa irregex-flags irregex-submatches irregex-lengths irregex-names
  • chicken/branches/prerelease/rules.make

    r13889 r14954  
    5151
    5252COMPILER_OBJECTS_1 = \
    53        chicken batch-driver compiler optimizer support \
     53       chicken batch-driver compiler optimizer scrutinizer support \
    5454       c-platform c-backend
    5555COMPILER_OBJECTS        = $(COMPILER_OBJECTS_1:=$(O))
     
    535535          $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
    536536          $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
    537 compiler.import$(O): compiler.import.c chicken.h $(CHICKEN_CONFIG_H)
    538         $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
    539           $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
    540           $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
    541537srfi-18.import$(O): srfi-18.import.c chicken.h $(CHICKEN_CONFIG_H)
    542538        $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
     
    584580          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
    585581          $(C_COMPILER_OUTPUT)
     582scrutinizer$(O): scrutinizer.c chicken.h $(CHICKEN_CONFIG_H)
     583        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     584          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
     585          $(C_COMPILER_OUTPUT)
    586586chicken$(O): chicken.c chicken.h $(CHICKEN_CONFIG_H)
    587587        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     
    627627          $(C_COMPILER_STATIC_OPTIONS) \
    628628          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
     629scrutinizer-static$(O): scrutinizer.c chicken.h $(CHICKEN_CONFIG_H)
     630        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     631          $(C_COMPILER_STATIC_OPTIONS) \
     632          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
    629633
    630634# assembler objects
     
    647651          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
    648652chicken-status$(O): chicken-status.c chicken.h $(CHICKEN_CONFIG_H)
     653        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) $(C_COMPILER_SHARED_OPTIONS) \
     654          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
     655chicken-setup$(O): chicken-setup.c chicken.h $(CHICKEN_CONFIG_H)
    649656        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) $(C_COMPILER_SHARED_OPTIONS) \
    650657          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
     
    744751        $(LINKER) $(LINKER_OPTIONS) $(LINKER_EXECUTABLE_OPTIONS) $< $(LINKER_OUTPUT) \
    745752          $(LINKER_LIBRARY_PREFIX)chicken$(LINKER_LIBRARY_SUFFIX) $(LINKER_LINK_SHARED_PROGRAM_OPTIONS) $(LIBRARIES)
     753$(CHICKEN_SETUP_PROGRAM)$(EXE): chicken-setup$(O) $(PRIMARY_LIBCHICKEN)
     754        $(LINKER) $(LINKER_OPTIONS) $(LINKER_EXECUTABLE_OPTIONS) $< $(LINKER_OUTPUT) \
     755          $(LINKER_LIBRARY_PREFIX)chicken$(LINKER_LIBRARY_SUFFIX) $(LINKER_LINK_SHARED_PROGRAM_OPTIONS) $(LIBRARIES)
    746756
    747757$(CHICKEN_PROFILE_PROGRAM)$(EXE): chicken-profile$(O) $(PRIMARY_LIBCHICKEN)
     
    767777# installation
    768778
    769 .PHONY: install uninstall install-libs install-manifests install-import-libs install-setup-files \
     779.PHONY: install uninstall install-libs install-import-libs install-setup-files \
    770780        install-dirs
    771781
     
    806816ifdef WINDOWS
    807817        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_SHARED_LIBRARY_OPTIONS) libchickengui$(SO) $(DESTDIR)$(IBINDIR)
    808 endif
    809 endif
    810 
    811 install-manifests:
    812 ifneq ($(CHICKEN_MANIFEST),)
    813 # ignore missing manifests since they don't exist for MSVC versions < 8.0
    814         -$(INSTALL_PROGRAM) $(INSTALL_MANIFEST_OPTIONS) $(CHICKEN_MANIFEST) $(DESTDIR)$(IBINDIR)
    815         -$(INSTALL_PROGRAM) $(INSTALL_MANIFEST_OPTIONS) $(CSI_MANIFEST) $(DESTDIR)$(IBINDIR)
    816         -$(INSTALL_PROGRAM) $(INSTALL_MANIFEST_OPTIONS) $(CHICKEN_PROFILE_MANIFEST) $(DESTDIR)$(IBINDIR)
    817         -$(INSTALL_PROGRAM) $(INSTALL_MANIFEST_OPTIONS) $(CSC_MANIFEST) $(DESTDIR)$(IBINDIR)
    818         -$(INSTALL_PROGRAM) $(INSTALL_MANIFEST_OPTIONS) $(CHICKEN_BUG_MANIFEST) $(DESTDIR)$(IBINDIR)
    819 ifndef STATICBUILD
    820         -$(INSTALL_PROGRAM) $(INSTALL_MANIFEST_OPTIONS) $(CHICKEN_INSTALL_MANIFEST) $(DESTDIR)$(IBINDIR)
    821         -$(INSTALL_PROGRAM) $(INSTALL_MANIFEST_OPTIONS) $(CHICKEN_UNINSTALL_MANIFEST) $(DESTDIR)$(IBINDIR)
    822         -$(INSTALL_PROGRAM) $(INSTALL_MANIFEST_OPTIONS) $(CHICKEN_STATUS_MANIFEST) $(DESTDIR)$(IBINDIR)
    823818endif
    824819endif
     
    854849endif
    855850else
    856 install: $(TARGETS) install-dirs install-libs install-import-libs install-manifests \
     851install: $(TARGETS) install-dirs install-libs install-import-libs \
    857852         install-setup-files
    858853        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CHICKEN_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
     
    887882        $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)/tcp.import.so
    888883        $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)/foreign.import.so
    889         $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)/compiler.import.so
    890884        $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)/scheme.import.so
    891885        $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)/csi.import.so
     
    897891        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CHICKEN_UNINSTALL_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
    898892        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CHICKEN_STATUS_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
     893        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CHICKEN_SETUP_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
    899894ifneq ($(POSTINSTALL_PROGRAM),true)
    900895        $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IBINDIR)/$(CHICKEN_INSTALL_PROGRAM)
     
    927922        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(SRCDIR)csibatch.bat $(DESTDIR)$(IBINDIR)
    928923endif
     924        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)types.db $(DESTDIR)$(IEGGDIR)
    929925endif
    930926
     
    948944        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) tcp.import.scm $(DESTDIR)$(IEGGDIR)
    949945        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) foreign.import.scm $(DESTDIR)$(IEGGDIR)
    950         $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) compiler.import.scm $(DESTDIR)$(IEGGDIR)
    951946        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) srfi-18.import.scm $(DESTDIR)$(IEGGDIR)
    952947        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) utils.import.scm $(DESTDIR)$(IEGGDIR)
     
    973968        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) tcp.import.so $(DESTDIR)$(IEGGDIR)
    974969        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) foreign.import.so $(DESTDIR)$(IEGGDIR)
    975         $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) compiler.import.so $(DESTDIR)$(IEGGDIR)
    976970        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) srfi-18.import.so $(DESTDIR)$(IEGGDIR)
    977971        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) utils.import.so $(DESTDIR)$(IEGGDIR)
     
    998992ifdef ($(PLATFORM),cygwin)
    999993        $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IBINDIR)/cygchicken* $(DESTDIR)$(IBINDIR)/cyguchicken*
    1000 endif
    1001 ifneq ($(CHICKEN_MANIFEST),)
    1002         $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IBINDIR)/$(CHICKEN_MANIFEST) \
    1003         $(DESTDIR)$(IBINDIR)/$(CSI_MANIFEST) $(DESTDIR)$(IBINDIR)/$(CHICKEN_PROFILE_MANIFEST) \
    1004         $(DESTDIR)$(IBINDIR)/$(CSC_MANIFEST) $(DESTDIR)$(IBINDIR)/$(CHICKEN_BUG_MANIFEST) \
    1005         $(DESTDIR)$(IBINDIR)/$(CHICKEN_INSTALL_MANIFEST) \
    1006         $(DESTDIR)$(IBINDIR)/$(CHICKEN_UNINSTALL_MANIFEST) \
    1007         $(DESTDIR)$(IBINDIR)/$(CHICKEN_STATUS_MANIFEST)
    1008994endif
    1009995        $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IMANDIR)/chicken.1 $(DESTDIR)$(IMANDIR)/csi.1 \
     
    11421128foreign.import.c: $(SRCDIR)foreign.import.scm
    11431129        $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
    1144 compiler.import.c: $(SRCDIR)compiler.import.scm
    1145         $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
    11461130scheme.import.c: $(SRCDIR)scheme.import.scm
    11471131        $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
     
    11661150        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
    11671151optimizer.c: $(SRCDIR)optimizer.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
     1152        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
     1153scrutinizer.c: $(SRCDIR)scrutinizer.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
    11681154        $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
    11691155batch-driver.c: $(SRCDIR)batch-driver.scm $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
     
    11841170chicken-status.c: $(SRCDIR)chicken-status.scm
    11851171        $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -ignore-repository -output-file $@
     1172chicken-setup.c: $(SRCDIR)chicken-setup.scm
     1173        $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -ignore-repository -output-file $@
    11861174csc.c: $(SRCDIR)csc.scm
    11871175        $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
     
    12071195        uutils.c utcp.c usrfi-1.c usrfi-4.c usrfi-13.c usrfi-14.c \
    12081196        usrfi-18.c usrfi-69.c uposixunix.c uposixwin.c uregex.c \
    1209         chicken-profile.c chicken-install.c chicken-uninstall.c chicken-status.c \
    1210         csc.c csi.c chicken.c batch-driver.c compiler.c optimizer.c support.c \
     1197        chicken-profile.c chicken-install.c chicken-uninstall.c chicken-status.c chicken-setup.c \
     1198        csc.c csi.c chicken.c batch-driver.c compiler.c optimizer.c scrutinizer.c support.c \
    12111199        c-platform.c c-backend.c chicken-bug.c $(IMPORT_LIBRARIES:=.import.c)
    12121200
     
    12291217endif
    12301218
    1231 clean:
     1219clean: scrutiny-clean
    12321220        -$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) chicken$(EXE) csi$(EXE) csc$(EXE) \
    12331221          chicken-profile$(EXE) csi-static$(EXE) \
    1234           chicken-install$(EXE) chicken-uninstall$(EXE) chicken-status$(EXE) \
     1222          chicken-install$(EXE) chicken-uninstall$(EXE) chicken-status$(EXE) chicken-setup$(EXE) \
    12351223          csc-static$(EXE) chicken-static$(EXE) chicken-bug$(EXE) *$(O) \
    12361224          $(LIBCHICKEN_SO_FILE) $(LIBUCHICKEN_SO_FILE) $(LIBCHICKENGUI_SO_FILE) \
    12371225          libchicken$(A) libuchicken$(A) libchickengui$(A) libchicken$(SO) $(PROGRAM_IMPORT_LIBRARIES) \
    1238           $(IMPORT_LIBRARIES:=.import.so) $(LIBCHICKEN_IMPORT_LIBRARY) $(LIBUCHICKEN_IMPORT_LIBRARY) $(LIBCHICKENGUI_IMPORT_LIBRARY)  \
    1239           $(MSVC_CHICKEN_EXPORT_FILES) $(CLEAN_MINGW_LIBS) \
    1240           $(CLEAN_MANIFESTS)
     1226          $(IMPORT_LIBRARIES:=.import.so) $(LIBCHICKEN_IMPORT_LIBRARY) $(LIBUCHICKEN_IMPORT_LIBRARY) \
     1227          $(LIBCHICKENGUI_IMPORT_LIBRARY) \
     1228          $(CLEAN_MINGW_LIBS)
    12411229
    12421230confclean:
     
    12511239          uutils.c utcp.c usrfi-1.c usrfi-4.c usrfi-13.c usrfi-14.c \
    12521240          usrfi-18.c usrfi-69.c uposixunix.c uposixwin.c uregex.c chicken-profile.c chicken-bug.c \
    1253           csc.c csi.c chicken-install.c chicken-uninstall.c chicken-status.c \
    1254           chicken.c batch-driver.c compiler.c optimizer.c support.c \
     1241          csc.c csi.c chicken-install.c chicken-setup.c chicken-uninstall.c chicken-status.c \
     1242          chicken.c batch-driver.c compiler.c optimizer.c scrutinizer.c support.c \
    12551243          c-platform.c c-backend.c \
    12561244          $(IMPORT_LIBRARIES:=.import.c)
     
    13161304        LD_LIBRARY_PATH=$$here DYLD_LIBRARY_PATH=$$here PATH=$$here:$$PATH \
    13171305        $(CSI) -s cscbench.scm $(BENCHMARK_OPTIONS)
     1306
     1307
     1308# scrutiny
     1309
     1310.PHONY: scrutiny scrutiny-clean
     1311
     1312scrutiny: $(SCRUTINIZED_LIBRARIES:=.scrutiny1) $(COMPILER_OBJECTS_1:=.scrutiny2)
     1313
     1314%.scrutiny1: $(SRCDIR)%.scm
     1315        $(CHICKEN) $< $(CHICKEN_SCRUTINY_OPTIONS) $(CHICKEN_LIBRARY_OPTIONS) 2>&1 | tee $@
     1316
     1317%.scrutiny2: $(SRCDIR)%.scm
     1318        $(CHICKEN) $< $(CHICKEN_SCRUTINY_OPTIONS) $(CHICKEN_COMPILER_OPTIONS) 2>&1 | tee $@
     1319
     1320scrutiny-clean:
     1321        $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) *.scrutiny1 *.scrutiny2
  • chicken/branches/prerelease/runtime.c

    r13859 r14954  
    716716  callback_continuation_level = 0;
    717717  timer_start_gc_ms = 0;
     718#if defined(C_NONUNIX)
    718719  C_randomize(time(NULL));
     720#elif defined(C_MACOSX) || defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__DragonFly__)
     721  srandomdev();
     722#else
     723  srandom(time(NULL));
     724#endif
    719725  return 1;
    720726}
     
    40284034C_regparm C_word C_fcall C_read_char(C_word port)
    40294035{
    4030   int c = C_fgetc(C_port_file(port));
     4036  int c = C_getc(C_port_file(port));
    40314037
    40324038  return c == EOF ? C_SCHEME_END_OF_FILE : C_make_character(c);
     
    40374043{
    40384044  C_FILEPTR fp = C_port_file(port);
    4039   int c = C_fgetc(fp);
     4045  int c = C_getc(fp);
    40404046
    40414047  C_ungetc(c, fp);
  • chicken/branches/prerelease/scheme-complete.el

    r13859 r14954  
    2121;;; (eval-after-load 'scheme
    2222;;;   '(define-key scheme-mode-map "\t" 'scheme-complete-or-indent))
     23;;;
     24;;;   Note: the completion uses a somewhat less common style than
     25;;;   typically found in other modes.  The first tab will complete the
     26;;;   longest prefix common to all possible completions.  The second
     27;;;   tab will show a list of those completions.  Subsequent tabs will
     28;;;   scroll that list.  You can't use the mouse to select from the
     29;;;   list - when you see what you want, just type the next one or
     30;;;   more characters in the symbol you want and hit tab again to
     31;;;   continue completing it.  Any key typed will bury the completion
     32;;;   list.  This ensures you can achieve a completion with the
     33;;;   minimal number of keystrokes without the completions window
     34;;;   lingering and taking up space.
    2335;;;
    2436;;; If you use eldoc-mode (included in Emacs), you can also get live
     
    4759
    4860;;; History:
     61;;; 0.8.6: 2009/05/03 - fixing support for chicken 4 w/ unbalanced parens
     62;;; 0.8.5: 2009/04/30 - full support for chicken 4, fixed bug in caching
     63;;; 0.8.4: 2008/12/26 - numerous small bugfixes (Merry Christmas!)
    4964;;; 0.8.3: 2008/10/06 - smart indent, inferring types from imported modules,
    50 ;;                      optionally caching exports, chicken 4 support
     65;;;                     optionally caching exports, chicken 4 support
    5166;;; 0.8.2: 2008/07/04 - both TAB and M-TAB scroll results (thanks Peter Bex),
    5267;;;                     better MATCH handling, fixed SRFI-55, other bugfixes
    5368;;; 0.8.1: 2008/04/17 - great renaming, everthing starts with `scheme-'
    54 ;;                      also, don't scan imported modules multiple times
     69;;;                     also, don't scan imported modules multiple times
    5570;;;   0.8: 2008/02/08 - several parsing bugfixes on unclosed parenthesis
    5671;;;                       (thanks to Kazushi NODA)
     
    284299    (procedure? (lambda (obj) bool) "returns #t iff OBJ is a procedure")
    285300    (apply (lambda ((lambda obj a) obj \.\.\.) a) "procedure application")
    286     (map (lambda ((lambda obj a) obj \.\.\.) (list a)) "a new list of PROC applied to every element of LIST")
     301    (map (lambda ((lambda (obj1 . obj2) a) list \.\.\.) (list a)) "a new list of PROC applied to every element of LIST")
    287302    (for-each (lambda ((lambda obj a) obj \.\.\.) undefined) "apply PROC to each element of LIST in order")
    288303    (force (lambda (promise) obj) "force the delayed value of PROMISE")
     
    373388    (unzip4 (lambda (list) list))
    374389    (unzip5 (lambda (list) list))
    375     (count (lambda (procedure list \.\.\.) n))
    376     (fold (lambda ((lambda obj a) object list \.\.\.) a))
     390    (count (lambda ((lambda (obj1 . obj2)) list \.\.\.) n))
     391    (fold (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
    377392    (unfold (lambda (procedure procedure procedure object :optional procedure) obj))
    378393    (pair-fold (lambda ((lambda obj a) object list \.\.\.) a))
    379     (reduce (lambda ((lambda obj a) object list \.\.\.) a))
    380     (fold-right (lambda ((lambda obj a) object list \.\.\.) a))
     394    (reduce (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
     395    (fold-right (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
    381396    (unfold-right (lambda (procedure procedure procedure object :optional object) obj))
    382     (pair-fold-right (lambda ((lambda obj a) object list \.\.\.) a))
    383     (reduce-right (lambda ((lambda obj a) object list \.\.\.) a))
    384     (append-map (lambda (procedure list \.\.\.) list))
    385     (append-map! (lambda (procedure list \.\.\.) list))
    386     (map! (lambda (procedure list \.\.\.) list))
    387     (pair-for-each (lambda (procedure list \.\.\.) undefined))
    388     (filter-map (lambda (procedure list \.\.\.) list))
    389     (map-in-order (lambda (procedure list \.\.\.) list))
    390     (filter (lambda (procedure list) list))
    391     (partition (lambda (procedure list) list))
    392     (remove (lambda (procedure list) list))
    393     (filter! (lambda (procedure list) list))
    394     (partition! (lambda (procedure list) list))
    395     (remove! (lambda (procedure list) list))
    396     (find (lambda (procedure list) obj))
    397     (find-tail (lambda (procedure list) obj))
    398     (any (lambda ((lambda obj a) list \.\.\.) a))
    399     (every (lambda ((lambda obj a) list \.\.\.) a))
    400     (list-index (lambda (procedure list \.\.\.) (or bool integer)))
    401     (take-while (lambda (procedure list) list))
    402     (drop-while (lambda (procedure list) list))
    403     (take-while! (lambda (procedure list) list))
    404     (span (lambda (procedure list) list))
    405     (break (lambda (procedure list) list))
    406     (span! (lambda (procedure list) list))
    407     (break! (lambda (procedure list) list))
     397    (pair-fold-right (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
     398    (reduce-right (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
     399    (append-map (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
     400    (append-map! (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
     401    (map! (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
     402    (pair-for-each (lambda ((lambda (obj1 . obj2)) list \.\.\.) undefined))
     403    (filter-map (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
     404    (map-in-order (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
     405    (filter (lambda ((lambda (obj1 . obj2)) list) list))
     406    (partition (lambda ((lambda (obj) bool) list) list))
     407    (remove (lambda ((lambda (obj1) bool) list) list))
     408    (filter! (lambda ((lambda (obj1) bool) list) list))
     409    (partition! (lambda ((lambda (obj1) bool) list) list))
     410    (remove! (lambda ((lambda (obj1) bool) list) list))
     411    (find (lambda ((lambda (obj1) bool) list) obj))
     412    (find-tail (lambda ((lambda (obj1) bool) list) obj))
     413    (any (lambda ((lambda (obj1 . obj2) a) list \.\.\.) a))
     414    (every (lambda ((lambda (obj1 . obj2) a) list \.\.\.) a))
     415    (list-index (lambda ((lambda (obj1 . obj2)) list \.\.\.) (or bool integer)))
     416    (take-while (lambda ((lambda (obj)) list) list))
     417    (drop-while (lambda ((lambda (obj)) list) list))
     418    (take-while! (lambda ((lambda (obj)) list) list))
     419    (span (lambda ((lambda (obj)) list) list))
     420    (break (lambda ((lambda (obj)) list) list))
     421    (span! (lambda ((lambda (obj)) list) list))
     422    (break! (lambda ((lambda (obj)) list) list))
    408423    (delete (lambda (object list :optional procedure) list))
    409424    (delete-duplicates (lambda (list :optional procedure) list))
     
    12931308   ;; SRFI 69
    12941309   ("Basic hash tables"
     1310    (alist->hash-table (lambda (alist) hash-table))
     1311    (hash (lambda (obj :optional n) int))
     1312    (hash-by-identity (lambda (obj :optional n) int))
     1313    (hash-table->alist (lambda (hash-table) alist))
     1314    (hash-table-copy (lambda (hash-table) hash-table))
     1315    (hash-table-delete! (lambda (hash-table key) undefined))
     1316    (hash-table-equivalence-function (lambda (hash-table) pred))
     1317    (hash-table-exists? (lambda (hash-table key) bool))
     1318    (hash-table-fold (lambda (hash-table f init-value)))
     1319    (hash-table-hash-function (lambda (hash-table) f))
     1320    (hash-table-keys (lambda (hash-table) list))
     1321    (hash-table-merge! (lambda (hash-table1 hash-table2) undefined))
     1322    (hash-table-ref (lambda (hash-table key :optional thunk)))
     1323    (hash-table-ref/default (lambda (hash-table key default)))
     1324    (hash-table-remove! (lambda (hash-table proc) undefined))
     1325    (hash-table-set! (lambda (hash-table key value) undefined))
     1326    (hash-table-size (lambda (hash-table) n))
     1327    (hash-table-update! (lambda (hash-table key proc :optional thunk) undefined))
     1328    (hash-table-update!/default (lambda (hash-table key proc default) undefined))
     1329    (hash-table-values (lambda (hash-table) list))
     1330    (hash-table-walk (lambda (hash-table proc) undefined))
     1331    (hash-table? (lambda (obj) bool))
     1332    (make-hash-table (lambda (:optional eq-fn hash-fn) hash-table))
     1333    (string-ci-hash (lambda (str :optional n) n))
     1334    (string-hash (lambda (str1 :optional n) n))
    12951335    )
    12961336
     
    13931433     (read-lines (lambda (:optional port max) list))
    13941434     (read-string (lambda (:optional n port) str))
    1395      (read-string! (lambda (n dest :optional port start) undefined))
     1435     (read-string! (lambda (n dest :optional port start) n))
    13961436     (read-token (lambda (predicate :optional port) str))
    13971437     (shuffle (lambda (list) list))
    1398      (sort (lambda (sequence less-fn) sequence))
    1399      (sort! (lambda (sequence less-fn) sequence))
    1400      (sorted? (lambda (sequence less-fn) bool))
     1438     (sort (lambda ((or list vector) less-fn) (or list vector)))
     1439     (sort! (lambda ((or list vector) less-fn) (or list vector)))
     1440     (sorted? (lambda ((or list vector) less-fn) bool))
    14011441     (sprintf (lambda (format-string arg \.\.\.) str))
    14021442     (string-chomp (lambda (str :optional suffix-str) str))
     
    17661806     (chicken-version (lambda () string))
    17671807     (command-line-arguments (lambda () list))
     1808     (cond-expand (syntax))
    17681809     (condition-predicate (lambda (kind) pred))
    17691810     (condition-property-accessor (lambda (kind prop :optional err?) proc))
     
    18681909     (open-output-string (lambda () string-output-port))
    18691910     (ormap (lambda (pred list \.\.\.) bool))
    1870      (port-name (lambda (port) name))
    1871      (port-position (lambda (port) n))
     1911     (port-name (lambda (:optional port) name))
     1912     (port-position (lambda (:optional port) n))
    18721913     (port? (lambda (obj) bool))
    18731914     (print (lambda (obj \.\.\.) undefined))
     
    27232764                                   "/usr/local/lib/chicken"
    27242765                                   "/opt/lib/chicken"
    2725                                    "/opt/local/lib/chicken")))))
     2766                                   "/opt/local/lib/chicken"
     2767                                   )))))
    27262768        (and dir
    27272769             (car (reverse (sort (directory-files dir t "^[0-9]+$")
    27282770                                 #'string-lessp)))))
    27292771      (and (fboundp 'shell-command-to-string)
    2730            (let* ((res (shell-command-to-string "csi -p \"(repository-path)\""))
     2772           (let* ((res (shell-command-to-string
     2773                        "csi -e '(print (repository-path))'"))
    27312774                  (res (substring res 0 (- (length res) 1))))
    27322775             (and res (file-directory-p res) res)))
     
    27382781   (let ((home (getenv "CHICKEN_HOME")))
    27392782     (if (and home (not (equal home "")))
    2740          (let ((res (split-string home ";")))
    2741            (if (member *scheme-chicken-repo-dirs* res)
     2783         (let ((res (split-string home ";"))) ;
     2784           (if (member *scheme-chicken-base-repo* res)
    27422785               res
    27432786             (cons *scheme-chicken-repo-dirs* res)))
     
    28362879;; visit a file and kill the buffer only if it wasn't already open
    28372880(defmacro scheme-with-find-file (path-expr &rest body)
    2838   (let ((path (gensym))
    2839         (buf (gensym))
    2840         (res (gensym)))
     2881  (let ((path (gensym "path"))
     2882        (buf (gensym "buf"))
     2883        (res (gensym "res")))
    28412884    `(save-window-excursion
    28422885       (let* ((,path (file-truename ,path-expr))
    2843               (,buf (find-if #'(lambda (x) (equal ,path (buffer-file-name x)))
    2844                              (buffer-list))))
     2886              (,buf (find-if
     2887                     #'(lambda (x)
     2888                         (let ((buf-file (buffer-file-name x)))
     2889                           (and buf-file
     2890                                (equal ,path (file-truename buf-file)))))
     2891                     (buffer-list))))
    28452892         (if ,buf
    28462893             (switch-to-buffer ,buf)
    2847            (switch-to-buffer (find-file-noselect ,path t t)))
     2894           (switch-to-buffer (find-file-noselect ,path t)))
    28482895         (let ((,res (save-excursion ,@body)))
    28492896           (unless ,buf (kill-buffer (current-buffer)))
     
    29372984                       (beginning-of-defun)
    29382985                       (< here (point)))
    2939         (progn (forward-char) (re-search-forward "^(" nil t))
     2986        (progn (forward-char)
     2987               (and (re-search-forward "^(" nil t)
     2988                    (progn (backward-char 1) t)))
    29402989        (goto-char (point-max)))))
    29412990
     
    30923141;;   :group 'scheme-complete)
    30933142
     3143(defvar *scheme-interleave-definitions-p* nil)
     3144
    30943145(defvar *scheme-complete-module-cache* '())
    30953146
     
    31213172                   'guile
    31223173                 'gauche))
    3123               ((re-search-forward "(use " nil t)
     3174              ((re-search-forward "(\\(?:use\\|require-library\\) " nil t)
    31243175               'chicken)
    31253176              ((re-search-forward
    3126                 "\\(?:(module \\|#\\(?:lang\\|reader\\)\\)" nil t)
    3127                'mzscheme))))))
     3177                "#\\(?:lang\\|reader\\)" nil t)
     3178               'mzscheme)
     3179              ((re-search-forward "(module\\s-" nil t)
     3180               (if (looking-at "\\s-*\\sw") 'chicken 'mzscheme)))))))
    31283181  (or *scheme-current-implementation*
    31293182      scheme-default-implementation))
     
    32763329      (scheme-extract-import-module-imports (cadr sexp))))
    32773330    ((import import-for-syntax require)
    3278      (scheme-extract-import-module-imports (cadr sexp)))
     3331     (scheme-append-map #'scheme-extract-import-module-imports (cdr sexp)))
    32793332    ((library)
    32803333     (if (and (stringp (cadr sexp)) (file-exists-p (cadr sexp)))
     
    33013354     (scheme-append-map #'scheme-module-exports (cdr sexp)))
    33023355    ((import)
    3303      (scheme-extract-import-module-imports (cadr sexp)))
     3356     (scheme-append-map #'scheme-extract-import-module-imports (cdr sexp)))
    33043357    ((autoload)
    33053358     (unless (member (cadr sexp) *scheme-imported-modules*)
     
    33103363     (unless (member (cadr sexp) *scheme-imported-modules*)
    33113364       (push (cadr sexp) *scheme-imported-modules*)
    3312        (and (file-exists-p (cadr sexp))
     3365       (and (stringp (cadr sexp))
     3366            (file-exists-p (cadr sexp))
    33133367            (scheme-with-find-file (cadr sexp)
    33143368              (scheme-current-globals)))))
     
    33403394      ;; scan for module forms
    33413395      (while (not (eobp))
    3342         (if (ignore-errors (progn (forward-sexp) t))
    3343             (let ((end (point)))
     3396        (if (ignore-errors (forward-sexp) t)
     3397            (let ((end (point))
     3398                  (inside-p nil))
    33443399              (backward-sexp)
    33453400              (when (eq ?\( (char-after))
    33463401                (forward-char)
    3347                 (when (and (not (eq ?\( (char-after)))
    3348                            (scheme-module-symbol-p (scheme-symbol-at-point)))
    3349                   (backward-char)
    3350                   (ignore-errors
    3351                     (setq imports
    3352                           (append (scheme-extract-sexp-imports
    3353                                    (scheme-nth-sexp-at-point 0))
    3354                                   imports)))))
    3355               (goto-char end))
     3402                (when (not (eq ?\( (char-after)))
     3403                  (let ((sym (scheme-symbol-at-point)))
     3404                    (cond
     3405                     ((memq sym '(module library))
     3406                      (forward-sexp 3)
     3407                      (setq inside-p t))
     3408                     ((scheme-module-symbol-p sym)
     3409                      (backward-char)
     3410                      (ignore-errors
     3411                        (setq imports
     3412                              (append (scheme-extract-sexp-imports
     3413                                       (scheme-nth-sexp-at-point 0))
     3414                                      imports))))))))
     3415              (unless inside-p (goto-char end)))
    33563416          ;; if an incomplete sexp is found, try to recover at the
    33573417          ;; next line beginning with an open paren
     
    33753435      `(lambda ,(cdr (scheme-nth-sexp-at-point 0))))
    33763436     (t
    3377       (scheme-beginning-of-next-sexp)
    3378       (scheme-sexp-type-at-point)))))
     3437      (ignore-errors (scheme-beginning-of-next-sexp)
     3438                     (scheme-sexp-type-at-point))))))
    33793439
    33803440;; we should be at the opening paren of an expression
     
    34323492;; there's an error during normal sexp movement
    34333493(defun scheme-current-globals ()
    3434   (let ((globals '()))
     3494  (let ((here (point))
     3495        (globals '())
     3496        (end (point-max)))
    34353497    (save-excursion
    34363498      (goto-char (point-min))
    3437       (or (ignore-errors (end-of-defun) (beginning-of-defun) t)
    3438           (re-search-forward "^(" nil t)
     3499      (or (ignore-errors (end-of-defun) (backward-sexp) t)
     3500          (and (re-search-forward "^(" nil t) (progn (backward-char) t))
    34393501          (goto-char (point-max)))
    3440       (while (not (eobp))
    3441         (setq globals
    3442               (append (ignore-errors (scheme-extract-definitions)) globals))
    3443         (scheme-goto-next-top-level)))
     3502      (while (< (point) end)
     3503        (cond
     3504         ((and (< (point) here) (looking-at "(\\(module\\|library\\)\\s-"))
     3505          (let ((module-end (ignore-errors
     3506                              (save-excursion (forward-sexp) (point)))))
     3507            (cond
     3508             ((or (not module-end) (< here module-end)) ; inside the module
     3509              (setq globals '())
     3510              (when module-end
     3511                (setq end module-end))
     3512              (forward-word 1)
     3513              (forward-sexp 2)
     3514              (scheme-beginning-of-next-sexp))
     3515             (t ;; not inside the module, skip it altogether
     3516              (forward-sexp 1)
     3517              (scheme-goto-next-top-level)))))
     3518         (t
     3519          (setq globals
     3520                (append (ignore-errors (scheme-extract-definitions)) globals))
     3521          (or (and (progn (forward-char) (re-search-forward "^(" nil t))
     3522                   (progn (backward-char) t))
     3523              (scheme-goto-next-top-level))))))
    34443524    globals))
    34453525
     
    34583538                                (> (point) here))
    34593539                 (goto-char end)))
    3460            (t ;; non-definition form, stop scanning
     3540           ;; non-definition form, maybe stop scanning
     3541           ((not *scheme-interleave-definitions-p*)
    34613542            (goto-char end))))))
    34623543    defs))
     
    35433624                       (or (> (car mtime) (car ptime))
    35443625                           (and (= (car mtime) (car ptime))
    3545                                 (>= (cadr mtime) (cadr ptime)))))))
     3626                                (> (cadr mtime) (cadr ptime)))))))
    35463627          (setq *scheme-complete-module-cache*
    35473628                (assq-delete-all mod *scheme-complete-module-cache*))
     
    35693650    (if predefined
    35703651        (list nil (cdr predefined))
    3571       (let ((export-file
    3572              (concat *scheme-chicken-base-repo* "/"
    3573                      (symbol-name mod) ".exports"))
    3574             (setup-file
    3575              (concat *scheme-chicken-base-repo* "/"
    3576                      (symbol-name mod) ".setup-info"))
    3577             (source-file
    3578              (concat (symbol-name mod) ".scm")))
     3652      (let* ((mod-str (symbol-name mod))
     3653             (export-file
     3654              (concat *scheme-chicken-base-repo* "/" mod-str ".exports"))
     3655             (setup-file
     3656              (concat *scheme-chicken-base-repo* "/" mod-str ".setup-info"))
     3657             ;; look for the source in the current directory
     3658             (source-file (concat mod-str ".scm"))
     3659             ;; try the chicken 4 modules db
     3660             (modules-db (concat *scheme-chicken-base-repo* "/modules.db")))
    35793661        (cond
     3662         ((eq mod 'scheme)
     3663          (list nil *scheme-r5rs-info*))
    35803664         ((file-exists-p source-file)
    35813665          (list source-file
     
    35853669                    (if (consp exports)
    35863670                        (remove-if-not #'(lambda (x) (memq (car x) exports)) env)
    3587                         env)))))
     3671                      env)))))
    35883672         ((file-exists-p export-file)
    35893673          (list export-file
    35903674                (mapcar #'(lambda (x) (cons (intern x) '((lambda obj))))
    35913675                        (scheme-file->lines export-file))))
    3592          ((file-exists-p setup-file)
    3593           (list setup-file
    3594                 (mapcar #'(lambda (x) (cons (intern x) '((lambda obj))))
    3595                         (scheme-with-find-file setup-file
    3596                           (let* ((alist (scheme-nth-sexp-at-point 0))
    3597                                  (cell (assq 'exports alist)))
    3598                             (cdr cell))))))
     3676         (t
     3677          (let ((setup-file-exports
     3678                 (and (file-exists-p setup-file)
     3679                      (scheme-with-find-file setup-file
     3680                        (let* ((alist (scheme-nth-sexp-at-point 0))
     3681                               (cell (assq 'exports alist)))
     3682                          (cdr cell))))))
     3683            (cond
     3684             (setup-file-exports
     3685              (list setup-file
     3686                    (mapcar #'(lambda (x) (cons (intern x) '((lambda obj))))
     3687                            setup-file-exports)))
     3688             ((file-exists-p modules-db)
     3689              (list modules-db
     3690                    (mapcar
     3691                     #'(lambda (x)
     3692                         (cons (intern (car (split-string (substring x 1))))
     3693                               '((lambda ()))))
     3694                     (remove-if-not
     3695                      #'(lambda (x) (string-match (concat " " mod-str ")") x))
     3696                      (scheme-file->lines modules-db))))))))
    35993697         )))))
    36003698
     
    36383736
    36393737;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    3640 ;; This is rather complicated because we to auto-generate docstring
    3641 ;; summaries from the type information, which means inferring various
    3642 ;; types from common names.  The benefit is that you don't have to
    3643 ;; input the same information twice, and can often cut&paste&munge
    3644 ;; procedure descriptions from the original documentation.
     3738;; This is rather complicated because we want to auto-generate
     3739;; docstring summaries from the type information, which means
     3740;; inferring various types from common names.  The benefit is that you
     3741;; don't have to input the same information twice, and can often
     3742;; cut&paste&munge procedure descriptions from the original
     3743;; documentation.
    36453744
    36463745(defun scheme-translate-type (type)
     
    36703769        port input-port output-port pair list vector array stream hash-table
    36713770        thread mutex condition-variable time exception date duration locative
    3672         random-source state condition condition-type queue sequence pointer
     3771        random-source state condition condition-type queue pointer
    36733772        u8vector s8vector u16vector s16vector u32vector s32vector
    36743773        u64vector s64vector f32vector f64vector undefined symbol
     
    38143913    spec))
    38153914
     3915(defun scheme-inside-module-p ()
     3916  (save-excursion
     3917    (ignore-errors
     3918      (let ((here (point))
     3919            res)
     3920        (goto-char (point-min))
     3921        (while (< (point) here)
     3922          (if (not (re-search-forward "^(\\(?:module\\|library\\)\\s-"))
     3923              (goto-char (point-max))
     3924            (beginning-of-line)
     3925            (let ((mod-point (point)))
     3926              (if (ignore-errors (forward-sexp) t)
     3927                  (if (and (<= mod-point here) (<= here (point)))
     3928                      (setq res t))
     3929                (setq res (<= mod-point here))
     3930                (goto-char (point-max))))))
     3931        res))))
     3932
    38163933(defun scheme-current-env ()
    3817   ;; r5rs
    3818   (let ((env (list *scheme-r5rs-info*)))
    3819     ;; base language
    3820     (let ((base (cdr (assq (scheme-current-implementation)
    3821                            *scheme-implementation-exports*))))
    3822       (if base (push base env)))
    3823     ;; imports
    3824     (let ((imports (ignore-errors (scheme-current-imports))))
    3825       (if imports (push imports env)))
    3826     ;; top-level defs
    3827     (let ((top (ignore-errors (scheme-current-globals))))
    3828       (if top (push top env)))
    3829     ;; current local vars
    3830     (let ((locals (ignore-errors (scheme-current-local-vars env))))
    3831       (if locals (push locals env)))
    3832     env))
     3934  (let ((in-mod-p (scheme-inside-module-p)))
     3935    ;; r5rs
     3936    (let ((env (if in-mod-p (list) (list *scheme-r5rs-info*))))
     3937      ;; base language
     3938      (let ((base (cdr (assq (scheme-current-implementation)
     3939                             *scheme-implementation-exports*))))
     3940        (if (and base (not in-mod-p)) (push base env)))
     3941      ;; imports
     3942      (let ((imports (ignore-errors (scheme-current-imports))))
     3943        (if imports (push imports env)))
     3944      ;; top-level defs
     3945      (let ((top (ignore-errors (scheme-current-globals))))
     3946        (if top (push top env)))
     3947      ;; current local vars
     3948      (let ((locals (ignore-errors (scheme-current-local-vars env))))
     3949        (if locals (push locals env)))
     3950      env)))
    38333951
    38343952(defun scheme-env-filter (pred env)
     
    38723990                             (scheme-type-match-p a1 b2))))))
    38733991               (and (consp a1)
    3874                     ;; type unions
    3875                     (if (eq 'or (car a1))
    3876                         (find-if
    3877                          #'(lambda (x)
    3878                              (scheme-type-match-p (scheme-translate-type x) b1))
    3879                          (cdr a1))
    3880                       ;; other special types
    3881                       (let ((a2 (scheme-translate-special-type a1))
    3882                             (b2 (scheme-translate-special-type b1)))
    3883                         (and (or (not (equal a1 a2)) (not (equal b1 b2)))
    3884                              (scheme-type-match-p a2 b2))))
    3885                     ))))))
     3992                    (case (car a1)
     3993                      ((or)
     3994                       ;; type unions
     3995                       (find-if
     3996                        #'(lambda (x)
     3997                            (scheme-type-match-p (scheme-translate-type x) b1))
     3998                        (cdr a1)))
     3999                      ((lambda)
     4000                       ;; procedures
     4001                       (or (eq 'procedure b1)
     4002                           (and (consp b1)
     4003                                (eq 'lambda (car b1))
     4004                                (scheme-param-list-match-p (cadr a1)
     4005                                                           (cadr b1)))))
     4006                      (t
     4007                       ;; other special types
     4008                       (let ((a2 (scheme-translate-special-type a1))
     4009                             (b2 (scheme-translate-special-type b1)))
     4010                         (and (or (not (equal a1 a2)) (not (equal b1 b2)))
     4011                              (scheme-type-match-p a2 b2)))))))))))
     4012
     4013(defun scheme-param-list-match-p (p1 p2)
     4014  (or (and (symbolp p1) (not (null p1)))
     4015      (and (symbolp p2) (not (null p2)))
     4016      (and (null p1) (null p2))
     4017      (and (consp p1) (consp p2)
     4018           (scheme-param-list-match-p (cdr p1) (cdr p2)))))
    38864019
    38874020(defun scheme-translate-special-type (x)
  • chicken/branches/prerelease/scheme.import.scm

    r13240 r14954  
    5454       with-output-to-file dynamic-wind values call-with-values eval
    5555       char-ready? imag-part real-part magnitude numerator denominator
    56        scheme-report-environment null-environment interaction-environment)
     56       scheme-report-environment null-environment interaction-environment
     57       er-macro-transformer)
    5758 ##sys#default-macro-environment)
  • chicken/branches/prerelease/scripts/make-egg-index.scm

    r13859 r14954  
    33(load-relative "tools.scm")
    44
    5 (use setup-download matchable htmlprag data-structures regex)
     5(use setup-download matchable sxml-transforms data-structures regex)
    66
    77(import irregex)
    88
     9(define *help* #f)
    910(define *major-version* (##sys#fudge 41))
    1011
    1112(define +link-regexp+
    12   '(: #\[ #\[ (submatch (* (~ #\] #\|))) #\] #\]))
    13 
    14 (define +stylesheet+ #<<EOF
    15 /* table mods by zb */
    16 table {
    17   background: #f6f6ff;
    18   padding: 0.2em;
    19   margin: 1.2em 2.0em;
    20   border: 1px solid #aac;
    21   border-collapse: collapse;
    22   font-size: 100%;
    23 }
    24 th {
    25   text-align: left;
    26   border-bottom: 1px solid #aac;
    27   border-left: 1px solid #aac;
    28   padding: 0.25em 1.0em 0.25em 1.0em;
    29 }
    30 td {
    31   padding: 0.25em 1.0em 0.25em 1.0em;
    32   border-left: 1px solid #aac;
    33 }
    34 blockquote, pre {
    35   background-color: #fafaff;
    36   display: block;
    37   border: 1px dashed gray;
    38   margin: 1.0em 0em;
    39   padding: 0.5em 1.0em;
    40   overflow: auto;
    41 }
    42 pre {
    43   line-height: 1.3;
    44 }
    45 h2, h3, h4, h5, h6 {
    46    color: #226;
    47    padding-top: 1em;
    48 }
    49 
    50 h1 {
    51     background-color: #336;
    52         color: #fff;
    53         width: 100%;
    54         padding: 0;
    55     padding: 0.25em 16px 0.25em 0.5em;
    56         margin: 0 0 0em 0;
    57         font-size: 160%;
    58 }
    59 
    60 EOF
    61 )
     13  (irregex '(: #\[ #\[ (submatch (* (~ #\] #\|))) #\] #\])))
    6214
    6315(define +categories+
     
    7123    (os "OS interface")
    7224    (ffi "Interfacing to other languages")
    73     (web "Web programing")
     25    (web "Web programming")
    7426    (xml "XML processing")
    7527    (doc-tools "Documentation tools")
     
    8840    (misc "Miscellaneous")
    8941    (hell "Concurrency and parallelism")
    90     (uncategorized "Not categerized")
     42    (uncategorized "Uncategorized")
    9143    (obsolete "Unsupported or redundant") ) )
    9244
     
    9547
    9648(define (usage code)
    97   (print "make-egg-index.scm [--major-version=MAJOR] [DIR]")
     49  (print "make-egg-index.scm [--help] [--major-version=MAJOR] [DIR]")
    9850  (exit code))
     51
     52(define (sxml->html doc)
     53  (SRV:send-reply
     54   (pre-post-order
     55    doc
     56    ;; LITERAL tag contents are used as raw HTML.
     57    `((literal *preorder* . ,(lambda (tag . body) (map ->string body)))
     58      ,@universal-conversion-rules))))
    9959
    10060(define (make-egg-index dir)
    10161  (let ((title (sprintf "Eggs Unlimited (release branch ~a)" *major-version*))
    10262        (eggs (gather-egg-information dir)))
    103     (write-shtml-as-html
    104      `(html
    105        ,(header title)
    106        (body
    107         ,@(prelude title)
    108         ,@(emit-egg-information eggs)
    109         ,@(trailer))))))
     63    (sxml->html
     64     `((literal "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
     65       (literal "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">")
     66       (html
     67        ,(header title)
     68        (body
     69         ,(titlebar title)
     70         ,(sidebar)
     71         ,(content (prelude title)
     72                   (emit-egg-information eggs))
     73         ,(trailer)))))))
     74
     75(define (wiki-link path desc)
     76  `(a (@ (href "http://chicken.wiki.br/" ,path))
     77      ,desc))
     78
     79(define (sidebar)
     80  `(div (@ (id "toc-links"))
     81        (div (@ (id "toc"))
     82             (p ,(wiki-link "" "Home") (br)
     83                ,(wiki-link "manual/index" "Manual") (br)
     84                ,(wiki-link "eggs" "Eggs") (br)
     85                ,(wiki-link "users" "Users") (br)
     86                ))))
     87
     88(define (content . body)
     89  `(div (@ (id "content-box"))
     90        (div (@ (class "content"))
     91             ,body)))
    11092
    11193(define (header title)
    11294  `(head
    113     (style (@ (type "text/css"))
    114       ,+stylesheet+)
     95;;     (style (@ (type "text/css"))
     96;;       ,+stylesheet+)
     97    (link (@ (rel "stylesheet")
     98             (type "text/css")
     99             (href "http://chicken.wiki.br/common-css")))
    115100    (title ,title)))
    116101
     102(define (titlebar title)
     103  `(div (@ (id "header"))
     104        (h1 (a (@ (href "http://chicken.wiki.br/eggs"))
     105               ,title))))
     106
    117107(define (prelude title)
    118   `((h1 ,title)
     108  `((p (img (@
     109             (style "float: right;")
     110             (src "http://www.call-with-current-continuation.org/eggs/3/egg.jpg"))))
    119111    (p (b "Last updated: " ,(seconds->string (current-seconds))))
    120112    (p "A library of extensions for the Chicken Scheme system.")
    121     (h3 "Installation")
     113    (h2 "Installation")
    122114    (p "Just enter")
    123115    (pre "  chicken-install EXTENSIONNAME\n")
     
    125117       "If your " (i "extension repository") " is placed at a location for which "
    126118       "you don't have write permissions, then run " (tt "chicken-install")
    127        "with the " (tt "-sudo") " option or run it as root (not recommended).")
     119       " with the " (tt "-sudo") " option or run it as root (not recommended).")
    128120    (p "You can obtain the repository location by running")
    129121    (pre "  csi -p \"(repository-path)\"\n")
     
    132124    (pre "  chicken-install -retrieve EXTENSIONNAME\n")
    133125    (p "By default the archive will be unpacked into a temporary directory (named "
    134        (tt "EXTENSIONNAME.egg-dir") " and the directory will be removed if the "
     126       (tt "EXTENSIONNAME.egg-dir") ") and the directory will be removed if the "
    135127       "installation completed successfully. To keep the extracted files add "
    136        (tt "-keep") "to the options passed to " (tt "chicken-install") ".")
     128       (tt "-keep") " to the options passed to " (tt "chicken-install") ".")
    137129    (p "For more information, enter")
    138130    (pre "  chicken-install -help\n")
    139     (p "If you would like to access the subversion repository, see "
    140        (a (@ (href "http://chicken.wiki.br/eggs tutorial")) "the "
    141           (i "Egg tutorial")) ".")
    142     (p "If you are looking for 3rd party libraries used by one the extensions, "
     131    (p "If you would like to access the subversion repository, see the "
     132       (a (@ (href "http://chicken.wiki.br/eggs tutorial"))
     133          "Egg tutorial") ".")
     134    (p "If you are looking for 3rd party libraries used by one of the extensions, "
    143135       "check out the CHICKEN "
    144136       (a (@ (href "http://www.call-with-current-continuation.org/tarballs/") )
    145           (i "tarball repository")))
    146     (h3 "List of available eggs")))
     137          "tarball repository") ".")
     138    (h2 "List of available eggs")
     139    (a (@ (name "category-list")))
     140    (h3 "Categories")
     141    ,(category-link-list)
     142    ))
     143
     144;; information on empty categories not available yet; link all possible categories
     145(define (category-link-list)
     146  `(ul (@ (style "list-style-type: none; padding-left: 2em;"))
     147       ,@(map
     148          (match-lambda
     149           ((cat catname)
     150            `(li (a (@ (href "#" ,cat))
     151                    ,catname))))
     152          +categories+)))
    147153
    148154(define (trailer)
    149   '())
     155  `(div (@ (id "credits"))
     156        (p "Generated with Chicken " ,(chicken-version))))
    150157
    151158(define (emit-egg-information eggs)
     
    167174            (begin
    168175              (d "category: ~a" catname)
    169               `((h3 ,catname)
     176              `((a (@ (name ,cat)))
     177                (h3 (a (@ (href "#category-list"))
     178                       ,catname))
    170179                (table
    171180                 (tr (th "Name") (th "Description") (th "License") (th "author") (th "maintainer") (th "version"))
     
    182191       (cond ((pred x) x)
    183192             (else
    184               (warning "extension has incorrectly typed .meta entry and will not be listed" (car egg) p x)
     193              (warning "extension has .meta entry of incorrect type and will not be listed" (car egg) p x)
    185194              (return '()))))
    186195     (d "  ~a   ~a" (car egg) (prop 'version "HEAD" any?))
    187      `((tr (td ,(symbol->string (car egg)))
     196     `((tr (td (a (@ (href ,(sprintf "http://chicken.wiki.br/eggref/~a/~a" *major-version* (car egg))))
     197                  ,(symbol->string (car egg))))
    188198           (td ,(prop 'synopsis "unknown" string?))
    189199           (td ,(prop 'license "unknown" name?))
     
    192202           (td ,(prop 'version "" version?)))))))
    193203
     204;; Names are either raw HTML, or [[user name]] denoting a wiki link.
    194205(define (linkify-names str)
    195   ;; silly
    196   (html->shtml
    197    (open-input-string
    198     (irregex-replace/all
    199      +link-regexp+
    200      str
    201      (lambda (m)
    202        (let ((name (irregex-match-substring m 1)))
    203          (string-append "<a href=\"http://chicken.wiki.br/" name "\">" name "</a>")))))))
     206  ;; Call MATCHED on (sub)matches and DID-NOT-MATCH on non-matches in STR,
     207  ;; and collect into a list.
     208  (define (transform irx str matched did-not-match)
     209    ;; IRREGEX-FOLD is exported for SVN trunk >= r14283, delete this if
     210    ;; installed Chicken is new enough.
     211    (define (irregex-fold irx kons knil str . o)
     212      (let* ((irx (irregex irx))
     213             (finish (if (pair? o) (car o) (lambda (i acc) acc)))
     214             (start (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
     215             (end (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
     216                      (caddr o)
     217                      (string-length str))))
     218        (let lp ((i start) (acc knil))
     219          (if (>= i end)
     220              (finish i acc)
     221              (let ((m (irregex-search irx str i end)))
     222                (if (not m)
     223                    (finish i acc)
     224                    (let* ((end (irregex-match-end m 0))
     225                           (acc (kons i m acc)))
     226                      (lp end acc))))))))
     227    (let ((irregex-match-start-index irregex-match-start)) ;; upcoming API change in irregex 0.7
     228      (irregex-fold irx
     229                    (lambda (i m s)
     230                      (cons (matched (irregex-match-substring m 1))
     231                            (cons (did-not-match
     232                                   (substring str i (irregex-match-start-index m 0)))
     233                                  s)))
     234                    '()
     235                    str
     236                    (lambda (i s)
     237                      (reverse (cons (did-not-match (substring str i))
     238                                     s))))))
     239  (transform
     240   +link-regexp+
     241   str
     242   (lambda (name)  ;; wiki username
     243     `(a (@ (href ,(string-append "http://chicken.wiki.br/users/"
     244                                  (string-substitute " " "-" name 'global))))
     245         ,name))
     246   (lambda (x)     ;; raw HTML chunk
     247     `(literal ,x))))
    204248
    205249(define name?
     
    210254
    211255(define (main args)
     256  (when *help* (usage 0))
    212257  (match args
    213258    ((dir)
     
    217262
    218263(main (simple-args (command-line-arguments)))
     264
  • chicken/branches/prerelease/setup-api.scm

    r13859 r14954  
    240240                   (cdr (assoc prg *installed-executables*))))
    241241                 "-feature" "compiling-extension"
     242                 (if (keep-intermediates) "-k" "")
    242243                 (if (host-extension) "-host" "")
    243244                 *csc-options*)
     
    396397
    397398(define-syntax make
     399  ;;XXX use er-macro-transformer
    398400  (lambda (form r c)
    399401    (##sys#check-syntax 'make form '(_ _ . #(_ 0 1)))
     
    448450
    449451(define (copy-file from to #!optional (err #t) (prefix (installation-prefix)))
     452  ;;XXX the prefix handling is completely bogus
    450453  (let ((from (if (pair? from) (car from) from))
    451454        (to (let ((to-path (if (pair? from) (make-pathname to (cadr from)) to)))
    452455              (if (and prefix (not (string-prefix? prefix to-path)))
    453                   (make-pathname prefix to-path) to-path))))
     456                  (make-pathname prefix to-path)
     457                  to-path))))
    454458    (ensure-directory to)
    455459    (cond ((or (glob? from) (file-exists? from))
     
    515519                               (run (,*ranlib-command* ,(shellpath to)) ) ))
    516520                           (make-dest-pathname rpath f)))
    517                        files) ) )
     521                       files) )
     522           (pre (installation-prefix))
     523           (docpath (if pre
     524                        (ensure-directory (make-pathname pre "share/chicken/doc"))
     525                        *doc-path*)))
    518526      (and-let* ((docs (assq 'documentation info)))
    519         (print "\n* Installing documentation files in " *doc-path* ":")
     527        (print "\n* Installing documentation files in " docpath ":")
    520528        (for-each
    521529         (lambda (f)
    522            (copy-file f (make-pathname *doc-path* f) #f) )
     530           (copy-file f (make-pathname docpath f) #f) )
    523531         (cdr docs))
    524532        (newline))
    525533      (and-let* ((exs (assq 'examples info)))
    526         (print "\n* Installing example files in " *doc-path* ":")
     534        (print "\n* Installing example files in " docpath ":")
    527535        (for-each
    528536         (lambda (f)
    529            (let ((destf (make-pathname *doc-path* f)))
     537           (let ((destf (make-pathname docpath f)))
    530538             (copy-file f destf #f)
    531539             (unless *windows-shell*
    532                (run (chmod a+rx ,destf)) ) ))
     540               (run (,*chmod-command* a+rx ,destf)) ) ))
    533541         (cdr exs))
    534542        (newline))
     
    542550  (when (setup-install-flag)
    543551    (let* ((files (check-filelist (if (list? files) files (list files))))
    544            (ppath ((lambda (pre) (if pre (make-pathname pre (program-path)) (program-path)))
     552           (ppath ((lambda (pre)
     553                     (if pre
     554                         (ensure-directory (make-pathname pre "bin"))
     555                         (program-path)))
    545556                   (installation-prefix)))
    546557           (files (if *windows*
     
    564575  (when (setup-install-flag)
    565576    (let* ((files (check-filelist (if (list? files) files (list files))))
    566            (ppath ((lambda (pre) (if pre (make-pathname pre (program-path)) (program-path)))
     577           (ppath ((lambda (pre)
     578                     (if pre
     579                         (ensure-directory (make-pathname pre "bin"))
     580                         (program-path)))
    567581                   (installation-prefix)))
    568582           (pfiles (map (lambda (f)
     
    583597(define (repo-path #!optional ddir?)
    584598  (let ((p (if (and ddir? (installation-prefix))
    585                (make-pathname (installation-prefix) (repository-path))
     599               (make-pathname
     600                (installation-prefix)
     601                (sprintf "lib/chicken/~a" (##sys#fudge 42)))
    586602               (repository-path))) )
    587603    (ensure-directory p)
     
    594610          (error "cannot create directory: a file with the same name already exists") )
    595611        (begin
    596           (create-directory dir)
     612          (create-directory/parents dir)
    597613          (unless *windows-shell*
    598                   (run (,*chmod-command* a+x ,(shellpath dir))))))))
     614                  (run (,*chmod-command* a+x ,(shellpath dir)))))))
     615  path)
    599616
    600617(define (try-compile code #!key c++ (cc (if c++ *cxx* *cc*)) (cflags "") (ldflags "")
     
    622639
    623640(define (required-chicken-version v)
    624   (when (string-ci<? (chicken-version) (->string v))
     641  (when (version>=? v (chicken-version) )
    625642    (error (sprintf "CHICKEN version ~a or higher is required" v)) ) )
    626643
     
    638655                  (version (cadr args))
    639656                  (more (cddr args))
    640                   (info (extension-information ext))
    641                   (version (->string version)) )
     657                  (info (extension-information ext)))
    642658             (if info
    643659                 (let ((ver (and (assq 'version info) (cadr (assq 'version info)))))
    644660                   (cond ((not ver) (upgrade-message ext "has no associated version information"))
    645                          ((string-ci<? (->string ver) version)
     661                         ((and (version>=? version ver) (not (string=? (->string version) (->string ver))))
    646662                          (upgrade-message
    647663                           ext
     
    668684  (define (version->list v)
    669685    (map (lambda (x) (or (string->number x) x))
    670          (string-split-fields "[-\\._]" v #:infix)))
     686         (string-split-fields "[-\\._]" (->string v) #:infix)))
    671687  (let loop ((p1 (version->list v1))
    672688             (p2 (version->list v2)))
     
    674690          ((null? p2))
    675691          ((number? (car p1))
    676            (and (if (number? (car p2))
    677                     (>= (car p1) (car p2))
    678                     (string>=? (number->string (car p1)) (car p2)))
    679                 (loop (cdr p1) (cdr p2))))
    680           ((number? (car p2))
    681            (and (string>=? (car p1) (number->string (car p2)))
    682                 (loop (cdr p1) (cdr p2))))
    683           ((string>=? (car p1) (car p2)) (loop (cdr p1) (cdr p2)))
    684           (else #f))))
     692           (and (number? (car p2))
     693                (or (> (car p1) (car p2))
     694                    (and (= (car p1) (car p2))
     695                         (loop (cdr p1) (cdr p2))))))
     696          ((number? (car p2)))
     697          ((string>? (car p1) (car p2)))
     698          (else
     699           (and (string=? (car p1) (car p2))
     700                (loop (cdr p1) (cdr p2)))))))
    685701
    686702(define extension-name-and-version
  • chicken/branches/prerelease/setup-download.scm

    r13859 r14954  
    4040  (import extras regex posix utils srfi-1 data-structures tcp srfi-13 files setup-api)
    4141
    42   (tcp-connect-timeout 10000)           ; 10 seconds
    43   (tcp-read-timeout 10000)
    44   (tcp-write-timeout 10000)
     42  (define-constant +default-tcp-connect-timeout+ 10000) ; 10 seconds
     43  (define-constant +default-tcp-read/write-timeout+ 20000) ; 20 seconds
     44
     45  (tcp-connect-timeout +default-tcp-connect-timeout+)
     46  (tcp-read-timeout +default-tcp-read/write-timeout+)
     47  (tcp-write-timeout +default-tcp-read/write-timeout+)
    4548
    4649  (define *quiet* #f)
     
    9497       (lambda (egg)
    9598         (let-values (((loc version) (locate-egg/local egg dir)))
    96            (let ((meta (make-pathname (list dir loc) egg "meta")))
     99           (let ((meta (make-pathname loc egg "meta")))
    97100             (and (file-exists? meta)
    98101                  (call/cc
     
    214217       (make-HTTP-GET/1.1 locn *chicken-install-user-agent* host port: port accept: "*/*")
    215218       out)
    216       (close-output-port out)
     219      (flush-output out)
    217220      (d "reading response ...~%")
    218221      (let ([chunked #f])
     
    241244                [(or (eof-object? name) (not name))
    242245                 (close-input-port in)
     246                 (close-output-port out)
    243247                 (reverse files) ]
    244248                [(not (string? name))
  • chicken/branches/prerelease/site/index.html

    r14125 r14954  
    110110
    111111<center>
    112 <img src="chicken4.png">
     112<img src="chicken4-low.png">
    113113<div style="width: 70%; margin: 3em;">
    114114
     
    179179</pre>
    180180(username: <tt>anonymous</tt>, password: &lt;none&gt;)
     181<p>
     182The CHICKEN bug tracking system is located <a href="http://www.irp.oist.jp/trac/chicken/"/>here.</a></p>
     183</p>
    181184</p>
    182185
  • chicken/branches/prerelease/srfi-13.import.scm

    r13240 r14954  
    6262   string-for-each
    6363   string-for-each-index
    64    string-hash
    65    string-hash-ci
    6664   string-index
    6765   string-index-right
  • chicken/branches/prerelease/srfi-13.scm

    r13859 r14954  
    206206 (else
    207207  (define-syntax let-string-start+end
     208    ;;XXX use er-macro-transformer
    208209    (lambda (form r c)
    209210      (##sys#check-syntax 'let-string-start+end form '(_ _ _ _ _ . _))
  • chicken/branches/prerelease/srfi-4.import.scm

    r13240 r14954  
    4343   blob->u8vector
    4444   blob->u8vector/shared
    45    byte-vector->f32vector
    46    byte-vector->f64vector
    47    byte-vector->s16vector
    48    byte-vector->s32vector
    49    byte-vector->s8vector
    50    byte-vector->u16vector
    51    byte-vector->u32vector
    52    byte-vector->u8vector
    5345   f32vector
    5446   f32vector->blob
  • chicken/branches/prerelease/srfi-69.import.scm

    r13240 r14954  
    6666   number-hash
    6767   object-uid-hash
     68   string-hash-ci
    6869   string-ci-hash
    6970   string-hash
  • chicken/branches/prerelease/srfi-69.scm

    r13859 r14954  
    2525; POSSIBILITY OF SUCH DAMAGE.
    2626
    27 
    2827(declare
    2928 (unit srfi-69)
     
    145144
    146145(define-syntax $flonum-hash
     146  ;;XXX use er-macro-transformer
    147147  (lambda (form r c)
    148148    (let ( (flo (cadr form))
    149            (%%subbyte (r '%subbyte))
    150            (%flonum-magic (r 'flonum-magic))
    151            (%fx+ (r 'fx+))
    152            (%fx* (r 'fx*))
    153            (%fxshl (r 'fxshl)) )
    154     `(,%fx* ,%flonum-magic
     149           (_%subbyte (r '%subbyte))
     150           (_flonum-magic (r 'flonum-magic))
     151           (_fx+ (r 'fx+))
     152           (_fx* (r 'fx*))
     153           (_fxshl (r 'fxshl)) )
     154    `(,_fx* ,_flonum-magic
    155155            ,(let loop ( (idx (fx- (##sys#size 1.0) 1)) )
    156156               (if (fx= 0 idx)
    157                    `(,%%subbyte ,flo 0)
    158                    `(,%fx+ (,%%subbyte ,flo ,idx)
    159                            (,%fxshl ,(loop (fx- idx 1)) 1)) ) ) ) ) ) )
     157                   `(,_%subbyte ,flo 0)
     158                   `(,_fx+ (,_%subbyte ,flo ,idx)
     159                           (,_fxshl ,(loop (fx- idx 1)) 1)) ) ) ) ) ) )
    160160
    161161(define (##sys#number-hash-hook obj)
     
    167167
    168168(define-inline (%number-hash obj)
    169   (cond [(fixnum? obj)  ?obj]
     169  (cond [(fixnum? obj)  obj]
    170170        [else           (%non-fixnum-number-hash obj)] ) )
    171171
     
    358358;; String Hash:
    359359
    360 (define (string-hash str #!optional (bound hash-default-bound))
     360(define (string-hash str #!optional (bound hash-default-bound) . start+end)
    361361  (##sys#check-string str 'string-hash)
    362362  (##sys#check-exact bound 'string-hash)
    363   (%hash/limit (%string-hash str) bound) )
    364 
    365 (define (string-ci-hash str #!optional (bound hash-default-bound))
     363  (let ((str (if (pair? start+end)
     364                 (let-optionals start+end ((start 0)
     365                                           (end (##sys#size str)))
     366                   (##sys#check-range start 0 (##sys#size str) 'string-hash)
     367                   (##sys#check-range end 0 (##sys#size str) 'string-hash)
     368                   (##sys#substring str start end) )
     369                 str) ) )
     370    (%hash/limit (%string-hash str) bound) ) )
     371
     372(define (string-ci-hash str #!optional (bound hash-default-bound) . start+end)
    366373  (##sys#check-string str 'string-ci-hash)
    367374  (##sys#check-exact bound 'string-ci-hash)
    368   (%hash/limit (%string-ci-hash str) bound) )
     375  (let ((str (if (pair? start+end)
     376                 (let-optionals start+end ((start 0)
     377                                           (end (##sys#size str)))
     378                   (##sys#check-range start 0 (##sys#size str) 'string-hash-ci)
     379                   (##sys#check-range end 0 (##sys#size str) 'string-hash-ci)
     380                   (##sys#substring str start end) )
     381                 str) ) )
     382  (%hash/limit (%string-ci-hash str) bound) ) )
     383
     384(define string-hash-ci string-ci-hash)
    369385
    370386
     
    457473                             (eq? string=? test))         string-hash]
    458474                        [(or (eq? core-string-ci=? test)
    459                              (eq? string-ci=? test))      string-ci-hash]
     475                             (eq? string-ci=? test))      string-hash-ci]
    460476                        [(or (eq? core= test)
    461477                             (eq? = test))                number-hash]
  • chicken/branches/prerelease/support.scm

    r13889 r14954  
    3232  compiler-arguments process-command-line dump-nodes dump-undefined-globals
    3333  default-standard-bindings default-extended-bindings
    34   foldable-bindings compiler-macro-environment
     34  foldable-bindings dump-defined-globals
    3535  installation-home optimization-iterations compiler-cleanup-hook decompose-lambda-list
    3636  file-io-only banner disabled-warnings internal-bindings
     
    6666  default-optimization-iterations chop-separator chop-extension follow-without-loop
    6767  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
    68   foreign-argument-conversion foreign-result-conversion final-foreign-type debugging
     68  foreign-argument-conversion foreign-result-conversion final-foreign-type debugging source-info->line
    6969  constant-declarations process-lambda-documentation big-fixnum? sort-symbols llist-length
    7070  export-dump-hook intrinsic? node->sexpr emit-global-inline-file inline-max-size
    71   make-random-name foreign-type-convert-result foreign-type-convert-argument)
     71  make-random-name foreign-type-convert-result foreign-type-convert-argument
     72  load-identifier-database)
    7273
    7374
     
    672673  (node-parameters-set! to (node-parameters from))
    673674  (node-subexpressions-set! to (node-subexpressions from))
    674   (let ([len-from (##sys#size from)]
    675         [len-to (##sys#size to)] )
    676     (do ([i 4 (fx+ i 1)])
    677         ((or (fx>= i len-from) (fx>= i len-to)))
    678       (##sys#setslot to i (##sys#slot from i)) ) ) )
     675  to)
    679676
    680677(define (node->sexpr n)
     
    809806     (when (and (assq 'global plist)
    810807                (not (assq 'assigned plist)) )
     808       (write sym)
     809       (newline) ) )
     810   db) )
     811
     812(define (dump-defined-globals db)
     813  (##sys#hash-table-for-each
     814   (lambda (sym plist)
     815     (when (and (assq 'global plist)
     816                (assq 'assigned plist))
    811817       (write sym)
    812818       (newline) ) )
     
    947953             [(nonnull-c-pointer)
    948954              `(##sys#foreign-pointer-argument ,param) ]
    949              [(c-string c-string* unsigned-c-string*)
     955             [(c-string c-string* unsigned-c-string unsigned-c-string*)
    950956              (let ([tmp (gensym)])
    951957                `(let ([,tmp ,param])
     
    10311037        0)
    10321038       ((c-string nonnull-c-string c-pointer nonnull-c-pointer symbol c-string* nonnull-c-string*
    1033                   unsigned-c-string* nonnull-unsigned-c-string*
     1039                  unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
    10341040                  c-string-list c-string-list*)
    10351041        (words->bytes 3) )
     
    10601066              c-pointer pointer nonnull-c-pointer unsigned-integer integer float c-string symbol
    10611067              scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer32
    1062               unsigned-c-string* nonnull-unsigned-c-string*
     1068              unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
    10631069              nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*) ; pointer and nonnull-pointer are DEPRECATED
    10641070        (words->bytes 1) )
     
    10811087(define (finish-foreign-result type body)
    10821088  (case type
    1083     [(c-string) `(##sys#peek-c-string ,body '0)]
     1089    [(c-string unsigned-c-string) `(##sys#peek-c-string ,body '0)]
    10841090    [(nonnull-c-string) `(##sys#peek-nonnull-c-string ,body '0)]
    10851091    [(c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body '0)]
     
    12831289                                  append mode
    12841290    -no-lambda-info              omit additional procedure-information
     1291    -scrutinize                  perform local flow analysis
     1292    -types FILENAME              load additional type database
    12851293
    12861294  Optimization options:
     
    12901298    -lambda-lift                 enable lambda-lifting
    12911299    -no-usual-integrations       standard procedures may be redefined
    1292     -unsafe                      disable safety checks
     1300    -unsafe                      disable all safety checks
    12931301    -local                       assume globals are only modified in current
    12941302                                  file
     
    13051313    -emit-inline-file FILENAME   generate file with globally inlinable
    13061314                                  procedures (implies -inline -local)
     1315    -consult-inline-file FILENAME  explicitly load inline file
     1316    -no-argc-checks              disable argument count checks
     1317    -no-bound-checks             disable bound variable checks
     1318    -no-procedure-checks         disable procedure call checks
     1319    -no-procedure-checks-for-usual-bindings
     1320                                 disable procedure call checks only for usual
     1321                                  bindings
    13071322
    13081323  Configuration options:
     
    13331348    -raw                         do not generate implicit init- and exit code                           
    13341349    -emit-external-prototypes-first
    1335                                  emit protoypes for callbacks before foreign
     1350                                 emit prototypes for callbacks before foreign
    13361351                                  declarations
    13371352    -ignore-repository           do not refer to repository for extensions
     
    14101425      (and info (->string info))) )
    14111426
     1427(define (source-info->line info)
     1428  (if (list? info)
     1429      (cadr info)
     1430      (and info (->string info))) )
     1431
    14121432
    14131433;;; We need this for constant folding:
     
    15041524
    15051525
    1506 ;;; compiler-specific syntax
    1507 
    1508 (define compiler-macro-environment
    1509   (let ((me0 (##sys#macro-environment)))
    1510     (##sys#extend-macro-environment
    1511      'define-rewrite-rule
    1512      '()
    1513      (##sys#er-transformer
    1514       (lambda (form r c)
    1515         (##sys#check-syntax 'define-rewrite-rule form '(_ (symbol . _) . #(_ 1)))
    1516         `(##core#define-rewrite-rule
    1517           ,(caadr form) (,(r 'lambda) ,(cdadr form) ,@(cddr form))))))
    1518     (##sys#macro-subset me0)))
    1519 
    1520 
    1521 ;;; not qualified, for use in `define-rewrite-rule'
    1522 
    1523 (define cdb-get get)
    1524 (define cdb-put! put!)
     1526;;; Load support files
     1527
     1528(define (load-identifier-database name)
     1529  (and-let* ((rp (repository-path))
     1530             (dbfile (file-exists? (make-pathname rp name))))
     1531    (when verbose-mode
     1532      (printf "loading identifier database ~a ...~%" dbfile))
     1533    (for-each
     1534     (lambda (e)
     1535       (##sys#put!
     1536        (car e) '##core#db
     1537        (append (or (##sys#get (car e) '##core#db) '()) (list (cdr e))) ))
     1538     (read-file dbfile))))
  • chicken/branches/prerelease/tcp.scm

    r13414 r14954  
    596596            (fail) ) )
    597597      (let ((err (get-socket-error s)))
    598         (cond ((= err -1)
     598        (cond ((= err -1)
     599               (##net#close s)
    599600               (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "getsockopt() failed - " strerror)))
    600               ((> err 0)
     601              ((> err 0)
     602               (##net#close s)
    601603               (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "cannot create socket - " (general-strerror err))))))
    602604      (##net#io-ports s) ) ) )
  • chicken/branches/prerelease/tests/compiler-tests.scm

    r13240 r14954  
    4949(import x)
    5050(bar 42)
     51
     52;;; rev. 14574 (reported by Peter Bex)
     53;
     54; - type specifiers in foreign-lambda in macros are incorrectly renamed
     55; - variable names and type specifiers in foreign-lambda* and
     56;    foreign-primitive in macros are incorrectly renamed
     57
     58(let-syntax ((strlen-macro
     59              (syntax-rules ()
     60                ((strlen-macro arg)
     61                 (print ((foreign-lambda int strlen c-string) arg)))))
     62             (strlen-macro*
     63              (syntax-rules ()
     64                ((strlen-macro* arg)
     65                 (print ((foreign-lambda* int ((c-string str))
     66                                          "C_return(strlen(str));") arg)))))
     67             (strlen-safe-macro
     68              (syntax-rules ()
     69                ((strlen-safe-macro arg)
     70                 (print ((foreign-safe-lambda int strlen c-string) arg)))))
     71             (strlen-safe-macro*
     72              (syntax-rules ()
     73                ((strlen-safe-macro* arg)
     74                 (print ((foreign-safe-lambda* int ((c-string str))
     75                                               "C_return(strlen(str));") arg)))))
     76             (strlen-primitive-macro
     77              (syntax-rules ()
     78                ((strlen-primitive-macro* arg)
     79                 (print ((foreign-primitive int ((c-string str))
     80                                            "C_return(strlen(str));") arg))))))
     81  (strlen-macro "hello, world")
     82  (strlen-macro* "hello, world")
     83  (strlen-safe-macro "hello, world")
     84  (strlen-safe-macro* "hello, world")
     85  (strlen-primitive-macro "hello, world"))
  • chicken/branches/prerelease/tests/runtests.sh

    r13876 r14954  
    1818
    1919echo "======================================== compiler tests ..."
    20 $compile compiler-tests.scm && ./a.out
     20$compile compiler-tests.scm
     21./a.out
    2122
    2223echo "======================================== compiler tests (2) ..."
    23 $compile compiler-tests.scm -lambda-lift && ./a.out
     24$compile compiler-tests.scm -lambda-lift
     25./a.out
     26
     27echo "======================================== scrutiny tests ..."
     28$compile scrutiny-tests.scm -scrutinize -analyze-only -ignore-repository -types ../types.db 2>scrutiny.out
     29diff -u scrutiny.out scrutiny.expected || exit 1
    2430
    2531echo "======================================== runtime tests ..."
    2632$interpret -s apply-test.scm
    27 $compile test-gc-hooks.scm && ./a.out
     33$compile test-gc-hooks.scm
     34./a.out
    2835
    2936echo "======================================== library tests ..."
     
    3441
    3542echo "======================================== syntax tests (compiled) ..."
    36 $compile syntax-tests.scm && ./a.out
     43$compile syntax-tests.scm
     44./a.out
    3745
    3846echo "======================================== syntax tests (2, compiled) ..."
    39 $compile syntax-tests-2.scm && ./a.out
     47$compile syntax-tests-2.scm
     48./a.out
    4049
    4150#echo "======================================== meta-syntax tests ..."
     
    5160$compile_s -s foo.import.scm -o foo.import.so
    5261$interpret -s import-library-test2.scm
    53 $compile import-library-test2.scm && ./a.out
     62$compile import-library-test2.scm
     63./a.out
    5464
    5565echo "======================================== syntax tests (matchable) ..."
     
    6676
    6777echo "======================================== module tests (compiled) ..."
    68 $compile module-tests-compiled.scm && ./a.out
     78$compile module-tests-compiled.scm
     79./a.out
    6980
    7081echo "======================================== module tests (chained) ..."
     
    8293$compile_s ec.import.scm -o ec.import.so
    8394$interpret -bnq ec.so ec-tests.scm
    84 # $compile ec-tests.scm && ./a.out        # takes ages to compile
     95# $compile ec-tests.scm
     96# ./a.out        # takes ages to compile
    8597
    8698echo "======================================== hash-table tests ..."
     
    94106
    95107echo "======================================== fixnum tests ..."
    96 $compile fixnum-tests.scm && ./a.out
     108$compile fixnum-tests.scm
     109./a.out
    97110
    98111echo "======================================== srfi-18 tests ..."
     
    101114
    102115echo "======================================== path tests ..."
    103 $compile path-tests.scm && ./a.out
     116$compile path-tests.scm
     117./a.out
    104118
    105119echo "======================================== regular expression tests ..."
     
    127141
    128142echo "======================================== finalizer tests (2) ..."
    129 $compile test-finalizers-2.scm && ./a.out
     143$compile test-finalizers-2.scm
     144./a.out
    130145
    131146echo "======================================== locative stress test ..."
    132 $compile locative-stress-test.scm && ./a.out
     147$compile locative-stress-test.scm
     148./a.out
    133149
    134150echo "======================================== embedding (1) ..."
    135 $compile embedded1.c && ./a.out
     151$compile embedded1.c
     152./a.out
    136153
    137154echo "======================================== embedding (2) ..."
    138 $compile -e embedded2.scm && ./a.out
     155$compile -e embedded2.scm
     156./a.out
    139157
    140158echo "======================================== benchmarks ..."
  • chicken/branches/prerelease/tests/srfi-18-tests.scm

    r13240 r14954  
    44(define-for-syntax count 0)
    55(define-syntax trail
     6  (er-macro-transformer
    67  (la