Changeset 15293 in project for chicken


Ignore:
Timestamp:
08/01/09 00:31:50 (10 years ago)
Author:
felix winkelmann
Message:

merged prerelease branch r15292 into release branch; synced with manual in wiki

Location:
chicken/branches/release
Files:
4 deleted
94 edited
14 copied

Legend:

Unmodified
Added
Removed
  • chicken/branches/release

  • chicken/branches/release/ANNOUNCE

    r13879 r15293  
    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/release/Makefile

    r13240 r15293  
    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."
  • chicken/branches/release/Makefile.bsd

    r13240 r15293  
    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/release/Makefile.macosx

    r13240 r15293  
    5858APPLY_HACK_OBJECT = apply-hack.$(ARCH)$(O)
    5959
     60# architectures
     61
     62ifeq ($(ARCH),x86-64)
     63C_COMPILER_OPTIONS += -m64
     64LINKER_OPTIONS += -m64
     65# Avoid bus error in install_name_tool
     66LINKER_LINK_SHARED_DLOADABLE_OPTIONS += -Wl,-headerpad -Wl,128
     67else
     68
     69ifeq ($(ARCH),universal)
     70C_COMPILER_OPTIONS += -arch ppc -arch i386 -isysroot /Developer/SDKs/MacOSX10.4u.sdk
     71LINKER_OPTIONS += -arch ppc -arch i386 -isysroot /Developer/SDKs/MacOSX10.4u.sdk
     72
     73ifneq ($(HACKED_APPLY),)
     74# We undefine HACKED_APPLY in order to override rules.make.
     75HACKED_APPLY=
     76apply-hack.ppc.darwin$(O): apply-hack.ppc.darwin.s
     77        as -arch ppc -o $@ $<
     78apply-hack.x86$(O): apply-hack.x86.s
     79        as -arch i386 -o $@ $<
     80$(APPLY_HACK_OBJECT): apply-hack.x86$(O) apply-hack.ppc.darwin$(O)
     81        lipo -create -output $(APPLY_HACK_OBJECT) $^
     82endif
     83endif
     84endif
     85
    6086# select default and internal settings
    6187
     
    103129        cat chicken-defaults.h >>$@
    104130
    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 
    130131include $(SRCDIR)/rules.make
  • chicken/branches/release/Makefile.mingw

    r13859 r15293  
    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/release/NEWS

    r13859 r15293  
     14.1.0
     2
     3- The new parameter "parantheses-synonyms" and the command-line
     4  option "-no-parantheses-synonyms" allows disabling list-like behaviour
     5  of "{ ... }" and "[ ... ]" tokens
     6- The new parameter "symbol-escape" and the command-line
     7  option "-no-symbol-escape" allows disabling "| ... |" symbol escape
     8  syntax
     9- Added command-line option "-r5rs-syntax" to disable CHICKEN-specific
     10  read-syntax
     11- Added compiler command-line-option "-no-compiler-syntax"
     12- Deprecated "getenv" (use "get-environment-variable" instead)
     13- Removed "macro?" and "undefine-macro!"
     14- Support for Microsoft Visual Studio / MSVC has been dropped
     15- The compiler provides now a simple flow-analysis pass that does
     16  basic checking of argument-count and -types for core library procedures
     17  (new option "-scrutinize")
     18- New compiler-options "-no-argc-checks", "-no-bound-checks",
     19  "-no-procedure checks", "-no-procedure-checks-for-usual-bindings",
     20  "-types TYPEFILE" and "-consult-inline-file FILENAME"
     21- Added a "chicken-setup" stub-application to catch incorrect use of
     22  this tool (which has been replaced in 4.0.0 with "chicken-install")
     23- Changed "setup-install-flag" and "setup-verbose-flag" to
     24  "setup-install-mode" and "setup-verbose-mode" in "setup-api" module,
     25  the old names are still available but deprecated
     26- Posix unit:
     27  added "socket?", "block-device?" and "character-device?", deprecated
     28  redundant "stat-..." procedures
     29- Also in Posix unit: "canonical-path" has been deprecated, "normalize-pathname"
     30  from the "files" unit provides now most of the functionality
     31- Added "directory-exists?"
     32- "(for-each (lambda ...) X)" is compiled as a loop
     33- The argument-count check for format-strings for "[sf]printf" with a constant
     34  string argument is done at compile-time
     35- A stub application named "chicken-setup" is installed to catch when a
     36  user invokes theobsolete tool instead of the new "chicken-install".
     37
    1384.0.0
    239
  • chicken/branches/release/README

    r14094 r15293  
    11
    2   README file for the CHICKEN compiler
     2  README file for the CHICKEN Scheme system
    33  (c) 2000-2007, Felix L. Winkelmann
    44  (c) 2008-2009, The Chicken Team
    55
    6   version 4.0.0x5
     6  version 4.1.0
    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/release/TODO

    r13876 r15293  
    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/release/batch-driver.scm

    r13859 r15293  
    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
    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
     
    4646  current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables
    4747  rest-parameters-promoted-to-vector inline-table inline-table-used constant-table constants-used
    48   broken-constant-nodes inline-substitutions-enabled
     48  broken-constant-nodes inline-substitutions-enabled compiler-syntax-statistics
    4949  emit-profile profile-lambda-list profile-lambda-index profile-info-vector-name
    5050  direct-call-ids foreign-type-table first-analysis emit-closure-info
     
    5353  reorganize-recursive-bindings substitution-table simplify-named-call emit-unsafe-marker
    5454  perform-closure-conversion prepare-for-code-generation compiler-source-file create-foreign-stub expand-foreign-lambda*
    55   transform-direct-lambdas! source-filename standalone-executable
     55  transform-direct-lambdas! source-filename standalone-executable compiler-syntax-enabled
    5656  debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list
    5757  string->c-identifier c-ify-string words check-and-open-input-file close-checked-input-file fold-inner constant?
     
    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
     
    113114                       [(memq 'to-stdout options) #f]
    114115                       [else (make-pathname #f (if filename (pathname-file filename) "out") "c")] ) ]
    115         [ipath (map chop-separator (string-split (or (getenv "CHICKEN_INCLUDE_PATH") "") ";"))]
     116        [ipath (map chop-separator (string-split (or (get-environment-variable "CHICKEN_INCLUDE_PATH") "") ";"))]
    116117        [opasses default-optimization-passes]
    117118        [time0 #f]
     
    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))
     
    239241    (when (memq 'no-lambda-info options)
    240242      (set! emit-closure-info #f) )
     243    (when (memq 'no-compiler-syntax options)
     244      (set! compiler-syntax-enabled #f))
    241245    (when (memq 'local options)
    242246      (set! local-definitions #t))
    243247    (when (memq 'inline-global options)
     248      (set! enable-inline-files #t)
    244249      (set! inline-locally #t)
    245250      (set! inline-globally #t))
     
    303308    (when (memq 'keep-shadowed-macros options)
    304309      (set! undefine-shadowed-macros #f) )
     310    (when (memq 'no-argc-checks options)
     311      (set! no-argc-checks #t) )
     312    (when (memq 'no-bound-checks options)
     313      (set! no-bound-checks #t) )
     314    (when (memq 'no-procedure-checks options)
     315      (set! no-procedure-checks #t) )
     316    (when (memq 'no-procedure-checks-for-usual-bindings options)
     317      (for-each
     318       (lambda (v)
     319         (mark-variable v '##compiler#always-bound-to-procedure)
     320         (mark-variable v '##compiler#always-bound) )
     321       default-standard-bindings)
     322      (for-each
     323       (lambda (v)
     324         (mark-variable v '##compiler#always-bound-to-procedure)
     325         (mark-variable v '##compiler#always-bound) )
     326       default-extended-bindings) )
    305327
    306328    ;; Handle feature options:
     
    331353         initforms
    332354         (map (lambda (r) `(##core#require-extension (,r) #t))
    333               (append se (collect-options 'require-extension)))))
     355              (append se (map string->symbol (collect-options 'require-extension))))))
    334356
    335357      ;; add static-extensions as used units:
     
    378400
    379401    ;;*** 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)))
     402    (load-identifier-database "modules.db")
    389403
    390404    (cond ((memq 'version options)
     
    474488                         '((##core#undefined))) ] )
    475489
     490             (when (and (pair? compiler-syntax-statistics)
     491                        (debugging 'x "applied compiler syntax:"))
     492               (for-each
     493                (lambda (cs) (printf "  ~a\t\t~a~%" (car cs) (cdr cs)))
     494                compiler-syntax-statistics))
    476495             (when (debugging '|N| "real name table:")
    477496               (display-real-name-table) )
     
    485504               (compiler-warning
    486505                'style
    487                 "compiling extensions in unsafe mode is bad practice and should be avoided as it may be surprising to an unsuspecting user") )
     506                "compiling extensions in unsafe mode is bad practice and should be avoided") )
    488507
    489508             (set! ##sys#line-number-database line-number-database-2)
     
    502521                 (end-time "user pass") ) )
    503522
    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...")
     523             (let ((node0 (make-node
     524                           'lambda '(())
     525                           (list (build-node-graph
     526                                  (canonicalize-begin-body exps) ) ) ) )
     527                   (db #f))
     528
     529               (print-node "initial node tree" '|T| node0)
     530               (initialize-analysis-database)
     531
     532               (when do-scrutinize
     533                 ;;;*** hardcoded database file name
     534                 (unless (memq 'ignore-repository options)
     535                   (load-type-database "types.db"))
     536                 (for-each (cut load-type-database <> #f) (collect-options 'types))
    525537                 (begin-time)
    526538                 (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) )
     539                 (set! db (analyze 'scrutiny node0))
     540                 (print-db "analysis" '|0| db 0)
     541                 (end-time "pre-analysis")
     542                 (begin-time)
     543                 (debugging 'p "performing scrutiny")
     544                 (scrutinize node0 db)
     545                 (end-time "scrutiny")
    534546                 (set! first-analysis #t) )
    535547
    536548               (when do-lambda-lifting
    537549                 (begin-time)
    538                  (set! first-analysis #f)
    539                  (let ([db (analyze 'lift node0)])
     550                 (unless do-scrutinize  ; no need to do analysis if already done above
     551                   (set! first-analysis #f)
     552                   (set! db (analyze 'lift node0))
    540553                   (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                   (end-time "pre-analysis (lambda-lift)"))
     555                 (begin-time)
     556                 (perform-lambda-lifting! node0 db)
     557                 (end-time "lambda lifting")
     558                 (print-node "lambda lifted" '|L| node0)
    546559                 (set! first-analysis #t) )
     560               
     561               (let ((req (concatenate (vector->list file-requirements))))
     562                 (when (debugging 'M "; requirements:")
     563                   (pp req))
     564                 (when enable-inline-files
     565                   (for-each
     566                    (lambda (id)
     567                      (and-let* ((ifile (##sys#resolve-include-filename
     568                                         (make-pathname #f (symbol->string id) "inline")
     569                                         #f #t))
     570                                 ((file-exists? ifile)))
     571                        (dribble "Loading inline file ~a ..." ifile)
     572                        (load-inline-file ifile)))
     573                    (concatenate (map cdr req))) )
     574                 (let ((ifs (collect-options 'consult-inline-file)))
     575                   (unless (null? ifs)
     576                     (set! inline-globally #t)
     577                     (set! inline-locally #t)
     578                     (for-each
     579                      (lambda (ilf)
     580                        (dribble "Loading inline file ~a ..." ilf)
     581                        (load-inline-file ilf) )
     582                      ifs))))
    547583
    548584               (set! ##sys#line-number-database #f)
     
    564600                     (when first-analysis
    565601                       (when (memq 'u debugging-chicken)
    566                          (dump-undefined-globals db)) )
     602                         (dump-undefined-globals db))
     603                       (when (memq 'd debugging-chicken)
     604                         (dump-defined-globals db)) )
    567605                     (set! first-analysis #f)
    568606                     (end-time "analysis")
  • chicken/branches/release/benchmarks/cscbench.scm

    r13240 r15293  
    102102  (system* "echo `csc -cflags`")
    103103  (display "\nRunning benchmarks ...\n\n  (averaging over 5 runs, dropping highest and lowest, binaries are statically linked and stripped)\n")
    104   (display "\n                     (runtime)                      (code size)\n")
     104  (display "\n                     (runtime)                                  (code size)\n")
    105105  (display "\n                     base       fast     unsafe        max      base      fast    unsafe       max")
    106106  (display "\n                  ----------------------------------------------------------------------------------\n")
  • chicken/branches/release/buildversion

    r13249 r15293  
    1 4.0.0
     14.1.0
  • chicken/branches/release/c-backend.scm

    r13240 r15293  
    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/release/c-platform.scm

    r13859 r15293  
    106106
    107107(define eq-inline-operator "C_eqp")
    108 (define optimizable-rest-argument-operators '(car cadr caddr cadddr length pair? null? list-ref))
     108(define optimizable-rest-argument-operators
     109  '(car cadr caddr cadddr length pair? null? list-ref))
    109110(define membership-test-operators
    110111  '(("C_i_memq" . "C_eqp") ("C_u_i_memq" . "C_eqp") ("C_i_member" . "C_i_equalp")
     
    116117  '(-help h help version verbose explicit-use
    117118          quiet                         ; DEPRECATED
    118           no-trace no-warnings unsafe block
     119          no-trace no-warnings unsafe block 
    119120    check-syntax to-stdout no-usual-integrations case-insensitive no-lambda-info
    120121    profile inline keep-shadowed-macros ignore-repository
     
    123124    disable-stack-overflow-checks disable-c-syntax-checks unsafe-libraries raw
    124125    emit-external-prototypes-first release local inline-global
    125     analyze-only dynamic
     126    analyze-only dynamic scrutinize no-argc-checks no-procedure-checks
     127    no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax
    126128    no-parentheses-synonyms no-symbol-escape r5rs-syntax) )
    127129
     
    129131  '(debug output-file include-path heap-size stack-size unit uses keyword-style require-extension
    130132          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
     133    prelude postlude prologue epilogue nursery extend feature types
     134    emit-import-library emit-inline-file static-extension consult-inline-file
    133135    heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path) )
    134136
     
    157159
    158160(define default-extended-bindings
    159   '(bitwise-and bitwise-ior bitwise-xor bitwise-not add1 sub1 fx+ fx- fx* fx/ fxmod
     161  '(bitwise-and bitwise-ior bitwise-xor bitwise-not add1 sub1 fx+ fx- fx* fx/ fxmod o
    160162    fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity fp+ fp- fp* fp/ fpmin fpmax fpneg
    161163    fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set?
     
    177179    u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
    178180    locative-ref locative-set! locative->object locative? global-ref
    179     null-pointer? pointer->object flonum? finite?) )
     181    null-pointer? pointer->object flonum? finite?
     182    printf sprintf format) )
    180183
    181184(define internal-bindings
     
    200203  '(vector
    201204    cons list string make-vector make-string string->symbol values current-input-port current-output-port
    202     read-char write-char
     205    read-char write-char printf fprintf
    203206    apply call-with-current-continuation set-car! set-cdr! write-char newline write display
    204207    peek-char char-ready?
     
    209212    u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared s16vector->blob/shared u32vector->blob/shared
    210213    f32vector->blob/shared f64vector->blob/shared
    211     s32vector->blob/shared read-string read-string!
     214    s32vector->blob/shared read-string read-string! o
    212215    ##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot ##sys#block-ref
    213216    ##sys#byte ##sys#setbyte
  • chicken/branches/release/chicken-bug.scm

    r13876 r15293  
    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/release/chicken-ffi-syntax.scm

    r13240 r15293  
    138138 (##sys#er-transformer
    139139  (lambda (form r c)
    140     (##sys#check-syntax 'foreign-value form '(_ string _))
    141     (let ([tmp (gensym 'code_)])
     140    (##sys#check-syntax 'foreign-value form '(_ _ _))
     141    (let ((tmp (gensym 'code_))
     142          (code (cadr form)))
    142143      `(,(r 'begin)
    143         (,(r 'define-foreign-variable) ,tmp ,(caddr form) ,(cadr form))
     144        (,(r 'define-foreign-variable) ,tmp
     145         ,(caddr form)
     146         ,(cond ((string? code) code)
     147                ((symbol? code) (symbol->string code))
     148                (else (syntax-error 'foreign-value "bad argument type - not a string or symbol" code))))
    144149        ,tmp) ) ) ) )
    145150
  • chicken/branches/release/chicken-install.scm

    r13859 r15293  
    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
     
    4041  (define +default-repository-files+
    4142    '("setup-api.so" "setup-api.import.so"
    42       "setup-utils.so" "setup-utils.import.so"
    4343      "setup-download.so" "setup-download.import.so"
    4444      "chicken.import.so"
     
    6262      "csi.import.so"
    6363      "irregex.import.so"
    64       "compiler.import.so"))
     64      "types.db"))
    6565
    6666  (define *program-path*
    67     (or (and-let* ((p (getenv "CHICKEN_PREFIX")))
     67    (or (and-let* ((p (get-environment-variable "CHICKEN_PREFIX")))
    6868          (make-pathname p "bin") )
    6969        (foreign-value "C_INSTALL_BIN_HOME" c-string) ) )
     
    129129               (if a
    130130                   (->string (cadr a))
    131                    "1.0.0"))))
     131                   "0.0.0"))))
    132132          (else #f)))
    133133
     
    152152                     (let ((v (ext-version (car dep))))
    153153                       (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)
     154                              (loop rest (cons (->string (car dep)) missing) upgrade))
     155                             ((not (version>=? v (->string (cadr dep))))
     156                              (when (string=? "chicken" (->string (car dep)))
     157                                (error
     158                                 (string-append
     159                                  "Your CHICKEN version is not recent enough to use this extension - version "
     160                                  (cadr dep)
     161                                  " or newer is required")))
    163162                              (loop rest missing
    164163                                    (alist-cons
     
    282281     (if (sudo-install) " -e \"(sudo-install #t)\"" "")
    283282     (if *keep* " -e \"(keep-intermediates #t)\"" "")
    284      (if *no-install* " -e \"(setup-install-flag #f)\"" "")
     283     (if *no-install* " -e \"(setup-install-mode #f)\"" "")
    285284     (if *host-extension* " -e \"(host-extension #t)\"" "")
    286285     (if *prefix* (sprintf " -e \"(installation-prefix \\\"~a\\\")\"" *prefix*) "")
     
    318317           (dbfile (make-pathname tmpdir +module-db+))
    319318           (rx (regexp ".*/([^/]+)\\.import\\.(scm|so)")))
     319      (print "loading import libraries ...")
    320320      (fluid-let ((##sys#warnings-enabled #f))
    321321        (for-each
    322322         (lambda (f)
    323323           (let ((m (string-match rx f)))
    324              (eval `(import ,(string->symbol (cadr m))))))
     324             (handle-exceptions ex
     325                 (print-error-message
     326                  ex (current-error-port)
     327                  (sprintf "Failed to import from `~a'" f))
     328               (eval `(import ,(string->symbol (cadr m)))))))
    325329         files))
    326330      (print "generating database")
     
    493497
    494498  (register-feature! 'chicken-install)
    495   (define ##compiler#compiler-macro-environment '()) ; only to make `compiler' import work
    496499
    497500  (handle-exceptions ex
  • chicken/branches/release/chicken-primitive-object-inlines.scm

    r13859 r15293  
    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/release/chicken-syntax.scm

    r13240 r15293  
    11;;;; chicken-syntax.scm - non-standard syntax extensions
    22;
     3; Copyright (c) 2008-2009, The Chicken Team
    34; Copyright (c) 2000-2007, Felix L. Winkelmann
    4 ; Copyright (c) 2008-2009, The Chicken Team
    55; All rights reserved.
    66;
     
    3333  (fixnum) )
    3434
    35 (##sys#provide 'chicken-more-macros 'chicken-syntax)
     35(##sys#provide
     36 'chicken-more-macros                   ; historical, remove later
     37 'chicken-syntax)
    3638
    3739
     
    4951           (slots (cddr x))
    5052           (prefix (symbol->string name))
     53           (%quote (r 'quote))
    5154           (setters (memq #:record-setters ##sys#features))
    5255           (%begin (r 'begin))
     
    5760          (,%define
    5861           ,(string->symbol (string-append "make-" prefix))
    59            (,%lambda ,slots (##sys#make-structure ',name ,@slots)) )
     62           (,%lambda ,slots (##sys#make-structure (,%quote ,name) ,@slots)) )
    6063          (,%define
    6164           ,(string->symbol (string-append prefix "?"))
     
    7275                         ,setr
    7376                         (,%lambda (x val)
    74                                    (##core#check (##sys#check-structure x ',name))
     77                                   (##core#check (##sys#check-structure x (,%quote ,name)))
    7578                                   (##sys#block-set! x ,i val) ) )
    7679                        (,%define
     
    7982                              `(,%getter-with-setter
    8083                                (,%lambda (x)
    81                                           (##core#check (##sys#check-structure x ',name))
     84                                          (##core#check (##sys#check-structure x (,%quote ,name)))
    8285                                          (##sys#block-ref x ,i) )
    8386                                ,setr)
    8487                              `(,%lambda (x)
    85                                          (##core#check (##sys#check-structure x ',name))
     88                                         (##core#check (##sys#check-structure x (,%quote ,name)))
    8689                                         (##sys#block-ref x ,i) ) ) ) )
    8790                     (mapslots (##sys#slot slots 1) (fx+ i 1)) ) ) ) ) ) ) ) ) )
     
    415418
    416419(##sys#extend-macro-environment
    417  'nth-value '()
     420 'nth-value
     421 `((list-ref . ,(##sys#primitive-alias 'list-ref)))
    418422 (##sys#er-transformer
    419423  (lambda (form r c)
    420424    (##sys#check-syntax 'nth-value form '(_ _ _))
    421425    (let ((v (r 'tmp))
    422           (%list-ref (r 'list-ref))
    423426          (%lambda (r 'lambda)))
    424427      `(##sys#call-with-values
    425428        (,%lambda () ,(caddr form))
    426         (,%lambda ,v (,%list-ref ,v ,(cadr form))))))))
     429        (,%lambda ,v (,(r 'list-ref) ,v ,(cadr form))))))))
    427430
    428431(##sys#extend-macro-environment
     
    478481          (%else (r 'else))
    479482          (%or (r 'or))
    480           (%eqv? (r 'eqv?))
    481483          (%begin (r 'begin)))
    482484      `(,(r 'let) ((,tmp ,exp))
     
    489491                 (if (c %else (car clause))
    490492                     `(,%begin ,@(cdr clause))
    491                      `(,%if (,%or ,@(map (lambda (x) `(,%eqv? ,tmp ,x))
     493                     `(,%if (,%or ,@(map (lambda (x) `(##sys#eqv? ,tmp ,x))
    492494                                         (car clause) ) )
    493495                            (,%begin ,@(cdr clause))
     
    572574
    573575(##sys#extend-macro-environment
    574  'let-optionals '()
     576 'let-optionals
     577 `((car . ,(##sys#primitive-alias 'car))
     578   (cdr . ,(##sys#primitive-alias 'cdr)))
    575579 (##sys#er-transformer
    576580  (lambda (form r c)
     
    579583          (var/defs (caddr form))
    580584          (body (cdddr form))
    581           (%null? (r 'null?))
    582585          (%if (r 'if))
    583586          (%let (r 'let))
    584           (%car (r 'car))
    585           (%cdr (r 'cdr))
    586587          (%lambda (r 'lambda)))
    587588
     
    610611        (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
    611612          (if (null? vars)
    612               `(,%if (##core#check (,%null? ,rest))
     613              `(,%if (##core#check (,(r 'null?) ,rest))
    613614                     (,body-proc . ,(reverse non-defaults))
    614615                     (##sys#error (##core#immutable '"too many optional arguments") ,rest))
     
    616617                `(,%if (null? ,rest)
    617618                       (,(car defaulters) . ,(reverse non-defaults))
    618                        (,%let ((,v (,%car ,rest))
    619                                (,rest (,%cdr ,rest)))
     619                       (,%let ((,v (,(r 'car) ,rest)) ; we use car/cdr, because of rest-list optimization
     620                               (,rest (,(r 'cdr) ,rest)))
    620621                              ,(recur (cdr vars)
    621622                                      (cdr defaulters)
     
    667668
    668669(##sys#extend-macro-environment
    669  'optional '()
     670 'optional
     671 `((null? . ,(##sys#primitive-alias 'null?))
     672   (car . ,(##sys#primitive-alias 'car))
     673   (cdr . ,(##sys#primitive-alias 'cdr)) )
    670674 (##sys#er-transformer
    671675  (lambda (form r c)
    672676    (##sys#check-syntax 'optional form '(_ _ . #(_ 0 1)))
    673677    (let ((var (r 'tmp))
    674           (%null? (r 'null?))
    675678          (%if (r 'if)))
    676679      `(,(r 'let) ((,var ,(cadr form)))
    677         (,%if (,%null? ,var)
     680        (,%if (,(r 'null?) ,var)
    678681              ,(optional (cddr form) #f)
    679               (,%if (##core#check (,%null? (,(r 'cdr) ,var)))
     682              (,%if (##core#check (,(r 'null?) (,(r 'cdr) ,var)))
    680683                    (,(r 'car) ,var)
    681684                    (##sys#error
     
    700703
    701704(##sys#extend-macro-environment
    702  'let-optionals* '()
     705 'let-optionals*
     706 `((null? . ,(##sys#primitive-alias 'null?)))
    703707 (##sys#er-transformer
    704708  (lambda (form r c)
     
    708712          (body (cdddr form))
    709713          (%let (r 'let))
    710           (%if (r 'if))
    711714          (%null? (r 'null?))
    712715          (%car (r 'car))
    713           (%cdr (r 'cdr)))
     716          (%cdr (r 'cdr))
     717          (%if (r 'if)))
    714718      (let ((rvar (r 'tmp)))
    715719        `(,%let ((,rvar ,args))
     
    737741
    738742(##sys#extend-macro-environment
    739  'case-lambda '()
     743 'case-lambda
     744 `((>= . ,(##sys#primitive-alias '>=))
     745   (car . ,(##sys#primitive-alias 'car))
     746   (cdr . ,(##sys#primitive-alias 'cdr))
     747   (eq? . ,(##sys#primitive-alias 'eq?)))
    740748 (##sys#er-transformer
    741749  (lambda (form r c)
     
    746754            '()
    747755            (cons (r (gensym)) (loop (fx+ i 1))) ) ) )
    748     (require 'srfi-1)                   ; Urgh...
     756    (require 'srfi-1)                   ; ugh...
    749757    (let* ((mincount (apply min (map (lambda (c)
    750758                                       (##sys#decompose-lambda-list
     
    757765           (%lambda (r 'lambda))
    758766           (%let (r 'let))
     767           (%>= (r '>=))
     768           (%eq? (r 'eq?))
     769           (%car (r 'car))
     770           (%cdr (r 'cdr))
    759771           (%if (r 'if)))
    760772      `(,%lambda ,(append minvars rvar)
     
    770782                                             (if (zero? a2)
    771783                                                 #t
    772                                                  `(,(r 'fx>=) ,lvar ,a2) )
    773                                              `(,(r 'fx=) ,lvar ,a2) ) )
     784                                                 `(,%>= ,lvar ,a2) )
     785                                             `(,%eq? ,lvar ,a2) ) )
    774786                                      ,(receive (vars1 vars2)
    775787                                           (split-at! (take vars argc) mincount)
     
    781793                                                            (else `(,%let () ,@(cdr c))) )
    782794                                                      (let ((vrest2 (r (gensym))))
    783                                                         `(,%let ((,(car vars2) (,(r 'car) ,vrest))
    784                                                                  (,vrest2 (,(r 'cdr) ,vrest)) )
     795                                                        `(,%let ((,(car vars2) (,%car ,vrest))
     796                                                                 (,vrest2 (,%cdr ,vrest)) )
    785797                                                                ,(if (pair? (cdr vars2))
    786798                                                                     (build (cdr vars2) vrest2)
     
    818830
    819831(##sys#extend-macro-environment
    820  'handle-exceptions '()
     832 'handle-exceptions
     833 `((call-with-current-continuation . ,(##sys#primitive-alias 'call-with-current-continuation))
     834   (with-exception-handler . ,(##sys#primitive-alias 'with-exception-handler)))
    821835 (##sys#er-transformer
    822836  (lambda (form r c)
     
    837851
    838852(##sys#extend-macro-environment
    839  'condition-case '()
     853 'condition-case
     854 `((else . ,(##sys#primitive-alias 'else))
     855   (memv . ,(##sys#primitive-alias 'memv)))
    840856 (##sys#er-transformer
    841857  (lambda (form r c)
     
    845861          (%and (r 'and))
    846862          (%let (r 'let))
     863          (%quote (r 'quote))
    847864          (%memv (r 'memv))
    848865          (%else (r 'else)))
     
    856873                     `(,%let ([,var ,exvar]) ,@body)
    857874                     `(,%let () ,@body) ) )
    858               `((,%and ,kvar ,@(map (lambda (k) `(,%memv ',k ,kvar)) kinds))
     875              `((,%and ,kvar ,@(map (lambda (k) `(,%memv (,%quote ,k) ,kvar)) kinds))
    859876                ,(if var
    860877                     `(,%let ([,var ,exvar]) ,@body)
    861878                     `(,%let () ,@body) ) ) ) ) )
    862879      `(,(r 'handle-exceptions) ,exvar
    863         (,%let ([,kvar (,%and (##sys#structure? ,exvar 'condition)
     880        (,%let ([,kvar (,%and (##sys#structure? ,exvar (,%quote condition) )
    864881                              (##sys#slot ,exvar 1))])
    865882               (,(r 'cond) ,@(map parse-clause (cddr form))
     
    871888
    872889(##sys#extend-macro-environment
    873  'define-record-type '()
     890 'define-record-type
     891 `((getter-with-setter . (##sys#primitive-alias 'getter-with-setter)))
    874892 (##sys#er-transformer
    875893  (lambda (form r c)
     
    882900          (%lambda (r 'lambda))
    883901          (%define (r 'define))
     902          (%quote (r 'quote))
     903          (%getter-with-setter (r 'getter-with-setter))
    884904          (vars (cdr conser))
    885905          (x (r 'x))
    886906          (y (r 'y))
    887           (%getter-with-setter (r 'getter-with-setter))
    888907          (slotnames (map car slots)))
    889908      `(,%begin
    890909        (,%define ,conser
    891910                  (##sys#make-structure
    892                    ',t
     911                   (,%quote ,t)
    893912                   ,@(map (lambda (sname)
    894913                            (if (memq sname vars)
     
    896915                                '(##core#undefined) ) )
    897916                          slotnames) ) )
    898         (,%define (,pred ,x) (##sys#structure? ,x ',t))
     917        (,%define (,pred ,x) (##sys#structure? ,x (,%quote ,t)))
    899918        ,@(let loop ([slots slots] [i 1])
    900919            (if (null? slots)
     
    904923                       (setr? (pair? (cddr slot)))
    905924                       (getr `(,%lambda (,x)
    906                                         (##core#check (##sys#check-structure ,x ',t))
     925                                        (##core#check (##sys#check-structure ,x (,%quote ,t)))
    907926                                        (##sys#block-ref ,x ,i) ) ) )
    908927                  `(,@(if setr?
    909928                          `((,%define (,(caddr slot) ,x ,y)
    910                                       (##core#check (##sys#check-structure ,x ',t))
     929                                      (##core#check (##sys#check-structure ,x (,%quote ,t)))
    911930                                      (##sys#block-set! ,x ,i ,y)) )
    912931                          '() )
     
    921940
    922941(##sys#extend-macro-environment
    923  'cut '()
     942 'cut
     943 `((apply . ,(##sys#primitive-alias 'apply)))
    924944 (##sys#er-transformer
    925945  (lambda (form r c)
     
    945965
    946966(##sys#extend-macro-environment
    947  'cute '()
     967 'cute
     968 `((apply . ,(##sys#primitive-alias 'apply)))
    948969 (##sys#er-transformer
    949970  (lambda (form r c)
    950971    (let ((%let (r 'let))
    951972          (%lambda (r 'lambda))
     973          (%apply (r 'apply))
    952974          (%<> (r '<>))
    953           (%<...> (r '<...>))
    954           (%apply (r 'apply)))
     975          (%<...> (r '<...>)))
    955976      (let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f])
    956977        (if (null? xs)
     
    10471068
    10481069
    1049 ;;; Just for backwards compatibility
     1070;;; use
    10501071
    10511072(##sys#extend-macro-environment
     
    10571078
    10581079
    1059 ;;;
     1080;;; compiler syntax
     1081
     1082(##sys#extend-macro-environment
     1083 'define-compiler-syntax '()
     1084 (##sys#er-transformer
     1085  (syntax-rules ()
     1086    ((_ (name . llist) body ...)
     1087     (define-compiler-syntax name (lambda llist body ...)))
     1088    ((_ name transformer)
     1089     (##core#define-compiler-syntax name transformer)))))
     1090
     1091(##sys#extend-macro-environment
     1092 'let-compiler-syntax '()
     1093 (##sys#er-transformer
     1094  (syntax-rules ()
     1095    ((_ ((name transformer) ...) body ...)
     1096     (##core#let-compiler-syntax ((name transformer) ...) body ...)))))
    10601097
    10611098
     
    10691106
    10701107
    1071 (##sys#macro-subset me0)))
     1108(##sys#macro-subset me0 ##sys#default-macro-environment)))
     1109
     1110;; register features
    10721111
    10731112(eval-when (compile load eval)
  • chicken/branches/release/chicken.h

    r13414 r15293  
    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/release/chicken.import.scm

    r13859 r15293  
    7777   features
    7878   file-exists?
     79   directory-exists?
    7980   fixnum-bits
    8081   fixnum-precision
     
    131132   get-output-string
    132133   get-properties
    133    getenv
     134   getenv                               ; DEPRECATED
    134135   getter-with-setter
    135136   implicit-exit-handler
     
    169170   remprop!
    170171   rename-file
     172   repl
     173   repl-prompt
    171174   repository-path
    172175   require
     
    200203   void
    201204   warning
     205   eval-handler
     206   er-macro-transformer
     207   dynamic-load-libraries
    202208   with-exception-handler)
    203  ##sys#chicken-macro-environment)       ;*** incorrect - won't work in compiled executable
     209 ##sys#chicken-macro-environment)       ;*** incorrect - won't work in compiled executable that does expansion
  • chicken/branches/release/chicken.scm

    r13240 r15293  
    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
     
    7878   (remove
    7979    (lambda (x) (string=? x ""))
    80     (string-split (or (getenv "CHICKEN_OPTIONS") "")))
     80    (string-split (or (get-environment-variable "CHICKEN_OPTIONS") "")))
    8181   (cdr (argv))))
    8282
  • chicken/branches/release/compiler.scm

    r13859 r15293  
    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
     
    99101; (quote <exp>)
    100102; (if <exp> <exp> [<exp>])
     103; ([##core#]syntax <exp>)
    101104; ([##core#]let <variable> ({(<variable> <exp>)}) <body>)
    102105; ([##core#]let ({(<variable> <exp>)}) <body>)
     
    106109; ([##core#]lambda ({<variable>}+ [. <variable>]) <body>)
    107110; ([##core#]set! <variable> <exp>)
     111; ([##core#]begin <exp> ...)
    108112; (##core#named-lambda <name> <llist> <body>)
    109113; (##core#loop-lambda <llist> <body>)
     
    135139; (##core#require-extension (<id> ...) <bool>)
    136140; (##core#app <exp> {<exp>})
    137 ; (##coresyntax <exp>)
     141; ([##core#]syntax <exp>)
    138142; (<exp> {<exp>})
    139143; (define-syntax <symbol> <expr>)
     
    141145; (define-compiled-syntax <symbol> <expr>)
    142146; (define-compiled-syntax (<symbol> . <llist>) <expr> ...)
     147; (##core#define-compiler-syntax <symbol> <expr>)
     148; (##core#let-compiler-syntax ((<symbol> <expr>) ...) <expr> ...)
    143149; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
    144 ; (##core#define-rewrite-rule <symbol> <expr>)
    145150
    146151; - Core language:
     
    288293  pprint-expressions-to-file foreign-type-check estimate-foreign-result-size scan-used-variables scan-free-variables
    289294  topological-sort print-version print-usage initialize-analysis-database csc-control-file
    290   estimate-foreign-result-location-size inline-output-file
     295  estimate-foreign-result-location-size inline-output-file compiler-syntax-enabled
    291296  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
    292297  units-used-by-default words-per-flonum disable-stack-overflow-checking
     
    294299  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
    295300  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?
     301  location-pointer-map inline-globally enable-inline-files
     302  local-definitions export-variable variable-mark intrinsic? do-scrutinize
    298303  undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info
    299304  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
     
    302307  big-fixnum? import-libraries unlikely-variables)
    303308
     309
     310(define (d arg1 . more)
     311  (if (null? more)
     312      (pp arg1)
     313      (apply print arg1 more)))
     314
     315(define-syntax d (syntax-rules () ((_ . _) (void))))
    304316
    305317(include "tweaks")
     
    368380(define inline-locally #f)
    369381(define inline-output-file #f)
     382(define do-scrutinize #f)
     383(define enable-inline-files #f)
     384(define compiler-syntax-enabled #t)
    370385
    371386
     
    414429(define file-requirements #f)
    415430(define postponed-initforms '())
    416 (define literal-rewrite-hook #f)
    417431
    418432
     
    474488        x) )
    475489
    476   (define (resolve-variable x0 se dest)
     490  (define (resolve-variable x0 e se dest)
    477491    (let ((x (lookup x0 se)))
     492      (d `(RESOLVE-VARIABLE: ,x0 ,x ,(map car se)))
    478493      (cond ((not (symbol? x)) x0)      ; syntax?
    479494            [(and constants-used (##sys#hash-table-ref constant-table x))
    480              => (lambda (val) (walk (car val) se dest)) ]
     495             => (lambda (val) (walk (car val) e se dest)) ]
    481496            [(and inline-table-used (##sys#hash-table-ref inline-table x))
    482              => (lambda (val) (walk val se dest)) ]
     497             => (lambda (val) (walk val e se dest)) ]
    483498            [(assq x foreign-variables)
    484499             => (lambda (fv)
     
    490505                      (finish-foreign-result ft body)
    491506                      t)
    492                      se dest)))]
     507                     e se dest)))]
    493508            [(assq x location-pointer-map)
    494509             => (lambda (a)
     
    500515                      (finish-foreign-result ft body)
    501516                      t)
    502                      se dest))) ]
    503             ((not (assq x0 se)) (##sys#alias-global-hook x #f)) ; only if global
     517                     e se dest))) ]
    504518            ((##sys#get x '##core#primitive))
     519            ((not (memq x e)) (##sys#alias-global-hook x #f)) ; only if global
    505520            (else x))))
    506521 
     
    514529       '() ) ))
    515530
    516   (define (walk x se dest)
     531  (define (walk x e se dest)
    517532    (cond ((symbol? x)
    518533           (cond ((keyword? x) `(quote ,x))
     
    521536                   'var
    522537                   "reference to variable `~s' possibly unintended" x) ))
    523            (resolve-variable x se dest))
     538           (resolve-variable x e se dest))
    524539          ((not-pair? x)
    525540           (if (constant? x)
     
    536551             (let* ((name0 (lookup (car x) se))
    537552                    (name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
    538                     (xexpanded (##sys#expand x se)))
     553                    (xexpanded (##sys#expand x se compiler-syntax-enabled)))
    539554               (cond ((not (eq? x xexpanded))
    540                       (walk xexpanded se dest))
     555                      (walk xexpanded e se dest))
    541556                     
    542557                     [(and inline-table-used (##sys#hash-table-ref inline-table name))
    543558                      => (lambda (val)
    544                            (walk (cons val (cdr x)) se dest)) ]
     559                           (walk (cons val (cdr x)) e se dest)) ]
    545560                     
    546561                     [else
     
    551566                         (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
    552567                         `(if
    553                            ,(walk (cadr x) se #f)
    554                            ,(walk (caddr x) se #f)
     568                           ,(walk (cadr x) e se #f)
     569                           ,(walk (caddr x) e se #f)
    555570                           ,(if (null? (cdddr x))
    556571                                '(##core#undefined)
    557                                 (walk (cadddr x) se #f) ) ) )
    558 
    559                         ((quote syntax)
     572                                (walk (cadddr x) e se #f) ) ) )
     573
     574                        ((quote syntax ##core#syntax)
    560575                         (##sys#check-syntax name x '(_ _) #f se)
    561576                         `(quote ,(##sys#strip-syntax (cadr x))))
     
    564579                         (if unsafe
    565580                             ''#t
    566                              (walk (cadr x) se dest) ) )
     581                             (walk (cadr x) e se dest) ) )
    567582
    568583                        ((##core#immutable)
     
    585600                         `(##core#inline_loc_ref
    586601                           ,(##sys#strip-syntax (cadr x))
    587                            ,(walk (caddr x) se dest)))
     602                           ,(walk (caddr x) e se dest)))
    588603
    589604                        ((##core#require-for-syntax)
     
    609624                                                           (##sys#find-extension
    610625                                                            (##sys#canonicalize-extension-path
    611                                                              id 'require-extension) #f)) ) )
     626                                                             id 'require-extension)
     627                                                            #f)) ) )
    612628                                        (compiler-warning
    613629                                         'ext "extension `~A' is currently not installed" id))
    614                                       `(begin ,exp ,(loop (cdr ids))) ) ) ) )
    615                             se dest) ) )
     630                                      `(##core#begin ,exp ,(loop (cdr ids))) ) ) ) )
     631                            e se dest) ) )
    616632
    617633                        ((let ##core#let)
     
    624640                           `(let
    625641                             ,(map (lambda (alias b)
    626                                      (list alias (walk (cadr b) se (car b))) )
     642                                     (list alias (walk (cadr b) e se (car b))) )
    627643                                   aliases bindings)
    628                              ,(walk (##sys#canonicalize-body (cddr x) se2)
     644                             ,(walk (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
     645                                    (append aliases e)
    629646                                    se2 dest) ) ) )
    630647
    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)))
     648                        ((letrec ##core#letrec)
     649                         (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
     650                         (let ((bindings (cadr x))
     651                               (body (cddr x)) )
     652                           (walk
     653                            `(##core#let
     654                              ,(map (lambda (b)
     655                                      (list (car b) '(##core#undefined)))
     656                                    bindings)
     657                              ,@(map (lambda (b)
     658                                       `(##core#set! ,(car b) ,(cadr b)))
     659                                     bindings)
     660                              (##core#let () ,@body) )
     661                            e se dest)))
    645662
    646663                        ((lambda ##core#lambda)
     
    658675                              (let* ((aliases (map gensym vars))
    659676                                     (se2 (append (map cons vars aliases) se))
    660                                      (body0 (##sys#canonicalize-body obody se2))
    661                                      (body (walk body0 se2 #f))
     677                                     (body0 (##sys#canonicalize-body obody se2 compiler-syntax-enabled))
     678                                     (body (walk body0 (append aliases e) se2 #f))
    662679                                     (llist2
    663680                                      (build-lambda-list
     
    702719                                     se) ) )
    703720                           (walk
    704                             (##sys#canonicalize-body (cddr x) se2)
    705                             se2
     721                            (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
     722                            e se2
    706723                            dest) ) )
    707724                               
     
    721738                           ms)
    722739                          (walk
    723                            (##sys#canonicalize-body (cddr x) se2)
    724                            se2 dest)))
     740                           (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
     741                           e se2 dest)))
    725742                               
    726                        ((define-syntax)
     743                       ((define-syntax define-compiled-syntax)
    727744                        (##sys#check-syntax
    728                          'define-syntax x
     745                         (car x) x
    729746                         (if (pair? (cadr x))
    730747                             '(_ (variable . lambda-list) . #(_ 1))
     
    733750                        (let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
    734751                               (body (if (pair? (cadr x))
    735                                          `(,(macro-alias 'lambda se) ,(cdadr x) ,@(cddr x))
     752                                         `(##core#lambda ,(cdadr x) ,@(cddr x))
    736753                                         (caddr x)))
    737754                               (name (lookup var se)))
     
    742759                           (##sys#er-transformer (eval/meta body)))
    743760                          (walk
    744                            (if ##sys#enable-runtime-macros
     761                           (if (or ##sys#enable-runtime-macros
     762                                   (eq? 'define-compiled-syntax (car x)))
    745763                               `(##sys#extend-macro-environment
    746764                                 ',var
     
    748766                                 (##sys#er-transformer ,body)) ;*** possibly wrong se?
    749767                               '(##core#undefined) )
    750                            se dest)) )
    751 
    752                        ((define-compiled-syntax)
    753                         (##sys#check-syntax
    754                          'define-compiled-syntax x
    755                          (if (pair? (cadr x))
    756                              '(_ (variable . lambda-list) . #(_ 1))
    757                              '(_ variable _) )
    758                          #f se)
    759                         (let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
    760                                (body (if (pair? (cadr x))
    761                                          `(,(macro-alias 'lambda se) ,(cdadr x) ,@(cddr x))
    762                                          (caddr x)))
    763                                (name (lookup var se)))
    764                           (##sys#extend-macro-environment
    765                            name
    766                            (##sys#current-environment)
    767                            (##sys#er-transformer (eval/meta body)))
    768                           (##sys#register-syntax-export name (##sys#current-module) body)
    769                           (walk
    770                            `(##sys#extend-macro-environment
    771                              ',var
    772                              (##sys#current-environment)
    773                              (##sys#er-transformer
    774                               ,body)) ;*** possibly wrong se?
    775                            se dest)))
    776 
    777                        ((##core#define-rewrite-rule)
    778                         (let ((name (##sys#strip-syntax (cadr x) se #t))
    779                               (re (caddr x)))
    780                           (##sys#put! name '##compiler#intrinsic 'rewrite)
    781                           (rewrite
    782                            name 8
    783                            (eval/meta re))
    784                           '(##core#undefined)))
     768                           e se dest)) )
     769
     770                       ((##core#define-compiler-syntax)
     771                        (let* ((var (cadr x))
     772                               (body (caddr x))
     773                               (name (##sys#strip-syntax var se #t)))
     774                          (##sys#put!
     775                           name '##compiler#compiler-syntax
     776                           (##sys#cons
     777                            (##sys#er-transformer (eval/meta body))
     778                            (##sys#current-environment)))
     779                          (walk
     780                           (if ##sys#enable-runtime-macros
     781                               `(##sys#put!
     782                                (##core#syntax ,name)
     783                                '##compiler#compiler-syntax
     784                                (##sys#cons
     785                                 (##sys#er-transformer ,body)
     786                                 (##sys#current-environment)))
     787                               '(##core#undefined) )
     788                           e se dest)))
     789
     790                       ((##core#let-compiler-syntax)
     791                        (let ((bs (map (lambda (b)
     792                                         (##sys#check-syntax 'let-compiler-syntax b '(symbol _))
     793                                         (let ((name (##sys#strip-syntax (car b) se #t)))
     794                                           (list
     795                                            name
     796                                            (cons (##sys#er-transformer (eval/meta (cadr b))) se)
     797                                            (##sys#get name '##compiler#compiler-syntax) ) ) )
     798                                       (cadr x))))
     799                          (dynamic-wind ; this ain't thread safe
     800                              (lambda ()
     801                                (for-each
     802                                 (lambda (b) (##sys#put! (car b) '##compiler#compiler-syntax (cadr b)))
     803                                 bs) )
     804                              (lambda ()
     805                                (walk
     806                                 (##sys#canonicalize-body (cddr x) se compiler-syntax-enabled)
     807                                 e se dest) )
     808                              (lambda ()
     809                                (for-each
     810                                 (lambda (b) (##sys#put! (car b) '##compiler#compiler-syntax (caddr b)))
     811                                 bs) ) ) ) )
    785812
    786813                       ((##core#module)
     
    811838                                              (cond
    812839                                               ((null? body)
    813                                                 (##sys#finalize-module (##sys#current-module))
     840                                                (handle-exceptions ex
     841                                                    (begin
     842                                                      ;; avoid backtrace
     843                                                      (print-error-message ex (current-error-port))
     844                                                      (exit 1))
     845                                                  (##sys#finalize-module (##sys#current-module)))
    814846                                                (cond ((assq name import-libraries) =>
    815847                                                       (lambda (il)
     
    850882                                                 (cons (walk
    851883                                                        (car body)
     884                                                        e ;?
    852885                                                        (##sys#current-environment)
    853886                                                        #f)
     
    859892                                (map
    860893                                 (lambda (x)
    861                                    (walk x (##sys#current-meta-environment) #f) )
     894                                   (walk
     895                                    x
     896                                    e   ;?
     897                                    (##sys#current-meta-environment) #f) )
    862898                                 mreg))
    863899                              body)))))
    864900
    865901                       ((##core#named-lambda)
    866                         (walk `(,(macro-alias 'lambda se) ,@(cddr x)) se (cadr x)) )
     902                        (walk `(##core#lambda ,@(cddr x)) e se (cadr x)) )
    867903
    868904                       ((##core#loop-lambda)
     
    873909                               [body
    874910                                (walk
    875                                  (##sys#canonicalize-body obody se2)
     911                                 (##sys#canonicalize-body obody se2 compiler-syntax-enabled)
     912                                 (append aliases e)
    876913                                 se2 #f) ] )
    877914                          (set-real-names! aliases vars)
    878                           `(lambda ,aliases ,body) ) )
     915                          `(##core#lambda ,aliases ,body) ) )
    879916
    880917                        ((set! ##core#set!)
     
    898935                                               (,(third fv) ,type)
    899936                                               ,(foreign-type-check tmp type) ) )
    900                                            se #f))))
     937                                           e se #f))))
    901938                                 ((assq var location-pointer-map)
    902939                                  => (lambda (a)
     
    909946                                              ,(second a)
    910947                                              ,(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))
     948                                          e se #f))))
     949                                 (else
     950                                  (unless (memq var e) ; global?
     951                                    (set! var (or (##sys#get var '##core#primitive)
     952                                                  (##sys#alias-global-hook var #t)))
    915953                                    (when safe-globals-flag
    916954                                      (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) ) ) )
     955                                      (mark-variable var '##compiler#always-bound)))
     956                                  (when (##sys#macro? var)
     957                                    (compiler-warning
     958                                     'var "assigned global variable `~S' is a macro ~A"
     959                                     var
     960                                     (if ln (sprintf "in line ~S" ln) "") )
     961                                    (when undefine-shadowed-macros (##sys#undefine-macro! var) ) )
    924962                                  (when (keyword? var)
    925963                                    (compiler-warning 'syntax "assignment to keyword `~S'" var) )
     
    927965                                    (syntax-error
    928966                                     'set! "assignment to syntactic identifier" var))
    929                                   `(set! ,var ,(walk val se var0))))))
     967                                  `(set! ,var ,(walk val e se var0))))))
    930968
    931969                        ((##core#inline)
    932                          `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) se)))
     970                         `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se)))
    933971
    934972                        ((##core#inline_allocate)
    935973                         `(##core#inline_allocate
    936974                           ,(map (cut unquotify <> se) (second x))
    937                            ,@(mapwalk (cddr x) se)))
     975                           ,@(mapwalk (cddr x) e se)))
    938976
    939977                        ((##core#inline_update)
    940                          `(##core#inline_update ,(cadr x) ,(walk (caddr x) se #f)) )
     978                         `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f)) )
    941979
    942980                        ((##core#inline_loc_update)
    943981                         `(##core#inline_loc_update
    944982                           ,(cadr x)
    945                            ,(walk (caddr x) se #f)
    946                            ,(walk (cadddr x) se #f)) )
     983                           ,(walk (caddr x) e se #f)
     984                           ,(walk (cadddr x) e se #f)) )
    947985
    948986                        ((##core#compiletimetoo ##core#elaborationtimetoo)
    949987                         (let ((exp (cadr x)))
    950988                           (eval/meta exp)
    951                            (walk exp se dest) ) )
     989                           (walk exp e se dest) ) )
    952990
    953991                        ((##core#compiletimeonly ##core#elaborationtimeonly)
     
    955993                         '(##core#undefined) )
    956994
    957                         ((begin)
    958                          (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
     995                        ((begin ##core#begin)
     996                         (##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
    959997                         (if (pair? (cdr x))
    960998                             (canonicalize-begin-body
     
    9631001                                      [r (cdr xs)] )
    9641002                                  (if (null? r)
    965                                       (list (walk x se dest))
    966                                       (cons (walk x se #f) (fold r)) ) ) ) )
     1003                                      (list (walk x e se dest))
     1004                                      (cons (walk x e se #f) (fold r)) ) ) ) )
    9671005                             '(##core#undefined) ) )
    9681006
    9691007                        ((foreign-lambda)
    970                          (walk (expand-foreign-lambda x) se dest) )
     1008                         (walk (expand-foreign-lambda x #f) e se dest) )
    9711009
    9721010                        ((foreign-safe-lambda)
    973                          (walk (expand-foreign-callback-lambda x) se dest) )
     1011                         (walk (expand-foreign-lambda x #t) e se dest) )
    9741012
    9751013                        ((foreign-lambda*)
    976                          (walk (expand-foreign-lambda* x) se dest) )
     1014                         (walk (expand-foreign-lambda* x #f) e se dest) )
    9771015
    9781016                        ((foreign-safe-lambda*)
    979                          (walk (expand-foreign-callback-lambda* x) se dest) )
     1017                         (walk (expand-foreign-lambda* x #t) e se dest) )
    9801018
    9811019                        ((foreign-primitive)
    982                          (walk (expand-foreign-primitive x) se dest) )
     1020                         (walk (expand-foreign-primitive x) e se dest) )
    9831021
    9841022                        ((define-foreign-variable)
    9851023                         (let* ([var (##sys#strip-syntax (second x))]
    986                                 [type (third x)]
     1024                                [type (##sys#strip-syntax (third x))]
    9871025                                [name (if (pair? (cdddr x))
    9881026                                          (fourth x)
     
    9981036                        ((define-foreign-type)
    9991037                         (let ([name (second x)]
    1000                                [type (third x)]
     1038                               [type (##sys#strip-syntax (third x))]
    10011039                               [conv (cdddr x)] )
    10021040                           (cond [(pair? conv)
     
    10091047                                    (hide-variable ret)
    10101048                                    (walk
    1011                                      `(,(macro-alias 'begin se)
     1049                                     `(##core#begin
    10121050                                        (define ,arg ,(first conv))
    10131051                                        (define
    10141052                                         ,ret
    10151053                                         ,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
    1016                                      se dest) ) ]
     1054                                     e se dest) ) ]
    10171055                                 [else
    10181056                                  (##sys#hash-table-set! foreign-type-table name type)
     
    10351073                        ((##core#let-location)
    10361074                         (let* ([var (second x)]
    1037                                 [type (third x)]
     1075                                [type (##sys#strip-syntax (third x))]
    10381076                                [alias (gensym)]
    10391077                                [store (gensym)]
     
    10511089                                         ("C_a_i_bytevector" ,(+ 2 size))
    10521090                                         ',size)) ) )
    1053                                (,(macro-alias 'begin se)
     1091                               (##core#begin
    10541092                                ,@(if init
    10551093                                      `((##core#set! ,alias ,init))
    10561094                                      '() )
    10571095                                ,(if init (fifth x) (fourth x)) ) )
    1058                             (alist-cons var alias se)
     1096                            e (alist-cons var alias se)
    10591097                            dest) ) )
    10601098
     
    10761114                                           valexp
    10771115                                           (eval
    1078                                             `(,(macro-alias 'let se)
     1116                                            `(##core#let
    10791117                                              ,defconstant-bindings ,valexp)) ) ) ] )
    10801118                           (set! constants-used #t)
     
    10891127                                    (mark-variable var '##compiler#constant)
    10901128                                    (mark-variable var '##compiler#always-bound)
    1091                                     (walk `(define ,var ',val) se #f) ) ] ) ) )
     1129                                    (walk `(define ,var ',val) e se #f) ) ] ) ) )
    10921130
    10931131                        ((##core#declare)
    10941132                         (walk
    1095                           `(,(macro-alias 'begin se)
     1133                          `(##core#begin
    10961134                             ,@(map (lambda (d)
    10971135                                      (process-declaration d se))
    10981136                                    (cdr x) ) )
    1099                           '() #f) )
     1137                          e '() #f) )
    11001138             
    11011139                        ((##core#foreign-callback-wrapper)
     
    11171155                                vars atypes) )
    11181156                             `(##core#foreign-callback-wrapper
    1119                                ,@(mapwalk args se)
     1157                               ,@(mapwalk args e se)
    11201158                               ,(walk `(##core#lambda
    11211159                                        ,vars
    1122                                         (,(macro-alias 'let se)
     1160                                        (##core#let
    11231161                                         ,(let loop ([vars vars] [types atypes])
    11241162                                            (if (null? vars)
     
    11341172                                                   (loop (cdr vars) (cdr types)) ) ) ) )
    11351173                                         ,(foreign-type-convert-argument
    1136                                            `(,(macro-alias 'let se)
     1174                                           `(##core#let
    11371175                                             ()
    11381176                                             ,@(cond
     
    11441182                                                    nonnull-c-string))
    11451183                                                 `((##sys#make-c-string
    1146                                                     (,(macro-alias 'let se)
     1184                                                    (##core#let
    11471185                                                     () ,@(cddr lam)))))
    11481186                                                ((member
     
    11641202                                                    unsigned-c-string
    11651203                                                    (const c-string)) )
    1166                                                  `((,(macro-alias 'let se)
    1167                                                     ((r (,(macro-alias 'let se)
    1168                                                          () ,@(cddr lam))))
     1204                                                 `((##core#let
     1205                                                    ((r (##core#let () ,@(cddr lam))))
    11691206                                                    (,(macro-alias 'and se)
    11701207                                                     r
     
    11721209                                                (else (cddr lam)) ) )
    11731210                                           rtype) ) )
    1174                                       se #f) ) ) ) )
     1211                                      e se #f) ) ) ) )
    11751212
    11761213                        (else
    11771214                         (let ([handle-call
    11781215                                (lambda ()
    1179                                   (let* ([x2 (mapwalk x se)]
     1216                                  (let* ([x2 (mapwalk x e se)]
    11801217                                         [head2 (car x2)]
    11811218                                         [old (##sys#hash-table-ref line-number-database-2 head2)] )
     
    11951232                                                    (walk
    11961233                                                     `(##sys#make-locative ,(second a) 0 #f 'location)
    1197                                                      se #f) ) ]
     1234                                                     e se #f) ) ]
    11981235                                              [(assq sym external-to-pointer)
    1199                                                => (lambda (a) (walk (cdr a) se #f)) ]
     1236                                               => (lambda (a) (walk (cdr a) e se #f)) ]
    12001237                                              [(memq sym callback-names)
    12011238                                               `(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
    12021239                                              [else
    1203                                                (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ] )
    1204                                         (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ) ) ]
     1240                                               (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ] )
     1241                                        (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ) ) ]
    12051242                                 
    12061243                                 [else (handle-call)] ) ) ) ) ] ) ) ) )
     
    12121249           (emit-syntax-trace-info x #f)
    12131250           (compiler-warning 'syntax "literal in operator position: ~S" x)
    1214            (mapwalk x se) )
    1215 
    1216           ((and (pair? (car x))
    1217                 (symbol? (caar x))
    1218                 (memq (or (lookup (caar x) se) (caar x)) '(lambda ##core#lambda)))
    1219            (let ([lexp (car x)]
    1220                  [args (cdr x)] )
    1221              (emit-syntax-trace-info x #f)
    1222              (##sys#check-syntax 'lambda lexp '(_ lambda-list . #(_ 1)) #f se)
    1223              (let ([llist (cadr lexp)])
    1224                (if (and (proper-list? llist) (= (llist-length llist) (length args)))
    1225                    (walk `(,(macro-alias 'let se)
    1226                            ,(map list llist args) ,@(cddr lexp)) se dest)
    1227                    (let ((var (gensym 't)))
    1228                      (walk
    1229                       `(,(macro-alias 'let se)
    1230                         ((,var ,(car x)))
    1231                         (,var ,@(cdr x)) )
    1232                       se dest) ) ) ) ) )
    1233          
     1251           (mapwalk x e se) )
     1252
    12341253          (else
    12351254           (emit-syntax-trace-info x #f)
    1236            (mapwalk x se)) ) )
     1255           (let ((x (mapwalk x e se)))
     1256             (if (and (pair? (car x))
     1257                      (symbol? (caar x))
     1258                      (memq (or (lookup (caar x) se) (caar x)) '(lambda ##core#lambda)))
     1259                 (let ((lexp (car x))
     1260                       (args (cdr x)) )
     1261                   (##sys#check-syntax 'lambda lexp '(_ lambda-list . #(_ 1)) #f se)
     1262                   (let ((llist (cadr lexp)))
     1263                     (if (and (proper-list? llist) (= (llist-length llist) (length args)))
     1264                         `(let ,(map list llist args) ,@(cddr lexp))
     1265                         (let ((var (gensym 't)))
     1266                           `(let ((,var ,(car x)))
     1267                             (,var ,@(cdr x)) ) ) ) ) )
     1268                 x))) ) )
    12371269 
    1238   (define (mapwalk xs se)
    1239     (map (lambda (x) (walk x se #f)) xs) )
     1270  (define (mapwalk xs e se)
     1271    (map (lambda (x) (walk x e se #f)) xs) )
    12401272
    12411273  (when (memq 'c debugging-chicken) (newline) (pretty-print exp))
     
    12431275  ;; Process visited definitions and main expression:
    12441276  (walk
    1245    `(,(macro-alias 'begin '())
    1246       ,@(let ([p (reverse pending-canonicalizations)])
    1247           (set! pending-canonicalizations '())
    1248           p)
    1249       ,(begin
    1250          (set! extended-bindings (append internal-bindings extended-bindings))
    1251          exp) )
    1252    (##sys#current-environment)
     1277   `(##core#begin
     1278     ,@(let ([p (reverse pending-canonicalizations)])
     1279         (set! pending-canonicalizations '())
     1280         p)
     1281     ,(begin
     1282        (set! extended-bindings (append internal-bindings extended-bindings))
     1283        exp) )
     1284   '() (##sys#current-environment)
    12531285   #f) )
    12541286
     
    13791411                    (set! extended-bindings (lset-difference eq? default-extended-bindings syms)) ) ] ) ]
    13801412          ((inline-global)
     1413           (set! enable-inline-files #t)
    13811414           (if (null? (cddr spec))
    13821415               (set! inline-globally #f)
     
    14571490                (stripa (cdr spec))))))
    14581491       ((inline-global)
     1492        (set! enable-inline-files #t)
     1493        (set! inline-locally #t)
    14591494        (if (null? (cdr spec))
    14601495            (set! inline-globally #t)
     
    14621497             (cut mark-variable <> '##compiler#inline-global 'yes)
    14631498             (stripa (cdr spec)))))
     1499       ((type)
     1500        (for-each
     1501         (lambda (spec)
     1502           (cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
     1503                  (##sys#put! (car spec) '##core#type (cadr spec))
     1504                  (##sys#put! (car spec) '##core#declared-type #t))
     1505                 (else
     1506                  (compiler-warning 'syntax "illegal `type' declaration item `~s'" spec))))
     1507         (cdr spec)))
     1508       ((scrutinize)
     1509        (set! do-scrutinize #t))
    14641510       (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) )
    14651511     '(##core#undefined) ) ) )
     
    14811527
    14821528(define (create-foreign-stub rtype sname argtypes argnames body callback cps)
    1483   (let* ([params (list-tabulate (length argtypes) (lambda (x) (gensym 'a)))]
     1529  (let* ((rtype (##sys#strip-syntax rtype))
     1530         (argtypes (##sys#strip-syntax argtypes))
     1531         [params (list-tabulate (length argtypes) (lambda (x) (gensym 'a)))]
    14841532         [f-id (gensym 'stub)]
    14851533         [bufvar (gensym)]
     
    15061554                     rtype) ) ) ) ) ) ) )
    15071555
    1508 (define (expand-foreign-lambda exp)
     1556(define (expand-foreign-lambda exp callback?)
    15091557  (let* ([name (third exp)]
    1510          [sname (cond ((symbol? name) (symbol->string name))
     1558         [sname (cond ((symbol? name) (symbol->string (##sys#strip-syntax name)))
    15111559                      ((string? name) name)
    15121560                      (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
    15131561         [rtype (second exp)]
    15141562         [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)
     1563    (create-foreign-stub rtype sname argtypes #f #f callback? callback?) ) )
     1564
     1565(define (expand-foreign-lambda* exp callback?)
    15271566  (let* ([rtype (second exp)]
    15281567         [args (third exp)]
    15291568         [body (apply string-append (cdddr exp))]
    15301569         [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 
     1570         ;; C identifiers aren't hygienically renamed inside body strings
     1571         [argnames (map cadr (##sys#strip-syntax args))] )
     1572    (create-foreign-stub rtype #f argtypes argnames body callback? callback?) ) )
     1573
     1574;; TODO: Try to fold this procedure into expand-foreign-lambda*
    15421575(define (expand-foreign-primitive exp)
    15431576  (let* ([hasrtype (and (pair? (cddr exp)) (not (string? (caddr exp))))]
    15441577         [rtype (if hasrtype (second exp) 'void)]
    1545          [args (if hasrtype (third exp) (second exp))]
     1578         [args (##sys#strip-syntax (if hasrtype (third exp) (second exp)))]
    15461579         [body (apply string-append (if hasrtype (cdddr exp) (cddr exp)))]
    15471580         [argtypes (map car args)]
    1548          [argnames (map cadr args)] )
     1581         ;; C identifiers aren't hygienically renamed inside body strings
     1582         [argnames (map cadr (##sys#strip-syntax args))] )
    15491583    (create-foreign-stub rtype #f argtypes argnames body #f #t) ) )
    15501584
     
    18741908                 (any (lambda (id2) (contains? id2 other-ids)) clist) ) ) ) )
    18751909
    1876     ;; Initialize database:
    1877     (initialize-analysis-database db)
    1878 
    18791910    ;; Walk toplevel expression-node:
    18801911    (debugging 'p "analysis traversal phase...")
  • chicken/branches/release/csc.scm

    r13859 r15293  
    6969  (exit 64) )
    7070
    71 (define chicken-prefix (getenv "CHICKEN_PREFIX"))
     71(define chicken-prefix (get-environment-variable "CHICKEN_PREFIX"))
    7272(define arguments (command-line-arguments))
    7373(define host-mode (member "-host" arguments))
     
    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 -no-compiler-syntax
     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
     
    312315    -j -emit-import-library MODULE write compile-time module information into
    313316                                    separate file
     317    -no-compiler-syntax            disable expansion of compiler-macros
    314318
    315319  Translation options:
     
    332336    -profile-name FILENAME         name of the generated profile information
    333337                                    file
     338    -S  -scrutinize                perform local flow analysis
     339    -types FILENAME                load additional type database
    334340
    335341  Optimization options:
     
    356362    -n -emit-inline-file FILENAME  generate file with globally inlinable
    357363                                    procedures (implies -inline -local)
     364    -consult-inline-file FILENAME  explicitly load inline file
     365    -no-argc-checks                disable argument count checks
     366    -no-bound-checks               disable bound variable checks
     367    -no-procedure-checks           disable procedure call checks
     368    -no-procedure-checks-for-usual-bindings
     369                                   disable procedure call checks only for usual
     370                                    bindings
    358371
    359372  Configuration options:
     
    380393    -R  -require-extension NAME    require extension and import in compiled
    381394                                    code
    382     -E  -extension                 compile as extension (dynamic or static)
    383395    -dll -library                  compile multiple units into a dynamic
    384396                                    library
     
    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)
     
    919937;;; Run it:
    920938
    921 (run (append (string-split (or (getenv "CSC_OPTIONS") "")) arguments))
     939(run (append (string-split (or (get-environment-variable "CSC_OPTIONS") "")) arguments))
  • chicken/branches/release/csi.scm

    r13859 r15293  
    190190                (else (loop (fx+ i 1))) ) ) ) )
    191191    (lambda (name)
    192       (let ([path (getenv "PATH")])
     192      (let ([path (get-environment-variable "PATH")])
    193193        (and (> (##sys#size name) 0)
    194194             (cond [(dirseparator? (string-ref name 0)) (addext name)]
     
    648648             (fprintf out "exact integer ~S, #x~X, #o~O, #b~B" x x x x)
    649649             (let ([code (integer->char x)])
    650                (when (fx< code #x10000) (fprintf out ", character ~S" code)) )
     650               (when (fx< x #x10000) (fprintf out ", character ~S" code)) )
    651651             (##sys#write-char-0 #\newline ##sys#standard-output) ]
    652652            [(eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))
     
    845845        '()
    846846        (let ((x (car args)))
    847           (cond ((member x '("-s" "-ss" "-script" "--")) args)
     847          (cond ((member x '("-s" "-ss" "-script" "-sx" "--")) args)
    848848                ((and (fx> (##sys#size x) 2)
    849849                       (char=? #\- (##core#inline "C_subchar" x 0))
     
    873873
    874874(define (run)
    875   (let* ([extraopts (parse-option-string (or (getenv "CSI_OPTIONS") ""))]
     875  (let* ([extraopts (parse-option-string (or (get-environment-variable "CSI_OPTIONS") ""))]
    876876         [args (canonicalize-args (command-line-arguments))]
    877877         ; Check for these before 'args' is updated by any 'extraopts'
     
    898898           [quietflag (member* '("-q" "-quiet") args)]
    899899           [quiet (or script quietflag eval?)]
    900            [ipath (map chop-separator (string-split (or (getenv "CHICKEN_INCLUDE_PATH") "") ";"))] )     
     900           [ipath (map chop-separator (string-split (or (get-environment-variable "CHICKEN_INCLUDE_PATH") "") ";"))] )     
    901901      (define (collect-options opt)
    902902        (let loop ([opts args])
     
    911911          (if (file-exists? fn)
    912912              (load fn)
    913               (let* ([prefix (chop-separator (or (getenv "HOME") "."))]
     913              (let* ([prefix (chop-separator (or (get-environment-variable "HOME") "."))]
    914914                     [fn (string-append prefix "/" init-file)] )
    915915                (when (file-exists? fn)
  • chicken/branches/release/defaults.make

    r13859 r15293  
    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
    285 CHICKEN_OPTIONS += -feature debugbuild
     284CHICKEN_OPTIONS += -feature debugbuild -scrutinize -types $(SRCDIR)types.db
    286285endif
    287286CHICKEN_LIBRARY_OPTIONS = $(CHICKEN_OPTIONS) -explicit-use
     
    299298CHICKEN_PROFILE_PROGRAM = $(PROGRAM_PREFIX)chicken-profile$(PROGRAM_SUFFIX)
    300299CHICKEN_INSTALL_PROGRAM = $(PROGRAM_PREFIX)chicken-install$(PROGRAM_SUFFIX)
     300CHICKEN_SETUP_PROGRAM = $(PROGRAM_PREFIX)chicken-setup$(PROGRAM_SUFFIX)
    301301CHICKEN_UNINSTALL_PROGRAM = $(PROGRAM_PREFIX)chicken-uninstall$(PROGRAM_SUFFIX)
    302302CHICKEN_STATUS_PROGRAM = $(PROGRAM_PREFIX)chicken-status$(PROGRAM_SUFFIX)
    303303CHICKEN_BUG_PROGRAM = $(PROGRAM_PREFIX)chicken-bug$(PROGRAM_SUFFIX)
    304304IMPORT_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
     305        regex srfi-14 tcp foreign scheme srfi-18 utils csi irregex
    306306IMPORT_LIBRARIES += setup-api setup-download
     307SCRUTINIZED_LIBRARIES = library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
     308       srfi-14 srfi-18 srfi-69 $(POSIXFILE) regex scheduler \
     309       profiler stub expand chicken-syntax
    307310
    308311ifdef STATICBUILD
     
    326329        $(CSI_SHARED_EXECUTABLE) $(CHICKEN_PROFILE_PROGRAM)$(EXE) \
    327330        $(CSC_PROGRAM)$(EXE) $(CHICKEN_INSTALL_PROGRAM)$(EXE) $(CHICKEN_UNINSTALL_PROGRAM)$(EXE) \
     331        $(CHICKEN_SETUP_PROGRAM)$(EXE) \
    328332        $(CHICKEN_STATUS_PROGRAM)$(EXE) setup-download.so setup-api.so \
    329333        $(CHICKEN_BUG_PROGRAM)$(EXE) \
  • chicken/branches/release/distribution/manifest

    r13859 r15293  
    6464lolevel.c
    6565optimizer.c
     66scrutinizer.c
    6667regex.c
    6768posixunix.c
     
    178179lolevel.scm
    179180optimizer.scm
     181scrutinizer.scm
    180182regex.scm
    181183irregex.scm
     
    216218tests/test-finalizers-2.scm
    217219tests/module-tests-compiled.scm
     220tests/scrutiny-tests.scm
     221tests/scrutiny.expected
    218222tests/syntax-tests.scm
    219223tests/syntax-tests-2.scm
     
    233237tests/lolevel-tests.scm
    234238tests/feeley-dynwind.scm
     239tests/compiler-syntax-tests.scm
    235240tweaks.scm
    236241utils.scm
     
    250255Makefile.cygwin
    251256Makefile.cross-linux-mingw
    252 Makefile.msvc
    253257rules.make
    254258defaults.make
    255259private-namespace.scm
    256260scripts/scheme
     261scripts/tools.scm
     262scripts/test-dist.sh
     263scripts/wiki2html.scm
     264scripts/make-egg-index.scm
     265scripts/makedist.scm
     266scripts/README
     267scripts/henrietta.scm
     268scripts/henrietta.cgi
    257269svnrevision.sh
    258270synrules.scm
     
    310322chicken-install.scm
    311323chicken-install.c
     324chicken-setup.scm
     325chicken-setup.c
    312326chicken-uninstall.scm
    313327chicken-uninstall.c
     
    320334setup-api.import.c
    321335setup-download.import.c
     336types.db
  • chicken/branches/release/eval.scm

    r13859 r15293  
    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#>
     
    7874     ##sys#repl-eval-hook ##sys#append ##sys#eval-decorator
    7975     open-output-string get-output-string make-parameter software-type software-version machine-type
    80      build-platform getenv set-extensions-specifier! ##sys#string->symbol list->vector
     76     build-platform set-extensions-specifier! ##sys#string->symbol list->vector get-environment-variable
    8177     extension-information syntax-error ->string chicken-home ##sys#expand-curried-define
    8278     vector->list store-string open-input-string eval ##sys#gc
     
    131127
    132128(define ##sys#chicken-prefix
    133   (let ((prefix (and-let* ((p (getenv prefix-environment-variable)))
     129  (let ((prefix (and-let* ((p (get-environment-variable prefix-environment-variable)))
    134130                  (##sys#string-append
    135131                   p
     
    331327              [(symbol? (##sys#slot x 0))
    332328               (emit-syntax-trace-info tf x cntr)
    333                (let ((x2 (##sys#expand x se)))
     329               (let ((x2 (##sys#expand x se #f)))
    334330                 (d `(EVAL/EXPANDED: ,x2))
    335331                 (if (not (eq? x2 x))
     
    353349                              [else (lambda v c)] ) ) ]
    354350
    355                          ((syntax)
     351                         ((syntax ##core#syntax)
    356352                          (let ((c (cadr x)))
    357353                            (lambda v c)))
     
    381377                            (lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
    382378
    383                          [(begin)
    384                           (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
     379                         [(begin ##core#begin)
     380                          (##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
    385381                          (let* ([body (##sys#slot x 1)]
    386382                                 [len (length body)] )
     
    394390                               (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
    395391                                      [x2 (compile (cadr body) e #f tf cntr se)]
    396                                       [x3 (compile `(,(rename 'begin se) ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se)] )
     392                                      [x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se)] )
    397393                                 (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ] ) ) ]
    398394
     
    430426                                 (se2 (append (map cons vars aliases) se))
    431427                                 [body (##sys#compile-to-closure
    432                                         (##sys#canonicalize-body (cddr x) se2)
     428                                        (##sys#canonicalize-body (cddr x) se2 #f)
    433429                                        e2
    434430                                        se2
     
    506502                                      (body
    507503                                       (##sys#compile-to-closure
    508                                         (##sys#canonicalize-body body se2)
     504                                        (##sys#canonicalize-body body se2 #f)
    509505                                        e2
    510506                                        se2
     
    595591                                      se) ) )
    596592                            (compile
    597                              (##sys#canonicalize-body (cddr x) se2)
     593                             (##sys#canonicalize-body (cddr x) se2 #f)
    598594                             e #f tf cntr se2)))
    599595                               
     
    613609                             ms)
    614610                            (compile
    615                              (##sys#canonicalize-body (cddr x) se2)
     611                             (##sys#canonicalize-body (cddr x) se2 #f)
    616612                             e #f tf cntr se2)))
    617613                               
     
    636632                             (##sys#er-transformer (eval/meta body)))
    637633                            (compile '(##core#undefined) e #f tf cntr se) ) )
     634
     635                         ((##core#define-compiler-syntax)
     636                          (compile '(##core#undefined) e #f tf cntr se))
     637
     638                         ((##core#let-compiler-syntax)
     639                          (compile
     640                           (##sys#canonicalize-body (cddr x) se #f)
     641                           e #f tf cntr se))
    638642
    639643                         ((##core#module)
     
    708712                                   (let-values ([(exp _)
    709713                                                 (##sys#do-the-right-thing (car ids) #f imp?)])
    710                                      `(,(rename 'begin se) ,exp ,(loop (cdr ids))) ) ) )
     714                                     `(##core#begin ,exp ,(loop (cdr ids))) ) ) )
    711715                             e #f tf cntr se) ) ]
    712716
     
    882886      [display display]
    883887      [newline newline]
     888      (flush-output flush-output)
    884889      [eval eval]
    885890      [open-input-file open-input-file]
     
    925930               (display "; loading ")
    926931               (display fname)
    927                (display " ...\n") ] )
     932               (display " ...\n")
     933               (flush-output)] )
    928934        (or (and fname
    929935                 (or (##sys#dload (##sys#make-c-string fname) topentry #t)
     
    10811087(define ##sys#repository-path
    10821088  (make-parameter
    1083    (or (getenv repository-environment-variable)
     1089   (or (get-environment-variable repository-environment-variable)
    10841090       (##sys#chicken-prefix
    10851091        (##sys#string-append
     
    10911097
    10921098(define ##sys#find-extension
    1093   (let ([file-exists? file-exists?]
    1094         [string-append string-append] )
     1099  (let ((file-exists? file-exists?)
     1100        (string-append string-append) )
    10951101    (lambda (p inc?)
    10961102      (let ((rp (##sys#repository-path)))
    10971103        (define (check path)
    1098           (let ([p0 (string-append path "/" p)])
     1104          (let ((p0 (string-append path "/" p)))
    10991105            (and (or (and rp
    11001106                          (not ##sys#dload-disabled)
     
    11031109                     (file-exists? (##sys#string-append p0 source-file-extension)) )
    11041110                 p0) ) )
    1105           (let loop ([paths (##sys#append
    1106                              (if rp (list rp) '("."))
    1107                              (if inc? (##sys#append ##sys#include-pathnames '(".")) '()) ) ] )
     1111          (let loop ((paths (##sys#append
     1112                             (if rp (list rp) '())
     1113                             (if inc? ##sys#include-pathnames '())
     1114                             '("."))) )
    11081115            (and (pair? paths)
    1109                  (let ([pa (##sys#slot paths 0)])
     1116                 (let ((pa (##sys#slot paths 0)))
    11101117                   (or (check pa)
    11111118                       (loop (##sys#slot paths 1)) ) ) ) ) ) ) ))
     
    11961203           (lambda () (list id)))))
    11971204      (define (impform x id builtin?)
    1198         `(begin
     1205        `(##core#begin
    11991206           ,x
    12001207           ,@(if (and imp? (or (not builtin?) (##sys#current-module)))
    1201                  `((import ,id))
     1208                 `((import ,id))        ;XXX make hygienic
    12021209                 '())))
    12031210      (define (doit id)
     
    12121219                 (if comp?
    12131220                     `(##core#declare (uses ,id))
    1214                      `(load-library ',id) )
     1221                     `(##sys#load-library ',id #f) )
    12151222                 id #t)
    12161223                #t) )
     
    12191226                      (s (assq 'syntax info)))
    12201227                 (values
    1221                   `(begin
     1228                  `(##core#begin
    12221229                     ,@(if s `((##core#require-for-syntax ',id)) '())
    12231230                     ,(impform
    12241231                       (if comp?
    12251232                           `(##core#declare (uses ,id))
    1226                            `(load-library ',id) )
     1233                           `(##sys#load-library ',id #f) )
    12271234                       id #f))
    12281235                  #t) ) )
     
    12351242                          (values
    12361243                           (impform
    1237                             `(begin
     1244                            `(##core#begin
    12381245                               ,@(if s `((##core#require-for-syntax ',id)) '())
    12391246                               ,@(if (and (not rr) s)
     
    12621269                                    (f #f) )
    12631270                           (if (null? specs)
    1264                                (values `(begin ,@(reverse exps)) f)
     1271                               (values `(##core#begin ,@(reverse exps)) f)
    12651272                               (let-values (((exp fi) (##sys#do-the-right-thing (car specs) comp? imp?)))
    12661273                                 (loop (cdr specs)
     
    13121319           ((number? x) (##sys#number->string x))
    13131320           (else (error "invalid extension version" x)) ) )
    1314    (if (and (list spec) (fx= 3 (length spec)))
     1321   (if (and (list? spec) (fx= 3 (length spec)))
    13151322       (let* ((info (extension-information (cadr spec)))
    13161323              (vv (and info (assq 'version info))) )
     
    16341641                                     (##sys#write-char-0 #\) ##sys#standard-error) )
    16351642                                   (##sys#write-char-0 #\newline ##sys#standard-error) )
    1636                                  u) ) )
     1643                                 u)
     1644                                (##sys#flush-output ##sys#standard-error)))
    16371645                             ((or (memq (caar vars) u)
    16381646                                  (##sys#symbol-has-toplevel-binding? (caar vars)) )
  • chicken/branches/release/expand.scm

    r13859 r15293  
    3131  (hide match-expression
    3232        macro-alias module-indirect-exports
    33         d dd dm map-se merge-se
     33        d dd dm dc map-se merge-se
    3434        lookup check-for-redef) )
    3535
     
    4646(define dd d)
    4747(define dm d)
     48(define dc d)
    4849
    4950(cond-expand
     
    5152  (declare
    5253    (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)))))
     54    (no-procedure-checks)))
    6455 (else))
     56
     57(begin
     58  (define-syntax dd (syntax-rules () ((_ . _) (void))))
     59  (define-syntax dm (syntax-rules () ((_ . _) (void))))
     60  (define-syntax dc (syntax-rules () ((_ . _) (void)))) )
    6561
    6662
     
    9288        alias) ) )
    9389
     90#+debugbuild
    9491(define (map-se se)
    9592  (map (lambda (a)
     
    9895
    9996(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))))
     97 ;; if se is given, retain bound vars
     98 (let ((seen '()))
     99   (let walk ((x exp))
     100     (cond ((assq x seen) => cdr)
     101           ((symbol? x)
     102            (let ((x2 (if se
     103                          (lookup x se)
     104                          (get x '##core#macro-alias) ) ) )
     105              (cond ((get x '##core#real-name))
     106                    ((and alias (not (assq x se)))
     107                     (##sys#alias-global-hook x #f))
     108                    ((not x2) x)
     109                    ((pair? x2) x)
     110                    (else x2))))
     111           ((pair? x)
     112            (let ((cell (cons #f #f)))
     113              (set! seen (cons (cons x cell) seen))
     114              (set-car! cell (walk (car x)))
     115              (set-cdr! cell (walk (cdr x)))
     116              cell))
     117           ((vector? x)
     118            (let* ((len (##sys#size x))
     119                   (vec (make-vector len)))
     120              (set! seen (cons (cons x vec) seen))
     121              (do ((i 0 (fx+ i 1)))
     122                  ((fx>= i len) vec)
     123                (##sys#setslot vec i (##sys#slot x i)))))
     124           (else x)))))
    118125
    119126(define strip-syntax ##sys#strip-syntax)
     
    224231;; The basic macro-expander
    225232
    226 (define (##sys#expand-0 exp dse)
    227   (define (call-handler name handler exp se)
     233(define (##sys#expand-0 exp dse cs?)
     234  (define (call-handler name handler exp se cs)
    228235    (dd "invoking macro: " name)
    229236    (dd `(STATIC-SE: ,@(map-se se)))
     
    255262                          (copy r) ) ) ) ) )
    256263             ex) )
    257       (let ((exp2 (handler exp se dse)))
     264      (let ((exp2
     265             (if cs
     266                 (fluid-let ((##sys#syntax-rules-mismatch (lambda (input) exp))) ; a bit of a hack
     267                   (handler exp se dse))
     268                 (handler exp se dse))) )
     269        (when (and (not cs) (eq? exp exp2))
     270          (##sys#syntax-error-hook
     271           (string-append
     272            "syntax transformer for `" (symbol->string name)
     273            "' returns original form, which would result in endless expansion")
     274           exp))
    258275        (dd `(,name --> ,exp2))
    259276        exp2)))
     
    273290           (values
    274291            ;; force ref. opaqueness by passing dynamic se  [what is this comment meaning? I forgot]
    275             (call-handler head (cadr mdef) exp (car mdef))
     292            (call-handler head (cadr mdef) exp (car mdef) #f)
    276293            #t))
    277294          (else (values exp #f)) ) )
    278   (if (pair? exp)
     295  (let loop ((exp exp))
     296    (if (pair? exp)
    279297      (let ((head (car exp))
    280298            (body (cdr exp)) )
     
    286304                     (##sys#check-syntax 'let body '#(_ 2) #f dse)
    287305                     (let ([bindings (car body)])
    288                        (cond [(symbol? bindings)
     306                       (cond [(symbol? bindings) ; expand named let
    289307                              (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)
    290308                              (let ([bs (cadr body)])
     
    297315                                 #t) ) ]
    298316                             [else (values exp #f)] ) ) ]
    299                     [(and (memq head2 '(set! ##core#set!))
     317                    [(and (memq head2 '(set! ##core#set!)) ; "setter" syntax
    300318                          (pair? body)
    301319                          (pair? (car body)) )
     
    307325                                (cdr body) )
    308326                        #t) ) ]
     327                    ((and cs? (symbol? head2) (##sys#get head2 '##compiler#compiler-syntax)) =>
     328                     (lambda (cs)
     329                       (let ((result (call-handler head (car cs) exp (cdr cs) #t)))
     330                         (cond ((eq? result exp) (expand head exp head2))
     331                               (else
     332                                (when ##sys#compiler-syntax-hook
     333                                  (##sys#compiler-syntax-hook head result))
     334                                (loop result))))))
    309335                    [else (expand head exp head2)] ) )
    310336            (values exp #f) ) )
    311       (values exp #f) ) )
    312 
     337      (values exp #f) ) ) )
     338
     339(define ##sys#compiler-syntax-hook #f)
    313340(define ##sys#enable-runtime-macros #f)
    314341
     
    324351    (cond ((##sys#current-module) =>
    325352           (lambda (mod)
    326              (dm "(ALIAS) global alias " sym " -> " (module-name mod))
     353             (dm "(ALIAS) global alias " sym " in " (module-name mod))
    327354             (unless assign (##sys#register-undefined sym mod))
    328355             (##sys#module-rename sym (module-name mod))))
     
    348375;;; User-level macroexpansion
    349376
    350 (define (##sys#expand exp #!optional (se (##sys#current-environment)))
     377(define (##sys#expand exp #!optional (se (##sys#current-environment)) cs?)
    351378  (let loop ((exp exp))
    352     (let-values (((exp2 m) (##sys#expand-0 exp se)))
     379    (let-values (((exp2 m) (##sys#expand-0 exp se cs?)))
    353380      (if m
    354381          (loop exp2)
     
    391418            (%let-optionals* (macro-alias 'let-optionals* se))
    392419            (%let (macro-alias 'let se)))
    393         (let loop ([mode 0]             ; req, opt, rest, key, end
     420        (let loop ([mode 0]             ; req=0, opt=1, rest=2, key=3, end=4
    394421                   [req '()]
    395422                   [opt '()]
     
    428455                     (err "rest argument list specified more than once")
    429456                     (begin
    430                        (if (not rvar) (set! rvar llist))
     457                       (unless rvar (set! rvar llist))
    431458                       (set! hasrest llist)
    432459                       (loop 4 req opt '() '()) ) ) ]
     
    435462                [else
    436463                 (let* ((var (car llist))
    437                         (x (or (and (symbol? var) (lookup var se)) var))
     464                        (x (or (and (symbol? var) (not (eq? 3 mode)) (lookup var se)) var))
    438465                        (r (cdr llist)))
    439466                   (case x
    440467                     [(#!optional)
    441                       (if (not rvar) (set! rvar (macro-alias 'tmp se)))
     468                      (unless rvar (set! rvar (macro-alias 'tmp se)))
    442469                      (if (eq? mode 0)
    443470                          (loop 1 req '() '() r)
     
    458485                          (err "`#!key' argument marker in wrong context") ) ]
    459486                     [else
    460                       (cond [(symbol? x)
     487                      (cond [(symbol? var)
    461488                             (case mode
    462                                [(0) (loop 0 (cons x req) '() '() r)]
    463                                [(1) (loop 1 req (cons (list x #f) opt) '() r)]
     489                               [(0) (loop 0 (cons var req) '() '() r)]
     490                               [(1) (loop 1 req (cons (list var #f) opt) '() r)]
    464491                               [(2) (err "invalid lambda list syntax after `#!rest' marker")]
    465                                [else (loop 3 req opt (cons (list x) key) r)] ) ]
    466                             [(and (list? x) (eq? 2 (length x)))
     492                               [else (loop 3 req opt (cons (list var) key) r)] ) ]
     493                            [(and (list? var) (eq? 2 (length var)))
    467494                             (case mode
    468495                               [(0) (err "invalid required argument syntax")]
    469                                [(1) (loop 1 req (cons x opt) '() r)]
     496                               [(1) (loop 1 req (cons var opt) '() r)]
    470497                               [(2) (err "invalid lambda list syntax after `#!rest' marker")]
    471                                [else (loop 3 req opt (cons x key) r)] ) ]
     498                               [else (loop 3 req opt (cons var key) r)] ) ]
    472499                            [else (err "invalid lambda list syntax")] ) ] ) ) ] ) ) ) ) ) )
    473500
     
    478505  (let ([reverse reverse]
    479506        [map map] )
    480     (lambda (body #!optional (se (##sys#current-environment)))
     507    (lambda (body #!optional (se (##sys#current-environment)) cs?)
    481508      (define (fini vars vals mvars mvals body)
    482509        (if (and (null? vars) (null? mvars))
     
    484511              (if (not (pair? body2))
    485512                  (cons
    486                    (macro-alias 'begin se)
     513                   '##core#begin
    487514                   body) ; no more defines, otherwise we would have called `expand'
    488515                  (let ([x (car body2)])
     
    493520                                        (eq? (or (lookup d se) d) 'define-values)))) )
    494521                        (cons
    495                          (macro-alias 'begin se)
     522                         '##core#begin
    496523                         (##sys#append (reverse exps) (list (expand body2))))
    497524                        (loop (cdr body2) (cons x exps)) ) ) ) )
     
    531558                     (cdr body)
    532559                     (cons (if (pair? (cadr def))
    533                                `(define-syntax ,(caadr def) (,(macro-alias 'lambda se) ,(cdadr def) ,@(cddr def)))
     560                               `(define-syntax ,(caadr def)
     561                                  (,(macro-alias 'lambda se) ,(cdadr def) ,@(cddr def)))
    534562                               def)
    535563                           defs)
     
    564592                                               (##sys#expand-curried-define head (cddr x) se))) ]
    565593                                 [else
    566                                   (##sys#check-syntax 'define x '(define (variable . lambda-list) . #(_ 1)) #f se)
     594                                  (##sys#check-syntax
     595                                   'define x '(define (variable . lambda-list) . #(_ 1)) #f se)
    567596                                  (loop rest
    568597                                        (cons (car head) vars)
     
    581610                       (fini vars vals mvars mvals body))
    582611                      [else
    583                        (let ([x2 (##sys#expand-0 x se)])
     612                       (let ([x2 (##sys#expand-0 x se cs?)])
    584613                         (if (eq? x x2)
    585614                             (fini vars vals mvars mvals body)
     
    631660
    632661(define syntax-error ##sys#syntax-error-hook)
     662
     663(define (##sys#syntax-rules-mismatch input)
     664  (##sys#syntax-error-hook "no rule matches form" input))
    633665
    634666(define (get-line-number sexp)
     
    728760
    729761;;; explicit-renaming transformer
     762
     763(define (er-macro-transformer x) x)
    730764
    731765(define ((##sys#er-transformer handler) form se dse)
     
    915949                (and-let* ((a (assq id (import-env)))
    916950                           ((not (eq? aid (cdr a)))))
    917                   (##sys#warn "re-importing already imported identfier" id))))
     951                  (##sys#warn "re-importing already imported identifier" id))))
    918952            vsv)
    919953           (for-each
     
    10031037  (lambda (form r c)
    10041038    (let ((body (cdr form))
    1005           (%begin (r 'begin))
    10061039          (%let (r 'let))
    10071040          (%if (r 'if))
     
    10161049                  (rclauses (cdr clauses)) )
    10171050              (##sys#check-syntax 'cond clause '#(_ 1))
    1018               (cond ((c %else (car clause)) `(,%begin ,@(cdr clause)))
     1051              (cond ((c %else (car clause)) `(##core#begin ,@(cdr clause)))
    10191052                    ((null? (cdr clause)) `(,%or ,(car clause) ,(expand rclauses)))
    10201053                    ((c %=> (cadr clause))
     
    10341067                                       ,(expand rclauses) ) ) ) ) )
    10351068                    (else `(,%if ,(car clause)
    1036                                  (,%begin ,@(cdr clause))
     1069                                 (##core#begin ,@(cdr clause))
    10371070                                 ,(expand rclauses) ) ) ) ) ) ) ) ) ))
    10381071
     
    10461079          (body (cddr form)) )
    10471080      (let ((tmp (r 'tmp))
    1048             (%begin (r 'begin))
    10491081            (%if (r 'if))
    10501082            (%or (r 'or))
    1051             (%eqv? '##sys#eqv?)
    10521083            (%else (r 'else)))
    10531084        `(let ((,tmp ,exp))
     
    10591090                    (##sys#check-syntax 'case clause '#(_ 1))
    10601091                    (if (c %else (car clause))
    1061                         `(,%begin ,@(cdr clause))
     1092                        `(##core#begin ,@(cdr clause))
    10621093                        `(,%if (,%or ,@(##sys#map
    1063                                         (lambda (x) `(,%eqv? ,tmp ',x)) (car clause)))
    1064                                (,%begin ,@(cdr clause))
     1094                                        (lambda (x) `(##sys#eqv? ,tmp ',x)) (car clause)))
     1095                               (##core#begin ,@(cdr clause))
    10651096                               ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )
    10661097
     
    10901121          (dovar (r 'doloop))
    10911122          (%let (r 'let))
    1092           (%if (r 'if))
    1093           (%begin (r 'begin)))
     1123          (%if (r 'if)))
    10941124      `(,%let ,dovar ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)
    10951125              (,%if ,(car test)
     
    10971127                       (if (eq? tbody '())
    10981128                           '(##core#undefined)
    1099                            `(,%begin ,@tbody) ) )
    1100                     (,%begin
     1129                           `(##core#begin ,@tbody) ) )
     1130                    (##core#begin
    11011131                     ,(if (eq? body '())
    11021132                          '(##core#undefined)
     
    11871217          (%not (r 'not))
    11881218          (%else (r 'else))
    1189           (%begin (r 'begin))
    11901219          (%and (r 'and)))
    11911220      (define (err x)
     
    12291258                                (if (eq? rest '())
    12301259                                    '(##core#undefined)
    1231                                     `(,%begin ,@rest) ) ) )
    1232                              ((test id) `(,%begin ,@(cdr clause)))
     1260                                    `(##core#begin ,@rest) ) ) )
     1261                             ((test id) `(##core#begin ,@(cdr clause)))
    12331262                             (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) )
    12341263
     
    12571286    `(##core#module
    12581287      ,(cadr x)
    1259       ,(if (c (r '*) (caddr x))
     1288      ,(if (eq? '* (strip-syntax (caddr x)))
    12601289           #t
    12611290           (caddr x))
     
    12681297  (lambda (x r c)
    12691298    (##sys#check-syntax 'begin-for-syntax x '(_ . #(_ 0)))
    1270     (##sys#register-meta-expression `(begin ,@(cdr x)))
    1271     `(##core#elaborationtimeonly (,(r 'begin) ,@(cdr x))))))
     1299    (##sys#register-meta-expression `(##core#begin ,@(cdr x)))
     1300    `(##core#elaborationtimeonly (##core#begin ,@(cdr x))))))
    12721301
    12731302(##sys#extend-macro-environment
     
    13041333;;; the base macro environment ("scheme", essentially)
    13051334
    1306 (define ##sys#default-macro-environment (##sys#macro-environment))
     1335(define (##sys#macro-subset me0 #!optional parent-env)
     1336  (let ((se (let loop ((me (##sys#macro-environment)))
     1337              (if (or (null? me) (eq? me me0))
     1338                  '()
     1339                  (cons (car me) (loop (cdr me)))))))
     1340    (##sys#fixup-macro-environment se parent-env)))
     1341
     1342(define (##sys#fixup-macro-environment se #!optional parent-env)
     1343  (let ((se2 (if parent-env (##sys#append se parent-env) se)))
     1344    (for-each                           ; fixup se
     1345     (lambda (sdef)
     1346       (when (pair? (cdr sdef))
     1347         (set-car!
     1348          (cdr sdef)
     1349          (if (null? (cadr sdef))
     1350              se2
     1351              (##sys#append (cadr sdef) se2)))))
     1352     se)
     1353    se))
     1354
     1355(define ##sys#default-macro-environment
     1356  (##sys#fixup-macro-environment (##sys#macro-environment)))
    13071357
    13081358
     
    15251575  (define (find-reexport name)
    15261576    (let ((a (assq name (##sys#macro-environment))))
    1527       (if (pair? (cdr a))
     1577      (if (and a (pair? (cdr a)))
    15281578          a
    15291579          (##sys#error
     
    15681618    mod))
    15691619
     1620(define (##sys#primitive-alias sym)
     1621  (let ((palias
     1622         (##sys#string->symbol
     1623          (##sys#string-append "#%" (##sys#slot sym 1)))))
     1624    (##sys#put! palias '##core#primitive sym)
     1625    palias))
     1626
    15701627(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
    15711628  (let* ((me (##sys#macro-environment))
     
    15741631               (map (lambda (ve)
    15751632                      (if (symbol? ve)
    1576                           (let ((palias
    1577                                  (##sys#string->symbol
    1578                                   (##sys#string-append "#%" (##sys#slot ve 1)))))
    1579                             (##sys#put! palias '##core#primitive ve)
    1580                             (cons ve palias))
     1633                          (cons ve (##sys#primitive-alias ve))
    15811634                          ve))
    15821635                    vexports)
     
    16971750
    16981751(define ##sys#module-table '())
    1699 
    1700 (define (##sys#macro-subset me0)
    1701   (let loop ((me (##sys#macro-environment)))
    1702     (if (or (null? me) (eq? me me0))
    1703         '()
    1704         (cons (car me) (loop (cdr me))))))
  • chicken/branches/release/extras.scm

    r13859 r15293  
    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/release/files.scm

    r13859 r15293  
    5252      string-match regexp
    5353      ##sys#string-append ##sys#substring  string-append
    54       getenv
     54      get-environment-variable
    5555      file-exists? delete-file
    5656      call-with-output-file read-string)
     
    325325
    326326(define create-temporary-file
    327   (let ([getenv getenv]
     327  (let ([get-environment-variable get-environment-variable]
    328328        [make-pathname make-pathname]
    329329        [file-exists? file-exists?]
    330330        [call-with-output-file call-with-output-file] )
    331331    (lambda ext
    332       (let ([dir (or (getenv "TMPDIR") (getenv "TEMP") (getenv "TMP"))]
    333             [ext (if (pair? ext) (car ext) "tmp")])
     332      (let ((dir (or (get-environment-variable "TMPDIR")
     333                     (get-environment-variable "TEMP")
     334                     (get-environment-variable "TMP")
     335                     (file-exists? "/tmp")))
     336            (ext (if (pair? ext) (car ext) "tmp")))
    334337        (##sys#check-string ext 'create-temporary-file)
    335338        (let loop ()
     
    343346;;; normalize pathname for a particular platform
    344347
    345 (define (normalize-pathname path #!optional (platform (build-platform)))
    346   (case platform
    347     ((mingw32 msvc)
    348      (string-translate path "/" "\\"))
    349     (else path)))
     348(define normalize-pathname
     349  (let ((open-output-string open-output-string)
     350        (get-output-string get-output-string)
     351        (get-environment-variable get-environment-variable)
     352        (reverse reverse)
     353        (display display))
     354    (lambda (path #!optional (platform (if (memq (build-platform) '(msvc mingw32)) 'windows 'unix)))
     355      (let ((sep (if (eq? platform 'windows) #\\ #\/)))
     356        (define (addpart part parts)
     357          (cond ((string=? "." part) parts)
     358                ((string=? ".." part)
     359                 (if (null? parts)
     360                     '("..")
     361                     (cdr parts)))
     362                (else (cons part parts))))
     363        (##sys#check-string path 'normalize-pathname)
     364        (let ((len (##sys#size path))
     365              (abspath #f)
     366              (drive #f))
     367          (let loop ((i 0) (prev 0) (parts '()))
     368            (cond ((fx>= i len)
     369                   (when (fx> i prev)
     370                     (set! parts (addpart (##sys#substring path prev i) parts)))
     371                   (if (null? parts)
     372                       (##sys#string-append "." (string sep))
     373                       (let ((out (open-output-string))
     374                             (parts (reverse parts)))
     375                         (display (car parts) out)
     376                         (for-each
     377                          (lambda (p)
     378                            (##sys#write-char-0 sep out)
     379                            (display p out) )
     380                          (cdr parts))
     381                         (when (fx= i prev) (##sys#write-char-0 sep out))
     382                         (let* ((r1 (get-output-string out))
     383                                (r (##sys#expand-home-path r1)))
     384                           (when (string=? r1 r)
     385                             (when abspath
     386                               (set! r (##sys#string-append (string sep) r)))
     387                             (when drive
     388                               (set! r (##sys#string-append drive r))))
     389                           r))))
     390                  ((memq (string-ref path i) '(#\\ #\/))
     391                   (when (and (null? parts) (fx= i prev))
     392                     (set! abspath #t))
     393                   (if (fx= i prev)
     394                       (loop (fx+ i 1) (fx+ i 1) parts)
     395                       (loop (fx+ i 1)
     396                             (fx+ i 1)
     397                             (addpart (##sys#substring path prev i) parts))))
     398                  ((and (null? parts)
     399                        (char=? (string-ref path i) #\:)
     400                        (eq? 'windows platform))
     401                   (set! drive (##sys#substring path 0 (fx+ i 1)))
     402                   (loop (fx+ i 1) (fx+ i 1) '()))
     403                  (else (loop (fx+ i 1) prev parts)))))))))
    350404
    351405
  • chicken/branches/release/irregex.import.scm

    r13240 r15293  
    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/release/irregex.scm

    r13240 r15293  
    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/release/library.scm

    r13876 r15293  
    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
    161      string->keyword keyword? string->keyword getenv ##sys#number->string ##sys#copy-bytes
     160     ##sys#apply-values ##sys#get-call-chain ##sys#really-print-call-chain
     161     string->keyword keyword? string->keyword get-environment-variable ##sys#number->string ##sys#copy-bytes
    162162     call-with-current-continuation ##sys#string->number ##sys#inexact->exact ##sys#exact->inexact
    163163     ##sys#reverse-list->string reverse ##sys#inexact? list? string ##sys#char->utf8-string
     
    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)
     
    231232(define ##sys#decode-seconds (##core#primitive "C_decode_seconds"))
    232233(define get-environment-variable (##core#primitive "C_get_environment_variable"))
    233 (define getenv get-environment-variable)
     234(define getenv get-environment-variable) ; DEPRECATED
    234235(define (##sys#start-timer) (##core#inline "C_start_timer"))
    235236(define ##sys#stop-timer (##core#primitive "C_stop_timer"))
     
    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"))
     
    18391846
    18401847(define ##sys#expand-home-path
    1841   (let ((getenv getenv))
     1848  (let ((get-environment-variable get-environment-variable))
    18421849    (lambda (path)
    18431850      (let ((len (##sys#size path)))
     
    18461853              ((#\~)
    18471854               (let ((rest (##sys#substring path 1 len)))
    1848                  (if (and (fx> len 1) (char=? #\/ (##core#inline "C_subchar" path 1)))
    1849                      (##sys#string-append (or (getenv "HOME") "") rest)
    1850                      (##sys#string-append "/home/" rest) ) ) )
     1855                 (##sys#string-append (or (get-environment-variable "HOME") "") rest) ) )
    18511856              ((#\$)
    18521857               (let loop ((i 1))
     
    18561861                       (if (or (eq? c #\/) (eq? c #\\))
    18571862                           (##sys#string-append
    1858                             (or (getenv (##sys#substring path 1 i)) "")
     1863                            (or (get-environment-variable (##sys#substring path 1 i)) "")
    18591864                            (##sys#substring path i len))
    18601865                           (loop (fx+ i 1)) ) ) ) ) )
     
    19601965    (lambda (name)
    19611966      (and (##sys#file-info (##sys#platform-fixup-pathname name)) name) )
     1967    #:exists?) )
     1968
     1969(define (directory-exists? name)
     1970  (##sys#check-string name 'directory-exists?)
     1971  (##sys#pathname-resolution
     1972    name
     1973    (lambda (name)
     1974      (and-let* ((info (##sys#file-info (##sys#platform-fixup-pathname name))))
     1975        (eq? 1 (vector-ref info 4))
     1976        name))
    19621977    #:exists?) )
    19631978
     
    36283643      (##sys#make-structure
    36293644       'condition
    3630        '(user-interrupt) ) ) ]
     3645       '(user-interrupt)
     3646       '() ) ) ]
    36313647    [(#:warning)
    36323648     (##sys#print "\nWarning: " #f ##sys#standard-error)
     
    37333749  (let ([oldh ##sys#current-exception-handler])
    37343750    (##sys#dynamic-wind
    3735         (lambda () (set! ##sys#current-exception-handler handler))
    3736         thunk
    3737         (lambda () (set! ##sys#current-exception-handler oldh)) ) ) )
     3751      (lambda () (set! ##sys#current-exception-handler handler))
     3752      thunk
     3753      (lambda () (set! ##sys#current-exception-handler oldh)) ) ) )
    37383754
    37393755(define (current-exception-handler) ##sys#current-exception-handler)
     
    43194335(define ##sys#vector->list vector->list)
    43204336(define ##sys#vector-length vector-length)
    4321 (define ##sys#vector-ref vector-length)
    4322 (define ##sys#vector-length vector-length)
     4337(define ##sys#vector-ref vector-ref)
    43234338(define ##sys#>= >=)
    43244339(define ##sys#= =)
     
    43294344(define ##sys#null? null?)
    43304345(define ##sys#map-n map)
     4346(define ##sys#list-ref list-ref)
    43314347
    43324348
  • chicken/branches/release/lolevel.scm

    r13859 r15293  
    365365(define pointer-s8-ref
    366366  (getter-with-setter
    367    (foreign-lambda* int ([c-pointer p]) "return(*((char *)p));")
     367   (foreign-lambda* int ([c-pointer p]) "return(*((signed char *)p));")
    368368   pointer-s8-set!) )
    369369
  • chicken/branches/release/manual/Accessing external objects

    r13859 r15293  
    2121=== foreign-value
    2222
    23  [syntax] (foreign-value STRING TYPE)
     23 [syntax] (foreign-value CODE TYPE)
    2424
    25 Evaluates the embedded C/C++ expression {{STRING}}, returning a value of type given
     25Evaluates the embedded C/C++ expression {{CODE}} (which may be a string or symbol), returning a value of type given
    2626in the foreign-type specifier {{TYPE}}.
    2727
  • chicken/branches/release/manual/Acknowledgements

    r13876 r15293  
    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
     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, Abdulaziz Ghuloum, Joey Gibson, Stephen C. Gilardi,
     18Mario Domenech Goulart, Joshua Griffith, Johannes Groedem, Damian
     19Gryski, Andreas Gustafsson, Sven Hartrumpf, Jun-ichiro itojun Hagino,
     20Ahdi Hargo, Matthias Heiler, Karl M. Hegbloom, William P. Heinemann,
     21Bill Hoffman, Bruce Hoult, Hans Huebner, Markus Huelsmann, Goetz
     22Isenmann, Paulo Jabardo, Wietse Jacobs, David Janssens, Christian
     23Jaeger, Matt Jones, Dale Jordan, Valentin Kamyshenko, Daishi Kato,
     24Peter Keller, Brad Kind, Ron Kneusel, Matthias Koeppe, Krysztof
     25Kowa&#322;czyk, Andre Kuehne, Todd R. Kueny Sr, Goran Krampe, David
     26Krentzlin, Ben Kurtz, Micky Latowicki, John Lenz, Kirill Lisovsky,
     27Juergen Lorenz, Kon Lovett, Lam Luu, Leonardo Valeri Manera, Dennis
    2728Marti, Charles Martin, Bob McIsaac, Alain Mellan, Eric Merrit, Perry
    2829Metzger, Scott G. Miller, Mikael, Bruce Mitchener, Chris Moline, Eric
    2930E. Moore, Julian Morrison, Dan Muresan, Lars Nilsson, Ian Oversby,
    3031o.t., Gene Pavlovsky, Levi Pearson, Nicolas Pelletier, Carlos Pita,
    31 Robin Lee Powell, Pupeno, Davide Puricelli, Doug Quale, Eric Raible,
    32 Ivan Raikov, Joel Reymont, Eric Rochester, Andreas Rottman, David
    33 Rush, Lars Rustemeier, Daniel Sadilek, Oskar Schirmer, Burton
     32Robin Lee Powell, Pupeno, Davide Puricelli, presto, Doug Quale, Eric
     33Raible, Ivan Raikov, Joel Reymont, Eric Rochester, Andreas Rottman,
     34David Rush, Lars Rustemeier, Daniel Sadilek, Oskar Schirmer, Burton
    3435Samograd, Reed Sheridan, Ronald Schroeder, Spencer Schumann, Ivan
    3536Shcheklein, Alex Shinn, Ivan Shmakov, Shmul, Tony Sidaway, Jeffrey
     
    6566; Olin Shivers : implementation of {{let-optionals[*]}} and reference implementations of SRFI-1, SRFI-13 and SRFI-14.
    6667; Andrew Wilcox : queues.
    67 ; [[http://chicken.wiki.br/Alex Shinn|Alex Shinn]] : {{scheme-complete.el}} emacs tab-completion
     68; [[http://chicken.wiki.br/users/Alex-Shinn|Alex Shinn]] : {{scheme-complete.el}} emacs tab-completion
    6869
    6970The documentation and examples for explicit renaming macros was taken from
  • chicken/branches/release/manual/Data representation

    r13859 r15293  
    33== Data representation
    44
    5 ''Note: In all cases below, bits are numbered starting
    6 at 1 and beginning with the lowest-order bit.''
     5''Note: In all cases below, bits are numbered starting at 1 and beginning with the lowest-order bit.''
    76
    87There exist two different kinds of data objects in the CHICKEN system:
  • chicken/branches/release/manual/Declarations

    r13859 r15293  
    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/release/manual/Deviations from the standard

    r13859 r15293  
    2929      (set! y tmp2)
    3030      (cons x y) ) )
    31 
    32 [4.3] {{syntax-rules}} macros are not provided but available
    33 separately.
    3431
    3532[6.1] {{equal?}} compares all structured data recursively, while R5RS
  • chicken/branches/release/manual/Extensions

    r13859 r15293  
    270270
    271271
    272 ==== setup-install-flag
    273 
    274  [parameter] (setup-install-flag [BOOL])
     272==== setup-install-mode
     273
     274 [parameter] (setup-install-mode [BOOL])
    275275
    276276Reflects the setting of the {{-no-install}} option, i.e. is {{#f}}, if {{-no-install}} was
  • chicken/branches/release/manual/Interface to external functions and variables

    r13859 r15293  
    22
    33== Interface to external functions and variables
     4
     5The macros in this section, such as {{define-foreign-type}} and {{define-external}}, are available in the {{foreign}} import library.  To access them:
     6
     7 (import foreign)
    48
    59* [[Accessing external objects]]
  • chicken/branches/release/manual/Modules and macros

    r13859 r15293  
    4545argument to the {{syntax-rules}} form.
    4646
     47The effect of destructively modifying the s-expression passed to a
     48transformer procedure is undefined.
     49
    4750
    4851==== define-compiled-syntax
     
    7376
    7477The low-level macro facility that CHICKEN provides is called "explicit
    75 renaming" and allows writing hygienic or nonhygienic macros procedurally.
     78renaming" and allows writing hygienic or non-hygienic macros procedurally.
    7679When given a lambda-expression instead of a {{syntax-rules}} form,
    7780{{define-syntax}} evaluates the procedure in a distinct expansion
     
    107110hygienic {{let}} macro must rename the identifier {{lambda}} to protect it
    108111from being captured by a local binding.  The renaming effectively
    109 creates an fresh alias for {{lambda}}, one that cannot be captured by
     112creates a fresh alias for {{lambda}}, one that cannot be captured by
    110113any subsequent binding:
    111114
     
    267270will export all definitions.
    268271
     272Note that the module system is only a device for controlling the
     273mapping of identifiers to value or syntax bindings. Modules do not
     274instantiate separate environments that contain their own bindings, as
     275do many other module systems. Redefinition of value or syntax bindings
     276will modify the original, imported definition.
     277
     278
    269279==== export
    270280
     
    280290 [syntax] (import IMPORT ...)
    281291
    282 Imports module bindings into the currentl syntactical environment.
     292Imports module bindings into the current syntactical environment.
    283293The visibility of any imported bindings is limited to the current
    284294module, if used inside a module-definition, or to the current
     
    293303
    294304Note that the imported bindings are only visible in the next toplevel
    295 expression (regardless of wether the import appears inside or outside
     305expression (regardless of whether the import appears inside or outside
    296306a module):
    297307
     
    439449  % csc -s hello.scm
    440450
    441 and used in an indentical manner:
     451and used in an identical manner:
    442452
    443453  #;1> ,l hello.so
     
    481491The macro- and module system has been implemented relatively
    482492recently and is likely to contain bugs. Please contact the
    483 maintainers if you encounter behaviour that you think is
     493maintainers if you encounter behavior that you think is
    484494not correct or that triggers an error where there shouldn't
    485495be one.
  • chicken/branches/release/manual/The User's Manual

    r13859 r15293  
    11[[tags:manual]]
    2 
    3 [[image:http://www.call-with-current-continuation.org/chicken4.png]]
    42
    53== The CHICKEN User's Manual
    64
    7 This is the user's manual for the Chicken Scheme compiler, version 4.0.0x5
     5<nowiki>
     6<img style="float:right; border-left:1px solid #ccc;border-bottom:1px solid #ccc;margin-left:1em;" src="http://www.call-with-current-continuation.org/chicken4.png" alt="Stylized picture of a chicken"/>
     7</nowiki>
     8
     9This is the manual for Chicken Scheme, version 4.1.0
    810
    911; [[Getting started]] : What is CHICKEN and how do I use it?
     
    2325; [[Data representation]] : How Scheme data is internally represented.
    2426
    25 ; [[Bugs and limitations]] : Yes, there are some.
     27; [[Bugs and limitations]] : Things that do not work yet.
    2628
    27 ; [[FAQ]] : A list of Frequently Asked Questions about CHICKEN (and their answers!).
     29; [[FAQ]] : A list of Frequently Asked Questions about CHICKEN (and their answers).
    2830
    2931; [[Acknowledgements]] : A list of some of the people that have contributed to make CHICKEN what it is.
  • chicken/branches/release/manual/Unit data-structures

    r13859 r15293  
    122122
    123123Returns {{LIST}} with its elements sorted in a random order given by
    124 procedure RANDOM.
     124procedure {{RANDOM}}.
    125125
    126126
  • chicken/branches/release/manual/Unit expand

    r13859 r15293  
    3434{{error}}.
    3535
     36
     37==== er-macro-transformer
     38
     39  [procedure] (er-macro-transformer TRANSFORMER)
     40
     41This procedure does nothing and is available for writing low-level
     42macros in a more portable fashion, without hard-coding the signature
     43of a transformer procedure.
     44
     45
    3646---
    3747Previous: [[Unit library]]
  • chicken/branches/release/manual/Unit files

    r13859 r15293  
    8282stripped.
    8383
     84==== normalize-pathname
     85
     86<procedure>(normalize-pathname PATHNAME [PLATFORM])</procedure>
     87
     88Performs a simple "normalization" on the {{PATHNAME}}, suitably for
     89{{PLATFORM}}, which should be one of the symbols {{windows}}
     90or {{unix}} and defaults to on whatever platform is currently
     91in use. All relative path elements and duplicate separators are processed
     92and removed.  If {{NAME}} ends with
     93a {{/}} or is empty, the appropriate slash is appended to the tail.
     94Tilde {{~}} and variable {{$<name>/...}} expansion is also done.
     95
     96No directories or files are actually tested for existence; this
     97procedure only canonicalises path syntax.
     98
    8499==== directory-null?
    85100
  • chicken/branches/release/manual/Unit library

    r13859 r15293  
    219219
    220220
     221==== directory-exists?
     222
     223<procedure>(directory-exists? STRING)</procedure>
     224
     225Returns {{STRING}} if a directory with the given pathname exists, or
     226{{#f}} otherwise.
     227
     228
    221229==== file-exists?
    222230
    223231<procedure>(file-exists? STRING)</procedure>
    224232
    225 Returns {{STRING}} if a file with the given pathname exists, or
     233Returns {{STRING}} if a file or directory with the given pathname exists, or
    226234{{#f}} otherwise.
    227235
  • chicken/branches/release/manual/Unit posix

    r13859 r15293  
    3636===== open/rdwr
    3737===== open/read
     38Synonym for {{open/rdonly}}.
     39
    3840===== open/write
     41Synonym for {{open/wronly}}.
     42
    3943===== open/creat
    4044===== open/append
     
    119123file-patterns (with {{*}} matching zero or more characters and
    120124{{?}} matching zero or one character).
    121 
    122 ==== canonical-path
    123 
    124 <procedure>(canonical-path NAME)</procedure>
    125 
    126 Returns a canonical path for {{NAME}}, which should be a string
    127 containing a path-or-filename.  The string returned by
    128 {{canonical-path}} is OS dependent; it may be quoted and used in
    129 a shell on the calling machine. (Quoting is suggested as shell
    130 special characters, including space, are not escaped.)  However,
    131 all path separators and prefixes are handled in an OS independent
    132 fashion.  Any appearance of {{/}} below imply {{\\}} is also handled.
    133 
    134 The prefix for {{NAME}} determines what path to prepend.  If {{NAME}}
    135 begins with a {{"~/"}}, this prefix is stripped and the user's
    136 home directory is added.  If beginning with {{/}} or a DRIVE-LETTER:\\
    137 combination, no additional path is added.  Otherwise, the current
    138 directory and separator are added.  All relative path elements and
    139 duplicate separators are processed and removed.  If {{NAME}} ends with
    140 a {{/}} or is empty, the appropriate slash is appended to the tail.
    141 
    142 No directories or files are actually tested for existence; this
    143 procedure only canonicalises path syntax.
    144125
    145126==== set-root-directory!
     
    279260
    280261Opens the file specified with the string {{FILENAME}} and open-flags
    281 {{FLAGS}} using the C function {{open()}}. On success a
    282 file-descriptor for the opened file is returned.  {{FLAGS}}
    283 should be a bitmask containing one or more of the {{open/...}}
     262{{FLAGS}} using the C function {{open(2)}}. On success a
     263file-descriptor for the opened file is returned.
     264
     265{{FLAGS}} is a bitmask of {{open/...}}
    284266values '''or'''ed together using {{bitwise-ior}} (or simply added
    285 together).  The optional {{MODE}} should be a bitmask composed of one
     267together).  You must provide exactly one of the access flags {{open/rdonly}}, {{open/wronly}}, or {{open/rdwr}}.  Additionally, you may provide zero or more creation flags ({{open/creat}}, {{open/excl}}, {{open/trunc}}, and {{open/noctty}}) and status flags (the remaining {{open/...}} values).  For example, to open a possibly new output file for appending:
     268
     269 (file-open "/tmp/hen.txt" (+ open/wronly open/append open/creat))
     270
     271The optional {{MODE}} should be a bitmask composed of one
    286272or more permission values like {{perm/irusr}} and is only relevant
    287273when a new file is created. The default mode is
     
    397383{{file-modification-time}}, device id, device type (for special file
    398384inode, blocksize and blocks allocated.  On Windows systems the last 4
    399 values are undefined.  If the optional argument {{LINK}} is given and
    400 not {{#f}}, then the file-statistics vector will be resolved for
    401 symbolic links (otherwise symbolic links are not resolved).
     385values are undefined.
     386
     387By default, symbolic links are followed and
     388the status of the referenced file is returned;
     389however, if the optional argument {{LINK}} is given and
     390not {{#f}}, the status of the link itself is returned.
     391
    402392Note that for very large files, the {{file-size}} value may be an
    403393inexact integer.
     
    452442
    453443
    454 ==== stat-regular?
    455 ==== stat-directory?
    456 ==== stat-char-device?
    457 ==== stat-block-device?
    458 ==== stat-fifo?
    459 ==== stat-symlink?
    460 ==== stat-socket?
    461 
    462 <procedure>(stat-regular? FILENAME)</procedure>
    463 <procedure>(stat-directory? FILENAME)</procedure>
    464 <procedure>(stat-char-device? FILENAME)</procedure>
    465 <procedure>(stat-block-device? FILENAME)</procedure>
    466 <procedure>(stat-fifo? FILENAME)</procedure>
    467 <procedure>(stat-symlink? FILENAME)</procedure>
    468 <procedure>(stat-socket? FILENAME)</procedure>
     444==== character-device?
     445==== block-device?
     446==== fifo?
     447==== socket?
     448
     449<procedure>(character-device? FILENAME)</procedure>
     450<procedure>(block-device? FILENAME)</procedure>
     451<procedure>(fifo? FILENAME)</procedure>
     452<procedure>(socket? FILENAME)</procedure>
    469453
    470454These procedures return {{#t}} if the {{FILENAME}} given is of the
     
    11361120current terminal window or {{0}}, {{0}} if the terminal
    11371121size can not be obtained. On Windows, this procedure
    1138 always returns {{0}, {{0}}.
     1122always returns {{0}}, {{0}}.
    11391123
    11401124
  • chicken/branches/release/manual/Unit regex

    r13859 r15293  
    99written completely in Scheme.
    1010
    11 This library unit exposes two APIs: the one listed below and the
    12 original irregex API. To use the latter, import from the {{irregex}} module.
     11This library unit exposes two APIs: the standard Chicken API described below, and the
     12original irregex API.  You may use either API or both:
     13
     14 (require-library regex)   ; required for either API, or both
     15 (import regex)            ; import the Chicken regex API
     16 (import irregex)          ; import the original irregex API
    1317
    1418Regular expressions may be either POSIX-style strings (with most PCRE
    1519extensions) or an SCSH-style SRE. There is no {{(rx ...)}} syntax -
    1620just use normal Scheme lists, with quasiquote if you like.
    17 
    18 
    1921
    2022=== grep
  • chicken/branches/release/manual/Unit srfi-13

    r13859 r15293  
    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/release/manual/Unit srfi-14

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

    r13859 r15293  
    103103Previous: [[Unit srfi-14]]
    104104
    105 Next: [[Unit posix]]
     105Next: [[Unit srfi-69]]
  • chicken/branches/release/manual/Unit utils

    r13859 r15293  
    6262port that is the current value of {{(current-input-port)}}.
    6363
     64
     65=== Shell argument quoting
     66
     67==== qs
     68
     69 [procedure] (qs STRING [PLATFORM])
     70
     71Escapes {{STRING}} suitably for passing to a shell command on {{PLATFORM}}.
     72{{PLATFORM}} defaults to the value of {{(build-platform)}} and indicates in
     73which style the argument should be quoted. On Windows systems, the string
     74is simply enclosed in double-quote ({{"}}) characters, on UNIXish systems,
     75characters that would have a special meaning to the shell are escaped
     76using backslash ({{\}}).
     77
     78
    6479---
    6580Previous: [[Unit posix]]
  • chicken/branches/release/manual/Using the compiler

    r13859 r15293  
    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
    5356     N          show the real-name mapping table
    54      U          show expressions after the secondary user pass
    5557     0          show database before lambda-lifting pass
     58     T          show expressions after converting to node tree
    5659     L          show expressions after lambda-lifting
    5760     M          show syntax-/runtime-requirements
     
    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}}.
     
    134137; -local : Assume toplevel variables defined in the current compilation unit are not externally modified.
    135138
     139; -no-argc-checks : disable argument count checks
     140
     141; -no-bound-checks : disable bound variable checks
     142
    136143; -no-lambda-info : Don't emit additional information for each {{lambda}} expression (currently the argument-list, after alpha-conversion/renaming).
    137144
    138145; -no-parentheses-synonyms STYLE : Disables list delimiter synonyms, [..] and {...} for (...).
     146
     147; -no-procedure-checks : disable procedure call checks
     148
     149; -no-procedure-checks-for-usual-bindings :  disable procedure call checks only for usual bindings
    139150
    140151; -no-symbol-escape : Disables support for escaped symbols, the |...| form.
     
    176187; -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 {{,}}.
    177188
     189; -scrutinize : Enable simple flow-analysis to catch common type errors and argument/result mismatches. You can also use the {{scrutinize}} declaration to enable scrutiny.
     190
    178191; -static-extension NAME : similar to {{-require-extension NAME}}, but links extension statically (also applies for an explicit {{(require-extension NAME)}}).
     192
     193; -types FILENAME : load additional type database from {{FILENAME}}. Type-definitions in {{FILENAME}} will override previous type-definitions.
    179194
    180195; -compile-syntax : Makes macros also available at run-time. By default macros are not available at run-time.
     
    366381or compiled code specified using the {{-extend}} option are loaded
    367382and 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
     383user-preprocessor-pass, user-pass}} and {{user-post-analysis-pass}} can be set
    369384to procedures that are called to perform certain compilation passes
    370385instead of the usual processing (for more information about parameters
  • chicken/branches/release/manual/Using the interpreter

    r13859 r15293  
    242242More details are available in [[http://www.call-with-current-continuation.org/eggs/readline.html|the egg's documentation]].
    243243
    244 === Accessing documentation
    245 
    246 You can access the manual directly from {{csi}} using the [[http://www.call-with-current-continuation.org/eggs/man.html|man]] extension by Mario Domenech Goulart.
    247 
    248 To enable it install the egg and put this in your {{~/.csirc}} file:
    249 
    250  (use man)
    251  (man:load)
    252 
    253 Then, in {{csi}}, you can search for definitions using {{man:search}} as in:
    254 
    255  (man:search "case")
    256 
    257 Note that the search uses regular expressions.
    258 To view the documentation for one entry from the manual, use {{man:help}} as in:
    259 
    260  (man:help "case-lambda")
    261 
    262 Note: Currently the documentation provided by the {{man}} extension corresponds to Chicken's 2.429, one of the last releases whose documentation was in the texinfo format (the format the {{man}} extension parses).
    263244
    264245---
  • chicken/branches/release/manual/faq

    r13859 r15293  
    11[[toc:]]
    2 [[tags:faq]]
     2[[tags:faq manual]]
    33
    44== FAQ
     
    415415{{boolean?}} {{number?}} {{complex?}} {{rational?}} {{real?}} {{exact?}} {{inexact?}} {{list?}} {{eof-object?}}
    416416{{string-ref}} {{string-set!}} {{vector-ref}} {{vector-set!}} {{char=?}} {{char<?}} {{char>?}} {{char<=?}} {{char>=?}}
    417 {{char-numeric?}} {{char-alphabetic?}} {{char-whitespace?}} {{char-upper-case?}}
     417{{char-numeric?}} {{char-alphabetic?}} {{char-whitespace?}} {{char-upper-case?}} {{for-each}}
    418418{{char-lower-case?}} {{char-upcae}} {{char-downcase}} {{list-tail}} {{assv}} {{memv}} {{memq}} {{assoc}}
    419419{{member}} {{set-car!}} {{set-cdr!}} {{abs}} {{exp}} {{sin}} {{cos}} {{tan}} {{log}} {{asin}} {{acos}} {{atan}} {{sqrt}}
     
    471471{{cpu-time}} {{error}} {{call/cc}} {{any?}}
    472472{{substring=?}} {{substring-ci=?}} {{substring-index}} {{substring-index-ci}}
     473{{printf}} {{sprintf}} {{fprintf}} {{format}} {{o}}
     474
     475==== What's the difference betweem "block" and "local" mode?
     476
     477In {{block}} mode, the compiler assumes that definitions in the current file
     478are not visible from outside of the current compilation unit, so unused
     479definitions can be removed and calls can be inlined. In {{local}} mode,
     480definitions are not hidden, but the compiler assumes that they are
     481not modified from other compilation units (or code evaluated at runtime),
     482and thus allows inlining of them.
    473483
    474484==== Can I load compiled code at runtime?
     
    486496==== Why is my program which uses regular expressions so slow?
    487497
    488 The regular expression engine has recently be replaced by [[alex shinn]]'s excellent
     498The regular expression engine has recently be replaced by [[/users/alex shinn|alex shinn]]'s excellent
    489499{{irregex}} library, which is fully implemented in Scheme. Precompiling regular
    490500expressions to internal form is somewhat slower than with the old PCRE-based
  • chicken/branches/release/optimizer.scm

    r13240 r15293  
    3131  compiler-arguments process-command-line perform-lambda-lifting!
    3232  default-standard-bindings default-extended-bindings
    33   foldable-bindings llist-length
     33  foldable-bindings llist-length r-c-s compile-format-string
    3434  installation-home decompose-lambda-list external-to-pointer
    3535  copy-node! variable-visible? mark-variable intrinsic?
     
    5959  topological-sort print-version print-usage initialize-analysis-database
    6060  expand-foreign-callback-lambda default-optimization-passes default-optimization-passes-when-trying-harder
    61   units-used-by-default words-per-flonum rewrite inline-locally
     61  units-used-by-default words-per-flonum rewrite inline-locally compiler-syntax-statistics
    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
     
    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-e