Changeset 14827 in project for chicken


Ignore:
Timestamp:
05/29/09 14:10:51 (10 years ago)
Author:
felix winkelmann
Message:

merged trunk changes until 14826 into scrutiny branch

Location:
chicken/branches/scrutiny
Files:
4 added
57 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/scrutiny

  • chicken/branches/scrutiny/ANNOUNCE

    r13965 r14827  
    44been released. In addition to many bugfixes and cleaning up, it provides
    55the 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 extension
    12   libraries, which are easier to use and provide more flexibility
    136
    147- The macro system has been completely rewritten and is now fully
     
    1912- A module system has been implemented that fully supports hygienic
    2013  macros and still integrates with separate and cross compilation
     14
     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)
     18
     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'
    2122
    2223- A new optimization mode "local" enables inlining of definitions
  • chicken/branches/scrutiny/Makefile.bsd

    r12937 r14827  
    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/scrutiny/Makefile.mingw

    r13965 r14827  
    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/scrutiny/Makefile.msvc

    r13965 r14827  
    185185        libuchicken$(SO) libchickengui$(SO) libchickengui$(A) chicken-setup$(EXE)
    186186
    187 chicken-config.h: chicken-defaults.h
     187chicken-config.h.in:
    188188        echo #define HAVE_DIRENT_H 0 >>$@
    189189        echo #define HAVE_INTTYPES_H 0 >>$@
     
    224224endif
    225225        echo #define C_HACKED_APPLY >>$@
    226         cat chicken-defaults.h >>$@
     226
     227chicken-config.h: chicken-config.h.in chicken-defaults.h
     228        copy /Y /B chicken-config.h.in + chicken-defaults.h $@
    227229
    228230chicken-defaults.h:
  • chicken/branches/scrutiny/NEWS

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

    r13965 r14827  
    44  (c) 2008-2009, The Chicken Team
    55
    6   version 4.0.1x1
     6  version 4.0.5
    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
     
    262274          Cygwin, and Visual C/C++ (PLATFORM=msvc) are supported.
    263275          Makefiles for mingw under MSYS and Windows shell are provided
    264           (`Makefile.mingw-msys' and `Makefile.mingw').
     276          (`Makefile.mingw-msys' and `Makefile.mingw'). Please also
     277          read the notes below:
    265278
    266279        - When installing under the mingw-msys platform, PREFIX must be an
    267           absolute path name (i.e. it must include the drive letter).
     280          absolute path name (i.e. it must include the drive letter) and
     281          must use forward slashes (no backward slashes).
    268282
    269283        - When installing under mingw, with a windows shell ("cmd.exe"),
    270284          pass an absolute pathname as PREFIX and use forward slashes.
     285
     286        - When installing under mingw without MSYS, make sure that the
     287          MSYS tools (in case you have some of them, in particular the
     288          sh.exe UNIX shell) are *NOT* visible in your PATH.
    271289
    272290        - Cygwin will not be able to find the chicken shared libraries
  • chicken/branches/scrutiny/TODO

    r14804 r14827  
    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
     68*** scrutiny
    5369
    5470** expander
    55 *** test new implementation of `define-for-syntax'
    56 **** test "numbers" egg
    57 **** is s48-modules still working?
    5871*** at some stage remove debug-output in expand.scm
    5972
     
    7184*** check phase separation and module access
    7285**** see "expander" above
     86** complete chicken-base.scm
     87*** syntax reexports
     88*** integrate into build
    7389
    7490** compiler
     
    8298**** option in chicken-install to list available eggs
    8399*** automatically update db after extension installation?
    84 *** test sudo
    85100
    86101** library units
     
    90105*** Use record-descriptors instead of symbols as 1st slot in structure objects?
    91106**** see Kon's proposal for new record-descriptors in "misc/Chicken Runtime Data Type Proposal"
     107*** deprecate "getenv"
    92108
    93109** syntax-error
     
    104120*** using "touch" with WINDOWS_SHELL won't work (need alternative)
    105121*** extend scripts/guess-platforms.sh for more platforms
    106 *** is the Mac build properly working?
    107122
    108123** documentation
     
    114129
    115130
     131* wiki
     132
     133** compatibility page
     134
     135
     136* extensions
     137
     138** check status of `s48-modules'
     139
     140
    116141* tests
    117142
     
    120145*** fully compiled ec-tests
    121146** 3-stage bootstrap with compiler-output comparison
    122 
    123 
    124 * documentation
    125 
    126 ** document new .meta entries in tutorials on wiki
    127    depends, test-depends
    128 ** chicken.texi needs to be regenerated
    129147
    130148
  • chicken/branches/scrutiny/batch-driver.scm

    r14716 r14827  
    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
     
    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 scrutinize do-scrutinize
     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
     
    495495                 (end-time "user pass") ) )
    496496
    497              (let ((req (concatenate (vector->list file-requirements))))
    498                (when (debugging 'M "; requirements:")
    499                  (pp req))
    500                (when inline-globally
    501                  (for-each
    502                   (lambda (id)
    503                     (and-let* ((ifile (##sys#resolve-include-filename
    504                                        (make-pathname #f (symbol->string id) "inline")
    505                                        #f #t))
    506                                ((file-exists? ifile)))
    507                       (dribble "Loading inline file ~a ..." ifile)
    508                       (load-inline-file ifile)))
    509                   (concatenate (map cdr req)))))
    510 
    511497             (let ((node0 (make-node
    512498                           'lambda '(())
     
    544530                 (set! first-analysis #t) )
    545531
     532               (let ((req (concatenate (vector->list file-requirements))))
     533                 (when (debugging 'M "; requirements:")
     534                   (pp req))
     535                 (when enable-inline-files
     536                   (for-each
     537                    (lambda (id)
     538                      (and-let* ((ifile (##sys#resolve-include-filename
     539                                         (make-pathname #f (symbol->string id) "inline")
     540                                         #f #t))
     541                                 ((file-exists? ifile)))
     542                        (dribble "Loading inline file ~a ..." ifile)
     543                        (load-inline-file ifile)))
     544                    (concatenate (map cdr req)))))
     545
    546546               (set! ##sys#line-number-database #f)
    547547               (set! constant-table #f)
     
    562562                     (when first-analysis
    563563                       (when (memq 'u debugging-chicken)
    564                          (dump-undefined-globals db)) )
     564                         (dump-undefined-globals db))
     565                       (when (memq 'd debugging-chicken)
     566                         (dump-defined-globals db)) )
    565567                     (set! first-analysis #f)
    566568                     (end-time "analysis")
  • chicken/branches/scrutiny/buildversion

    r13965 r14827  
    1 4.0.1x1
     14.0.5
     2
  • chicken/branches/scrutiny/c-backend.scm

    r13138 r14827  
    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/scrutiny/chicken-install.scm

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

    r13965 r14827  
    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/scrutiny/chicken-syntax.scm

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

    r13965 r14827  
    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)
  • chicken/branches/scrutiny/chicken.import.scm

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

    r13965 r14827  
    296296  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
    297297  make-random-name final-foreign-type real-name-table real-name set-real-name! safe-globals-flag
    298   location-pointer-map literal-rewrite-hook inline-globally
     298  location-pointer-map literal-rewrite-hook inline-globally enable-inline-files
    299299  local-definitions export-variable variable-mark intrinsic? do-scrutinize
    300300  undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info
     
    304304  big-fixnum? import-libraries unlikely-variables)
    305305
     306
     307(define (d arg1 . more)
     308  (if (null? more)
     309      (pp arg1)
     310      (apply print arg1 more)))
     311
     312(define-syntax d (syntax-rules () ((_ . _) (void))))
    306313
    307314(include "tweaks")
     
    371378(define inline-output-file #f)
    372379(define do-scrutinize #f)
     380(define enable-inline-files #f)
    373381
    374382
     
    477485        x) )
    478486
    479   (define (resolve-variable x0 se dest)
     487  (define (resolve-variable x0 e se dest)
    480488    (let ((x (lookup x0 se)))
     489      (d `(RESOLVE-VARIABLE: ,x0 ,x ,(map car se)))
    481490      (cond ((not (symbol? x)) x0)      ; syntax?
    482491            [(and constants-used (##sys#hash-table-ref constant-table x))
    483              => (lambda (val) (walk (car val) se dest)) ]
     492             => (lambda (val) (walk (car val) e se dest)) ]
    484493            [(and inline-table-used (##sys#hash-table-ref inline-table x))
    485              => (lambda (val) (walk val se dest)) ]
     494             => (lambda (val) (walk val e se dest)) ]
    486495            [(assq x foreign-variables)
    487496             => (lambda (fv)
     
    493502                      (finish-foreign-result ft body)
    494503                      t)
    495                      se dest)))]
     504                     e se dest)))]
    496505            [(assq x location-pointer-map)
    497506             => (lambda (a)
     
    503512                      (finish-foreign-result ft body)
    504513                      t)
    505                      se dest))) ]
    506             ((not (assq x0 se)) (##sys#alias-global-hook x #f)) ; only if global
     514                     e se dest))) ]
    507515            ((##sys#get x '##core#primitive))
     516            ((not (memq x e)) (##sys#alias-global-hook x #f)) ; only if global
    508517            (else x))))
    509518 
     
    517526       '() ) ))
    518527
    519   (define (walk x se dest)
     528  (define (walk x e se dest)
    520529    (cond ((symbol? x)
    521530           (cond ((keyword? x) `(quote ,x))
     
    524533                   'var
    525534                   "reference to variable `~s' possibly unintended" x) ))
    526            (resolve-variable x se dest))
     535           (resolve-variable x e se dest))
    527536          ((not-pair? x)
    528537           (if (constant? x)
     
    541550                    (xexpanded (##sys#expand x se)))
    542551               (cond ((not (eq? x xexpanded))
    543                       (walk xexpanded se dest))
     552                      (walk xexpanded e se dest))
    544553                     
    545554                     [(and inline-table-used (##sys#hash-table-ref inline-table name))
    546555                      => (lambda (val)
    547                            (walk (cons val (cdr x)) se dest)) ]
     556                           (walk (cons val (cdr x)) e se dest)) ]
    548557                     
    549558                     [else
     
    554563                         (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
    555564                         `(if
    556                            ,(walk (cadr x) se #f)
    557                            ,(walk (caddr x) se #f)
     565                           ,(walk (cadr x) e se #f)
     566                           ,(walk (caddr x) e se #f)
    558567                           ,(if (null? (cdddr x))
    559568                                '(##core#undefined)
    560                                 (walk (cadddr x) se #f) ) ) )
     569                                (walk (cadddr x) e se #f) ) ) )
    561570
    562571                        ((quote syntax)
     
    567576                         (if unsafe
    568577                             ''#t
    569                              (walk (cadr x) se dest) ) )
     578                             (walk (cadr x) e se dest) ) )
    570579
    571580                        ((##core#immutable)
     
    588597                         `(##core#inline_loc_ref
    589598                           ,(##sys#strip-syntax (cadr x))
    590                            ,(walk (caddr x) se dest)))
     599                           ,(walk (caddr x) e se dest)))
    591600
    592601                        ((##core#require-for-syntax)
     
    616625                                         'ext "extension `~A' is currently not installed" id))
    617626                                      `(begin ,exp ,(loop (cdr ids))) ) ) ) )
    618                             se dest) ) )
     627                            e se dest) ) )
    619628
    620629                        ((let ##core#let)
     
    627636                           `(let
    628637                             ,(map (lambda (alias b)
    629                                      (list alias (walk (cadr b) se (car b))) )
     638                                     (list alias (walk (cadr b) e se (car b))) )
    630639                                   aliases bindings)
    631640                             ,(walk (##sys#canonicalize-body (cddr x) se2)
     641                                    (append aliases e)
    632642                                    se2 dest) ) ) )
    633643
    634                          ((letrec ##core#letrec)
    635                           (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
    636                           (let ((bindings (cadr x))
    637                                 (body (cddr x)) )
    638                             (walk
    639                              `(##core#let
    640                                ,(##sys#map (lambda (b)
    641                                              (list (car b) '(##core#undefined)))
    642                                            bindings)
    643                                ,@(##sys#map (lambda (b)
    644                                               `(##core#set! ,(car b) ,(cadr b)))
    645                                             bindings)
    646                                (##core#let () ,@body) )
    647                             se dest)))
     644                        ((letrec ##core#letrec)
     645                         (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
     646                         (let ((bindings (cadr x))
     647                               (body (cddr x)) )
     648                           (walk
     649                            `(##core#let
     650                              ,(map (lambda (b)
     651                                      (list (car b) '(##core#undefined)))
     652                                    bindings)
     653                              ,@(map (lambda (b)
     654                                       `(##core#set! ,(car b) ,(cadr b)))
     655                                     bindings)
     656                              (##core#let () ,@body) )
     657                            e se dest)))
    648658
    649659                        ((lambda ##core#lambda)
     
    662672                                     (se2 (append (map cons vars aliases) se))
    663673                                     (body0 (##sys#canonicalize-body obody se2))
    664                                      (body (walk body0 se2 #f))
     674                                     (body (walk body0 (append aliases e) se2 #f))
    665675                                     (llist2
    666676                                      (build-lambda-list
     
    706716                           (walk
    707717                            (##sys#canonicalize-body (cddr x) se2)
    708                             se2
     718                            e se2
    709719                            dest) ) )
    710720                               
     
    725735                          (walk
    726736                           (##sys#canonicalize-body (cddr x) se2)
    727                            se2 dest)))
     737                           e se2 dest)))
    728738                               
    729739                       ((define-syntax)
     
    751761                                 (##sys#er-transformer ,body)) ;*** possibly wrong se?
    752762                               '(##core#undefined) )
    753                            se dest)) )
     763                           e se dest)) )
    754764
    755765                       ((define-compiled-syntax)
     
    776786                             (##sys#er-transformer
    777787                              ,body)) ;*** possibly wrong se?
    778                            se dest)))
     788                           e se dest)))
    779789
    780790                       ((##core#define-rewrite-rule)
     
    853863                                                 (cons (walk
    854864                                                        (car body)
     865                                                        e ;?
    855866                                                        (##sys#current-environment)
    856867                                                        #f)
     
    862873                                (map
    863874                                 (lambda (x)
    864                                    (walk x (##sys#current-meta-environment) #f) )
     875                                   (walk
     876                                    x
     877                                    e   ;?
     878                                    (##sys#current-meta-environment) #f) )
    865879                                 mreg))
    866880                              body)))))
    867881
    868882                       ((##core#named-lambda)
    869                         (walk `(,(macro-alias 'lambda se) ,@(cddr x)) se (cadr x)) )
     883                        (walk `(,(macro-alias 'lambda se) ,@(cddr x)) e se (cadr x)) )
    870884
    871885                       ((##core#loop-lambda)
     
    877891                                (walk
    878892                                 (##sys#canonicalize-body obody se2)
     893                                 (append aliases e)
    879894                                 se2 #f) ] )
    880895                          (set-real-names! aliases vars)
     
    901916                                               (,(third fv) ,type)
    902917                                               ,(foreign-type-check tmp type) ) )
    903                                            se #f))))
     918                                           e se #f))))
    904919                                 ((assq var location-pointer-map)
    905920                                  => (lambda (a)
     
    912927                                              ,(second a)
    913928                                              ,(foreign-type-check tmp type) ) )
    914                                           se #f))))
    915                                  (else
    916                                   (when (eq? var var0) ; global?
    917                                     (set! var (##sys#alias-global-hook var #t))
     929                                          e se #f))))
     930                                 (else
     931                                  (unless (memq var e) ; global?
     932                                    (set! var (or (##sys#get var '##core#primitive)
     933                                                  (##sys#alias-global-hook var #t)))
    918934                                    (when safe-globals-flag
    919935                                      (mark-variable var '##compiler#always-bound-to-procedure)
    920                                       (mark-variable var '##compiler#always-bound))
    921                                     (when (##sys#macro? var)
    922                                       (compiler-warning
    923                                        'var "assigned global variable `~S' is a macro ~A"
    924                                        var
    925                                        (if ln (sprintf "in line ~S" ln) "") )
    926                                       (when undefine-shadowed-macros (##sys#undefine-macro! var) ) ) )
     936                                      (mark-variable var '##compiler#always-bound)))
     937                                  (when (##sys#macro? var)
     938                                    (compiler-warning
     939                                     'var "assigned global variable `~S' is a macro ~A"
     940                                     var
     941                                     (if ln (sprintf "in line ~S" ln) "") )
     942                                    (when undefine-shadowed-macros (##sys#undefine-macro! var) ) )
    927943                                  (when (keyword? var)
    928944                                    (compiler-warning 'syntax "assignment to keyword `~S'" var) )
     
    930946                                    (syntax-error
    931947                                     'set! "assignment to syntactic identifier" var))
    932                                   `(set! ,var ,(walk val se var0))))))
     948                                  `(set! ,var ,(walk val e se var0))))))
    933949
    934950                        ((##core#inline)
    935                          `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) se)))
     951                         `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se)))
    936952
    937953                        ((##core#inline_allocate)
    938954                         `(##core#inline_allocate
    939955                           ,(map (cut unquotify <> se) (second x))
    940                            ,@(mapwalk (cddr x) se)))
     956                           ,@(mapwalk (cddr x) e se)))
    941957
    942958                        ((##core#inline_update)
    943                          `(##core#inline_update ,(cadr x) ,(walk (caddr x) se #f)) )
     959                         `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f)) )
    944960
    945961                        ((##core#inline_loc_update)
    946962                         `(##core#inline_loc_update
    947963                           ,(cadr x)
    948                            ,(walk (caddr x) se #f)
    949                            ,(walk (cadddr x) se #f)) )
     964                           ,(walk (caddr x) e se #f)
     965                           ,(walk (cadddr x) e se #f)) )
    950966
    951967                        ((##core#compiletimetoo ##core#elaborationtimetoo)
    952968                         (let ((exp (cadr x)))
    953969                           (eval/meta exp)
    954                            (walk exp se dest) ) )
     970                           (walk exp e se dest) ) )
    955971
    956972                        ((##core#compiletimeonly ##core#elaborationtimeonly)
     
    966982                                      [r (cdr xs)] )
    967983                                  (if (null? r)
    968                                       (list (walk x se dest))
    969                                       (cons (walk x se #f) (fold r)) ) ) ) )
     984                                      (list (walk x e se dest))
     985                                      (cons (walk x e se #f) (fold r)) ) ) ) )
    970986                             '(##core#undefined) ) )
    971987
    972988                        ((foreign-lambda)
    973                          (walk (expand-foreign-lambda x) se dest) )
     989                         (walk (expand-foreign-lambda x #f) e se dest) )
    974990
    975991                        ((foreign-safe-lambda)
    976                          (walk (expand-foreign-callback-lambda x) se dest) )
     992                         (walk (expand-foreign-lambda x #t) e se dest) )
    977993
    978994                        ((foreign-lambda*)
    979                          (walk (expand-foreign-lambda* x) se dest) )
     995                         (walk (expand-foreign-lambda* x #f) e se dest) )
    980996
    981997                        ((foreign-safe-lambda*)
    982                          (walk (expand-foreign-callback-lambda* x) se dest) )
     998                         (walk (expand-foreign-lambda* x #t) e se dest) )
    983999
    9841000                        ((foreign-primitive)
    985                          (walk (expand-foreign-primitive x) se dest) )
     1001                         (walk (expand-foreign-primitive x) e se dest) )
    9861002
    9871003                        ((define-foreign-variable)
    9881004                         (let* ([var (##sys#strip-syntax (second x))]
    989                                 [type (third x)]
     1005                                [type (##sys#strip-syntax (third x))]
    9901006                                [name (if (pair? (cdddr x))
    9911007                                          (fourth x)
     
    10011017                        ((define-foreign-type)
    10021018                         (let ([name (second x)]
    1003                                [type (third x)]
     1019                               [type (##sys#strip-syntax (third x))]
    10041020                               [conv (cdddr x)] )
    10051021                           (cond [(pair? conv)
     
    10171033                                         ,ret
    10181034                                         ,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
    1019                                      se dest) ) ]
     1035                                     e se dest) ) ]
    10201036                                 [else
    10211037                                  (##sys#hash-table-set! foreign-type-table name type)
     
    10381054                        ((##core#let-location)
    10391055                         (let* ([var (second x)]
    1040                                 [type (third x)]
     1056                                [type (##sys#strip-syntax (third x))]
    10411057                                [alias (gensym)]
    10421058                                [store (gensym)]
     
    10591075                                      '() )
    10601076                                ,(if init (fifth x) (fourth x)) ) )
    1061                             (alist-cons var alias se)
     1077                            e (alist-cons var alias se)
    10621078                            dest) ) )
    10631079
     
    10921108                                    (mark-variable var '##compiler#constant)
    10931109                                    (mark-variable var '##compiler#always-bound)
    1094                                     (walk `(define ,var ',val) se #f) ) ] ) ) )
     1110                                    (walk `(define ,var ',val) e se #f) ) ] ) ) )
    10951111
    10961112                        ((##core#declare)
     
    11001116                                      (process-declaration d se))
    11011117                                    (cdr x) ) )
    1102                           '() #f) )
     1118                          e '() #f) )
    11031119             
    11041120                        ((##core#foreign-callback-wrapper)
     
    11201136                                vars atypes) )
    11211137                             `(##core#foreign-callback-wrapper
    1122                                ,@(mapwalk args se)
     1138                               ,@(mapwalk args e se)
    11231139                               ,(walk `(##core#lambda
    11241140                                        ,vars
     
    11751191                                                (else (cddr lam)) ) )
    11761192                                           rtype) ) )
    1177                                       se #f) ) ) ) )
     1193                                      e se #f) ) ) ) )
    11781194
    11791195                        (else
    11801196                         (let ([handle-call
    11811197                                (lambda ()
    1182                                   (let* ([x2 (mapwalk x se)]
     1198                                  (let* ([x2 (mapwalk x e se)]
    11831199                                         [head2 (car x2)]
    11841200                                         [old (##sys#hash-table-ref line-number-database-2 head2)] )
     
    11981214                                                    (walk
    11991215                                                     `(##sys#make-locative ,(second a) 0 #f 'location)
    1200                                                      se #f) ) ]
     1216                                                     e se #f) ) ]
    12011217                                              [(assq sym external-to-pointer)
    1202                                                => (lambda (a) (walk (cdr a) se #f)) ]
     1218                                               => (lambda (a) (walk (cdr a) e se #f)) ]
    12031219                                              [(memq sym callback-names)
    12041220                                               `(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
    12051221                                              [else
    1206                                                (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ] )
    1207                                         (walk `(##sys#make-locative ,sym 0 #f 'location) se #f) ) ) ]
     1222                                               (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ] )
     1223                                        (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ) ) ]
    12081224                                 
    12091225                                 [else (handle-call)] ) ) ) ) ] ) ) ) )
     
    12151231           (emit-syntax-trace-info x #f)
    12161232           (compiler-warning 'syntax "literal in operator position: ~S" x)
    1217            (mapwalk x se) )
     1233           (mapwalk x e se) )
    12181234
    12191235          ((and (pair? (car x))
     
    12271243               (if (and (proper-list? llist) (= (llist-length llist) (length args)))
    12281244                   (walk `(,(macro-alias 'let se)
    1229                            ,(map list llist args) ,@(cddr lexp)) se dest)
     1245                           ,(map list llist args) ,@(cddr lexp))
     1246                         e se dest)
    12301247                   (let ((var (gensym 't)))
    12311248                     (walk
     
    12331250                        ((,var ,(car x)))
    12341251                        (,var ,@(cdr x)) )
    1235                       se dest) ) ) ) ) )
     1252                      e se dest) ) ) ) ) )
    12361253         
    12371254          (else
    12381255           (emit-syntax-trace-info x #f)
    1239            (mapwalk x se)) ) )
     1256           (mapwalk x e se)) ) )
    12401257 
    1241   (define (mapwalk xs se)
    1242     (map (lambda (x) (walk x se #f)) xs) )
     1258  (define (mapwalk xs e se)
     1259    (map (lambda (x) (walk x e se #f)) xs) )
    12431260
    12441261  (when (memq 'c debugging-chicken) (newline) (pretty-print exp))
     
    12531270         (set! extended-bindings (append internal-bindings extended-bindings))
    12541271         exp) )
    1255    (##sys#current-environment)
     1272   '() (##sys#current-environment)
    12561273   #f) )
    12571274
     
    13821399                    (set! extended-bindings (lset-difference eq? default-extended-bindings syms)) ) ] ) ]
    13831400          ((inline-global)
     1401           (set! enable-inline-files #t)
    13841402           (if (null? (cddr spec))
    13851403               (set! inline-globally #f)
     
    14601478                (stripa (cdr spec))))))
    14611479       ((inline-global)
     1480        (set! enable-inline-files #t)
     1481        (set! inline-locally #t)
    14621482        (if (null? (cdr spec))
    14631483            (set! inline-globally #t)
     
    14951515
    14961516(define (create-foreign-stub rtype sname argtypes argnames body callback cps)
    1497   (let* ([params (list-tabulate (length argtypes) (lambda (x) (gensym 'a)))]
     1517  (let* ((rtype (##sys#strip-syntax rtype))
     1518         (argtypes (##sys#strip-syntax argtypes))
     1519         [params (list-tabulate (length argtypes) (lambda (x) (gensym 'a)))]
    14981520         [f-id (gensym 'stub)]
    14991521         [bufvar (gensym)]
     
    15201542                     rtype) ) ) ) ) ) ) )
    15211543
    1522 (define (expand-foreign-lambda exp)
     1544(define (expand-foreign-lambda exp callback?)
    15231545  (let* ([name (third exp)]
    1524          [sname (cond ((symbol? name) (symbol->string name))
     1546         [sname (cond ((symbol? name) (symbol->string (##sys#strip-syntax name)))
    15251547                      ((string? name) name)
    15261548                      (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
    15271549         [rtype (second exp)]
    15281550         [argtypes (cdddr exp)] )
    1529     (create-foreign-stub rtype sname argtypes #f #f #f #f) ) )
    1530 
    1531 (define (expand-foreign-callback-lambda exp)
    1532   (let* ([name (third exp)]
    1533          [sname (cond ((symbol? name) (symbol->string name))
    1534                       ((string? name) name)
    1535                       (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
    1536          [rtype (second exp)]
    1537          [argtypes (cdddr exp)] )
    1538     (create-foreign-stub rtype sname argtypes #f #f #t #t) ) )
    1539 
    1540 (define (expand-foreign-lambda* exp)
     1551    (create-foreign-stub rtype sname argtypes #f #f callback? callback?) ) )
     1552
     1553(define (expand-foreign-lambda* exp callback?)
    15411554  (let* ([rtype (second exp)]
    15421555         [args (third exp)]
    15431556         [body (apply string-append (cdddr exp))]
    15441557         [argtypes (map car args)]
    1545          [argnames (map cadr args)] )
    1546     (create-foreign-stub rtype #f argtypes argnames body #f #f) ) )
    1547 
    1548 (define (expand-foreign-callback-lambda* exp)
    1549   (let* ([rtype (second exp)]
    1550          [args (third exp)]
    1551          [body (apply string-append (cdddr exp))]
    1552          [argtypes (map car args)]
    1553          [argnames (map cadr args)] )
    1554     (create-foreign-stub rtype #f argtypes argnames body #t #t) ) )
    1555 
     1558         ;; C identifiers aren't hygienically renamed inside body strings
     1559         [argnames (map cadr (##sys#strip-syntax args))] )
     1560    (create-foreign-stub rtype #f argtypes argnames body callback? callback?) ) )
     1561
     1562;; TODO: Try to fold this procedure into expand-foreign-lambda*
    15561563(define (expand-foreign-primitive exp)
    15571564  (let* ([hasrtype (and (pair? (cddr exp)) (not (string? (caddr exp))))]
    15581565         [rtype (if hasrtype (second exp) 'void)]
    1559          [args (if hasrtype (third exp) (second exp))]
     1566         [args (##sys#strip-syntax (if hasrtype (third exp) (second exp)))]
    15601567         [body (apply string-append (if hasrtype (cdddr exp) (cddr exp)))]
    15611568         [argtypes (map car args)]
    1562          [argnames (map cadr args)] )
     1569         ;; C identifiers aren't hygienically renamed inside body strings
     1570         [argnames (map cadr (##sys#strip-syntax args))] )
    15631571    (create-foreign-stub rtype #f argtypes argnames body #f #t) ) )
    15641572
  • chicken/branches/scrutiny/csc.scm

    r14529 r14827  
    279279    -h  -help                      display this text and exit
    280280    -v                             show intermediate compilation stages
    281     -v2  -verbose                  display information about translation
     281    -vv  -verbose                  display information about translation
    282282                                    progress
    283     -v3                            display information about all compilation
     283    -vvv                           display information about all compilation
    284284                                    stages
    285285    -V  -version                   display Scheme compiler version and exit
     
    435435    -raw                           do not generate implicit init- and exit code
    436436    -emit-external-prototypes-first
    437                                    emit protoypes for callbacks before foreign
     437                                   emit prototypes for callbacks before foreign
    438438                                    declarations
    439439    -ignore-repository             do not refer to repository for extensions
     
    563563                (set! show-libs #t) ]
    564564               [(-v)
    565                 (set! verbose #t) ]
    566                [(-v2 -verbose)
     565                (when (and (number? verbose) (not msvc))
     566                  (set! compile-options (cons* "-v" "-Q" compile-options))
     567                  (set! link-options (cons (if msvc "-VERBOSE" "-v") link-options)) )
     568                (cond (verbose
     569                       (t-options "-verbose")
     570                       (set! verbose 2))
     571                      (else (set! verbose #t))) ]
     572               [(-v2 -verbose)          ; DEPRECATED
    567573                (set! verbose #t)
    568574                (t-options "-verbose") ]
    569                [(-w -no-warnings)
    570                 (set! compile-options (cons "-w" compile-options))
    571                 (t-options "-no-warnings") ]
    572                [(-v3)
     575               [(-v3)                   ; DEPRECATED
    573576                (set! verbose #t)
    574577                (t-options "-verbose")
     
    576579                    (set! compile-options (cons* "-v" "-Q" compile-options)))
    577580                (set! link-options (cons (if msvc "-VERBOSE" "-v") link-options)) ]
     581               [(-w -no-warnings)
     582                (set! compile-options (cons "-w" compile-options))
     583                (t-options "-no-warnings") ]
    578584               [(|-A| -analyze-only)
    579585                (set! translate-only #t)
  • chicken/branches/scrutiny/eval.scm

    r14525 r14827  
    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#>
  • chicken/branches/scrutiny/expand.scm

    r14628 r14827  
    4848
    4949(cond-expand
    50  (chicken   ;(not debugbuild)
    51   #;(declare
    52     (no-bound-checks)
    53     (no-procedure-checks))
    54   (define-syntax dd (syntax-rules () ((_ . _) (void))))
    55   (define-syntax dm (syntax-rules () ((_ . _) (void)))))
     50 ((not debugbuild)
     51  (begin
     52    (declare
     53      (no-bound-checks)
     54      (no-procedure-checks))
     55    (define-syntax dd (syntax-rules () ((_ . _) (void))))
     56    (define-syntax dm (syntax-rules () ((_ . _) (void))))))
    5657 (else))
    5758
     
    8485        alias) ) )
    8586
     87#+debugbuild
    8688(define (map-se se)
    8789  (map (lambda (a)
     
    9092
    9193(define (##sys#strip-syntax exp #!optional se alias)
    92   ;; if se is given, retain bound vars
    93   (let walk ((x exp))
    94     (cond ((symbol? x)
    95            (let ((x2 (if se
    96                          (lookup x se)
    97                          (get x '##core#macro-alias) ) ) )
    98              (cond ((get x '##core#real-name))
    99                    ((and alias (not (assq x se)))
    100                     (##sys#alias-global-hook x #f))
    101                    ((not x2) x)
    102                    ((pair? x2) x)
    103                    (else x2))))
    104           ((pair? x)
    105            (cons (walk (car x))
    106                  (walk (cdr x))))
    107           ((vector? x)
    108            (list->vector (map walk (vector->list x))))
    109           (else x))))
     94 ;; if se is given, retain bound vars
     95 (let ((seen '()))
     96   (let walk ((x exp))
     97     (cond ((assq x seen) => cdr)
     98           ((symbol? x)
     99            (let ((x2 (if se
     100                          (lookup x se)
     101                          (get x '##core#macro-alias) ) ) )
     102              (cond ((get x '##core#real-name))
     103                    ((and alias (not (assq x se)))
     104                     (##sys#alias-global-hook x #f))
     105                    ((not x2) x)
     106                    ((pair? x2) x)
     107                    (else x2))))
     108           ((pair? x)
     109            (let ((cell (cons #f #f)))
     110              (set! seen (cons (cons x cell) seen))
     111              (set-car! cell (walk (car x)))
     112              (set-cdr! cell (walk (cdr x)))
     113              cell))
     114           ((vector? x)
     115            (let* ((len (##sys#size x))
     116                   (vec (make-vector len)))
     117              (set! seen (cons (cons x vec) seen))
     118              (do ((i 0 (fx+ i 1)))
     119                  ((fx>= i len) vec)
     120                (##sys#setslot vec i (##sys#slot x i)))))
     121           (else x)))))
    110122
    111123(define strip-syntax ##sys#strip-syntax)
     
    383395            (%let-optionals* (macro-alias 'let-optionals* se))
    384396            (%let (macro-alias 'let se)))
    385         (let loop ([mode 0]             ; req, opt, rest, key, end
     397        (let loop ([mode 0]             ; req=0, opt=1, rest=2, key=3, end=4
    386398                   [req '()]
    387399                   [opt '()]
     
    420432                     (err "rest argument list specified more than once")
    421433                     (begin
    422                        (if (not rvar) (set! rvar llist))
     434                       (unless rvar (set! rvar llist))
    423435                       (set! hasrest llist)
    424436                       (loop 4 req opt '() '()) ) ) ]
     
    427439                [else
    428440                 (let* ((var (car llist))
    429                         (x (or (and (symbol? var) (lookup var se)) var))
     441                        (x (or (and (symbol? var) (not (eq? 3 mode)) (lookup var se)) var))
    430442                        (r (cdr llist)))
    431443                   (case x
    432444                     [(#!optional)
    433                       (if (not rvar) (set! rvar (macro-alias 'tmp se)))
     445                      (unless rvar (set! rvar (macro-alias 'tmp se)))
    434446                      (if (eq? mode 0)
    435447                          (loop 1 req '() '() r)
     
    523535                     (cdr body)
    524536                     (cons (if (pair? (cadr def))
    525                                `(define-syntax ,(caadr def) (,(macro-alias 'lambda se) ,(cdadr def) ,@(cddr def)))
     537                               `(define-syntax ,(caadr def)
     538                                  (,(macro-alias 'lambda se) ,(cdadr def) ,@(cddr def)))
    526539                               def)
    527540                           defs)
     
    720733
    721734;;; explicit-renaming transformer
     735
     736(define (er-macro-transformer x) x)
    722737
    723738(define ((##sys#er-transformer handler) form se dse)
     
    907922                (and-let* ((a (assq id (import-env)))
    908923                           ((not (eq? aid (cdr a)))))
    909                   (##sys#warn "re-importing already imported identfier" id))))
     924                  (##sys#warn "re-importing already imported identifier" id))))
    910925            vsv)
    911926           (for-each
     
    12491264    `(##core#module
    12501265      ,(cadr x)
    1251       ,(if (c (r '*) (caddr x))
     1266      ,(if (eq? '* (strip-syntax (caddr x)))
    12521267           #t
    12531268           (caddr x))
     
    15171532  (define (find-reexport name)
    15181533    (let ((a (assq name (##sys#macro-environment))))
    1519       (if (pair? (cdr a))
     1534      (if (and a (pair? (cdr a)))
    15201535          a
    15211536          (##sys#error
  • chicken/branches/scrutiny/extras.scm

    r13965 r14827  
    205205           (set! start (fx+ start 1)) )
    206206         (let ((rdstring (##sys#slot (##sys#slot port 2) 7)))
    207            (let loop ((start start) (n n) (m 0))
    208              (let ((n2 (if rdstring
    209                            (rdstring port n dest start) ; *** doesn't update port-position!
    210                            (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)))
    211218                             (if (eof-object? c)
    212219                                 0
    213220                                 (begin
    214221                                   (##core#inline "C_setsubchar" dest start c)
    215                                    1) ) ) ) ) )
    216                (cond ((eq? n2 0) m)
    217                     ((or (not n) (fx< n2 n))
    218                       (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)) )
    219                      (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))) )))))))
    220227
    221228(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
     
    229236  (##sys#read-string! n dest port start) )
    230237
     238(define-constant read-string-buffer-size 2048)
    231239(define ##sys#read-string/port
    232240  (let ((open-output-string open-output-string)
     
    241249                     (##sys#substring str 0 n2))))
    242250            (else
    243              (let ([str (open-output-string)])
    244                (let loop ([n n])
    245                  (or (and (eq? n 0) (get-output-string str))
    246                      (let ([c (##sys#read-char-0 p)])
    247                        (if (eof-object? c)
    248                            (get-output-string str)
    249                            (begin
    250                              (##sys#write-char/port c str)
    251                              (loop (and n (fx- n 1))) ) ) ) ) ) ) ) ) ) ) )
     251             (let ([out (open-output-string)]
     252                   (buf (make-string read-string-buffer-size)))
     253               (let loop ()
     254                 (let ((n (##sys#read-string! read-string-buffer-size
     255                                              buf p 0)))
     256                   (cond ((eq? n 0)
     257                          (get-output-string out))
     258                         (else
     259                          (write-string buf n out)
     260                          (loop)))))))))))
    252261
    253262(define (read-string #!optional n (port ##sys#standard-input))
  • chicken/branches/scrutiny/irregex.import.scm

    r13169 r14827  
    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/scrutiny/irregex.scm

    r13151 r14827  
    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/scrutiny/library.scm

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

    r13965 r14827  
    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, Leonardo
    27 Valeri Manera, Dennis Marti, Charles Martin, Bob McIsaac, Alain
    28 Mellan, Eric Merrit, Perry Metzger, Scott G. Miller, Mikael, Bruce
    29 Mitchener, Chris Moline, Eric E. Moore, Julian Morrison, Dan Muresan,
    30 Lars Nilsson, Ian Oversby, o.t., Gene Pavlovsky, Levi Pearson, Nicolas
    31 Pelletier, Carlos Pita, Robin Lee Powell, Pupeno, Davide Puricelli,
    32 Doug Quale, Eric Raible, Ivan Raikov, Joel Reymont, Eric Rochester,
    33 Andreas Rottman, David Rush, Lars Rustemeier, Daniel Sadilek, Oskar
    34 Schirmer, Burton Samograd, Reed Sheridan, Ronald Schroeder, Spencer
    35 Schumann, Ivan Shcheklein, Alex Shinn, Ivan Shmakov, Shmul, Tony
    36 Sidaway, Jeffrey B. Siegal, Andrey Sidorenko, Michele Simionato,
    37 Volker Stolz, Jon Strait, Dorai Sitaram, Robert Skeels, Jason
    38 Songhurst, Clifford Stein, Sunnan, Zbigniew Szadkowski, Rick Taube,
    39 Nathan Thern, Mike Thomas, Minh Thu, Christian Tismer, Andre van
    40 Tonder, John Tobey, Henrik Tramberend, Vladimir Tsichevsky, Neil van
    41 Dyke, Taylor Venable, Sander Vesik, Jaques Vidrine, Panagiotis Vossos,
    42 Shawn Wagner, Peter Wang, Ed Watkeys, Brad Watson, Thomas Weidner,
    43 Goeran Weinholt, Matthew Welland, Drake Wilson, Joerg Wittenberger,
    44 Peter Wright, Mark Wutka, Richard Zidlicky and Houman Zolfaghari for
    45 bug-fixes, tips and suggestions.
     11Franklin Chen, Thomas Chust, Gian Paolo Ciceri, Fulvio Ciriaco, Tobia
     12Conforto, John Cowan, Grzegorz Chrupa&#322;a, James Crippen, Tollef
     13Fog Heen, Drew Hess, Alejandro Forero Cuervo, Linh Dang, Brian
     14Denheyer, dgym, Don, Chris Double, Brown Dragon, Jarod Eells, Petter
     15Egesund, Steve Elkins, Daniel B. Faken, Will Farr, Graham Fawcett,
     16Marc Feeley, Fizzie, Matthew Flatt, Kimura Fuyuki, Tony Garnock-Jones,
     17Martin Gasbichler, Joey Gibson, Stephen C. Gilardi, Joshua Griffith,
     18Johannes Groedem, Damian Gryski, Mario Domenech Goulart, Andreas
     19Gustafsson, Sven Hartrumpf, Jun-ichiro itojun Hagino, Ahdi Hargo,
     20Matthias Heiler, Karl M. Hegbloom, William P. Heinemann, Bill Hoffman,
     21Bruce Hoult, Hans Huebner, Markus Huelsmann, Goetz Isenmann, Paulo
     22Jabardo, Wietse Jacobs, David Janssens, Christian Jaeger, Matt Jones,
     23Dale Jordan, Valentin Kamyshenko, Daishi Kato, Peter Keller, Brad
     24Kind, Ron Kneusel, Matthias Koeppe, Krysztof Kowa&#322;czyk, Andre
     25Kuehne, Todd R. Kueny Sr, Goran Krampe, David Krentzlin, Ben Kurtz,
     26Micky Latowicki, John Lenz, Kirill Lisovsky, Juergen Lorenz, Kon
     27Lovett, Lam Luu, Leonardo Valeri Manera, Dennis Marti, Charles Martin,
     28Bob McIsaac, Alain Mellan, Eric Merrit, Perry Metzger, Scott
     29G. Miller, Mikael, Bruce Mitchener, Chris Moline, Eric E. Moore,
     30Julian Morrison, Dan Muresan, Lars Nilsson, Ian Oversby, o.t., Gene
     31Pavlovsky, Levi Pearson, Nicolas Pelletier, Carlos Pita, Robin Lee
     32Powell, Pupeno, Davide Puricelli, presto, Doug Quale, Eric Raible,
     33Ivan Raikov, Joel Reymont, Eric Rochester, Andreas Rottman, David
     34Rush, Lars Rustemeier, Daniel Sadilek, Oskar Schirmer, Burton
     35Samograd, Reed Sheridan, Ronald Schroeder, Spencer Schumann, Ivan
     36Shcheklein, Alex Shinn, Ivan Shmakov, Shmul, Tony Sidaway, Jeffrey
     37B. Siegal, Andrey Sidorenko, Michele Simionato, Volker Stolz, Jon
     38Strait, Dorai Sitaram, Robert Skeels, Jason Songhurst, Clifford Stein,
     39Sunnan, Zbigniew Szadkowski, Rick Taube, Nathan Thern, Mike Thomas,
     40Minh Thu, Christian Tismer, Andre van Tonder, John Tobey, Henrik
     41Tramberend, Vladimir Tsichevsky, Neil van Dyke, Taylor Venable, Sander
     42Vesik, Jaques Vidrine, Panagiotis Vossos, Shawn Wagner, Peter Wang, Ed
     43Watkeys, Brad Watson, Thomas Weidner, Goeran Weinholt, Matthew
     44Welland, Drake Wilson, Joerg Wittenberger, Peter Wright, Mark Wutka,
     45Richard Zidlicky and Houman Zolfaghari for bug-fixes, tips and
     46suggestions.
    4647
    4748CHICKEN uses the "irregex" regular expression package written by Alex Shinn.
  • chicken/branches/scrutiny/manual/Callbacks

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

    r14804 r14827  
    148148{{.inline}} files (if available in the current include path) and inlined
    149149in the current compilation unit.
     150
     151Enabling global inlining implies {{(declare (inline))}}.
    150152
    151153
  • chicken/branches/scrutiny/manual/Modules and macros

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

    r13965 r14827  
    55== The CHICKEN User's Manual
    66
    7 This is the user's manual for the Chicken Scheme compiler, version 4.0.1x1
     7This is the user's manual for the Chicken Scheme compiler, version 4.0.5
    88
    99; [[Getting started]] : What is CHICKEN and how do I use it?
  • chicken/branches/scrutiny/manual/Unit srfi-13

    r13965 r14827  
    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/scrutiny/manual/Unit srfi-14

    r13965 r14827  
    1616
    1717---
    18 Previous: [[Unit srfi-18]]
     18Previous: [[Unit srfi-13]]
    1919
    20 Next: [[Unit srfi-69]]
     20Next: [[Unit srfi-18]]
  • chicken/branches/scrutiny/manual/Unit srfi-18

    r13965 r14827  
    103103Previous: [[Unit srfi-14]]
    104104
    105 Next: [[Unit posix]]
     105Next: [[Unit srfi-69]]
  • chicken/branches/scrutiny/manual/Unit srfi-69

    r13965 r14827  
    317317==== string-hash
    318318
    319  [procedure] (string-hash STRING [BOUND])
     319 [procedure] (string-hash STRING [BOUND START END])
    320320
    321321For use with {{string=?}} as a {{hash-table-equivalence-function}}.
     322The optional {{START}} and {{END}} arguments may be given to limit
     323the hash calculation to a specific sub-section of {{STRING}}.
    322324
    323325
    324326==== string-ci-hash
    325327
    326  [procedure] (string-ci-hash STRING [BOUND])
     328 [procedure] (string-hash-ci STRING [BOUND START END])
     329 [procedure] (string-ci-hash STRING [BOUND START END])
    327330
    328331For use with {{string-ci=?}} as a {{hash-table-equivalence-function}}.
  • chicken/branches/scrutiny/manual/Using the compiler

    r14529 r14827  
    4949     c          print every expression before macro-expansion
    5050     u          lists all unassigned global variable references
     51     d          lists all assigned global variables
    5152     x          display information about experimental features
    5253     D          when printing nodes, use node-tree output
     
    122123; -inline : Enable procedure inlining for known procedures of a size below the threshold (which can be set through the {{-inline-limit}} option).
    123124
    124 ; -inline-global : Enable cross-module inlining (in addition to local inlining).
     125; -inline-global : Enable cross-module inlining (in addition to local inlining). Implies {{-inline}}. For more information, see also [[Declarations]].
    125126
    126127; -inline-limit THRESHOLD : Sets the maximum size of a potentially inlinable procedure. The default threshold is {{20}}.
  • chicken/branches/scrutiny/posix.import.scm

    r12937 r14827  
    114114   file-permissions
    115115   file-position
     116   set-file-position!
    116117   file-read
    117118   file-read-access?
  • chicken/branches/scrutiny/posixunix.scm

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

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

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

    r13965 r14827  
    4848    irregex-match-num-submatches
    4949    irregex-search irregex-search/matches irregex-match irregex-match-string
    50     irregex-replace irregex-replace/all
     50    irregex-fold irregex-replace irregex-replace/all irregex-apply-match
    5151    irregex-dfa irregex-dfa/search irregex-dfa/extract
    5252    irregex-nfa irregex-flags irregex-submatches irregex-lengths irregex-names
  • chicken/branches/scrutiny/runtime.c

    r13965 r14827  
    40344034C_regparm C_word C_fcall C_read_char(C_word port)
    40354035{
    4036   int c = C_fgetc(C_port_file(port));
     4036  int c = C_getc(C_port_file(port));
    40374037
    40384038  return c == EOF ? C_SCHEME_END_OF_FILE : C_make_character(c);
     
    40434043{
    40444044  C_FILEPTR fp = C_port_file(port);
    4045   int c = C_fgetc(fp);
     4045  int c = C_getc(fp);
    40464046
    40474047  C_ungetc(c, fp);
  • chicken/branches/scrutiny/scheme-complete.el

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

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

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

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

    r13965 r14827  
    4040  (import extras regex posix utils srfi-1 data-structures tcp srfi-13 files setup-api)
    4141
    42   (tcp-connect-timeout 10000)           ; 10 seconds
    43   (tcp-read-timeout 10000)
    44   (tcp-write-timeout 10000)
     42  (define-constant +default-tcp-connect-timeout+ 10000) ; 10 seconds
     43  (define-constant +default-tcp-read/write-timeout+ 20000) ; 20 seconds
     44
     45  (tcp-connect-timeout +default-tcp-connect-timeout+)
     46  (tcp-read-timeout +default-tcp-read/write-timeout+)
     47  (tcp-write-timeout +default-tcp-read/write-timeout+)
    4548
    4649  (define *quiet* #f)
     
    214217       (make-HTTP-GET/1.1 locn *chicken-install-user-agent* host port: port accept: "*/*")
    215218       out)
    216       (close-output-port out)
     219      (flush-output out)
    217220      (d "reading response ...~%")
    218221      (let ([chunked #f])
     
    241244                [(or (eof-object? name) (not name))
    242245                 (close-input-port in)
     246                 (close-output-port out)
    243247                 (reverse files) ]
    244248                [(not (string? name))
  • chicken/branches/scrutiny/site/index.html

    r13965 r14827  
    110110
    111111<center>
    112 <img src="chicken-new.png">
     112<img src="chicken4-low.png">
    113113<div style="width: 70%; margin: 3em;">
    114 <font size="5"><em><span>CHICKEN - A practical and portable Scheme system</span></em></font>
    115114
    116115<p class="block" style="margin: 3em;">
     
    144143<li>Support for a large number of <a href="http://srfi.schemers.org/">Scheme Requests For Implementation</a> (SRFIs)
    145144<li>Many libraries and extensions are available
    146 at <a href="http://www.call-with-current-continuation.org/eggs/">"Eggs
    147 unlimited"</a>
     145at <a href="http://chicken.wiki.br/chicken-projects/egg-index-4.html">"Eggs Unlimited"</a>
    148146</ul>
    149147</p>
     
    159157<h3>DOCUMENTATION</h3>
    160158<p>
    161 Browse the <a href="http://chicken.wiki.br/The User's Manual">User's manual</a> at the CHICKEN
     159Browse the <a href="http://chicken.wiki.br/man/4/">User's manual</a> at the CHICKEN
    162160<a href="http://chicken.wiki.br/">wiki</a>
    163161</p>
     
    181179</pre>
    182180(username: <tt>anonymous</tt>, password: &lt;none&gt;)
     181<p>
     182The CHICKEN bug tracking system is located <a href="http://www.irp.oist.jp/trac/chicken/"/>here.</a></p>
     183</p>
    183184</p>
    184185
  • chicken/branches/scrutiny/srfi-13.import.scm

    r12937 r14827  
    6262   string-for-each
    6363   string-for-each-index
    64    string-hash
    65    string-hash-ci
    6664   string-index
    6765   string-index-right
  • chicken/branches/scrutiny/srfi-13.scm

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

    r12937 r14827  
    6666   number-hash
    6767   object-uid-hash
     68   string-hash-ci
    6869   string-ci-hash
    6970   string-hash
  • chicken/branches/scrutiny/srfi-69.scm

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

    r14529 r14827  
    3232  compiler-arguments process-command-line dump-nodes dump-undefined-globals
    3333  default-standard-bindings default-extended-bindings
    34   foldable-bindings compiler-macro-environment
     34  foldable-bindings compiler-macro-environment dump-defined-globals
    3535  installation-home optimization-iterations compiler-cleanup-hook decompose-lambda-list
    3636  file-io-only banner disabled-warnings internal-bindings
     
    814814   db) )
    815815
     816(define (dump-defined-globals db)
     817  (##sys#hash-table-for-each
     818   (lambda (sym plist)
     819     (when (and (assq 'global plist)
     820                (assq 'assigned plist))
     821       (write sym)
     822       (newline) ) )
     823   db) )
     824
    816825
    817826;;; change hook function to hide non-exported module bindings
     
    948957             [(nonnull-c-pointer)
    949958              `(##sys#foreign-pointer-argument ,param) ]
    950              [(c-string c-string* unsigned-c-string*)
     959             [(c-string c-string* unsigned-c-string unsigned-c-string*)
    951960              (let ([tmp (gensym)])
    952961                `(let ([,tmp ,param])
     
    10321041        0)
    10331042       ((c-string nonnull-c-string c-pointer nonnull-c-pointer symbol c-string* nonnull-c-string*
    1034                   unsigned-c-string* nonnull-unsigned-c-string*
     1043                  unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
    10351044                  c-string-list c-string-list*)
    10361045        (words->bytes 3) )
     
    10611070              c-pointer pointer nonnull-c-pointer unsigned-integer integer float c-string symbol
    10621071              scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer32
    1063               unsigned-c-string* nonnull-unsigned-c-string*
     1072              unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
    10641073              nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*) ; pointer and nonnull-pointer are DEPRECATED
    10651074        (words->bytes 1) )
     
    10821091(define (finish-foreign-result type body)
    10831092  (case type
    1084     [(c-string) `(##sys#peek-c-string ,body '0)]
     1093    [(c-string unsigned-c-string) `(##sys#peek-c-string ,body '0)]
    10851094    [(nonnull-c-string) `(##sys#peek-nonnull-c-string ,body '0)]
    10861095    [(c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body '0)]
     
    13361345    -raw                         do not generate implicit init- and exit code                           
    13371346    -emit-external-prototypes-first
    1338                                  emit protoypes for callbacks before foreign
     1347                                 emit prototypes for callbacks before foreign
    13391348                                  declarations
    13401349    -ignore-repository           do not refer to repository for extensions
  • chicken/branches/scrutiny/tcp.scm

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

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

    r11038 r14827  
    44(define-for-syntax count 0)
    55(define-syntax trail
     6  (er-macro-transformer
    67  (lambda (form r c)                    ; doesn't bother much with renaming
    78    (let ((loc (cadr form))
     
    1213        (let ((xxx ,expr))
    1314          (print "  (" ,count ") " ,loc ": " ',expr ": get: " (##sys#slot get-mutex 5) ", put: " (##sys#slot put-mutex 5))
    14           xxx) ) ))))
     15          xxx) ) )))))
    1516(else (define-syntax trail (syntax-rules () ((_ loc expr) expr)))))
    1617
  • chicken/branches/scrutiny/tests/syntax-tests.scm

    r13965 r14827  
    212212
    213213(define-syntax loop
    214   (lambda (x r c)
    215     (let ((body (cdr x)))
    216       `(,(r 'call/cc)
    217         (,(r 'lambda) (exit)
    218          (,(r 'let) ,(r 'f) () ,@body (,(r 'f))))))))
     214  (er-macro-transformer
     215   (lambda (x r c)
     216     (let ((body (cdr x)))
     217       `(,(r 'call/cc)
     218         (,(r 'lambda) (exit)
     219          (,(r 'let) ,(r 'f) () ,@body (,(r 'f)))))))))
    219220
    220221(let ((n 10))
     
    234235
    235236(define-syntax while
    236   (lambda (x r c)
    237     `(,(r 'loop)
    238       (,(r 'if) (,(r 'not) ,(cadr x)) (exit #f))
    239       ,@(cddr x))))
     237  (er-macro-transformer
     238   (lambda (x r c)
     239     `(,(r 'loop)
     240       (,(r 'if) (,(r 'not) ,(cadr x)) (exit #f))
     241       ,@(cddr x)))))
    240242
    241243(let ((n 10))
     
    303305(assert (equal? (foo (1 2) (3) (5 6)) '(((1 2)) ((3)) ((5 6))))) ; failed
    304306(assert (equal? (foo 1) '((1))))
     307
     308
     309;;; incorrect lookup for keyword variables in DSSSL llists
     310
     311(module broken-keyword-var ()
     312  (import scheme chicken)
     313  ((lambda (#!key string) (assert (not string))))) ; refered to R5RS `string'
     314
     315
     316;;; compiler didn't resolve expansion into local variable
     317;;; (reported by Alex Shinn, #15)
     318
     319(module unresolve-local (foo)
     320  (import scheme)
     321  (define (foo)
     322    (let ((qux 3))
     323      (let-syntax ((bar (syntax-rules () ((bar) qux))))
     324        (bar))))
     325
     326  (display (foo))
     327  (newline)
     328)
     329
     330
     331;;; incorrect expansion when assigning to something marked '##core#primitive (rev. 14613)
     332
     333(define x 99)
     334
     335(module primitive-assign ()
     336  (import scheme chicken)
     337  (let ((x 100)) (set! x 20) (assert (= x 20)))
     338  (set! setter 123))
     339
     340(assert (= x 99))
     341(assert (= 123 setter))
     342
  • chicken/branches/scrutiny/version.scm

    r13965 r14827  
    1 (define-constant +build-version+ "4.0.1x1")
     1(define-constant +build-version+ "4.0.5")
Note: See TracChangeset for help on using the changeset viewer.