Changeset 10653 in project


Ignore:
Timestamp:
04/30/08 06:48:13 (12 years ago)
Author:
Ivan Raikov
Message:

Merged prerelease and release branches.

Location:
chicken/branches/release
Files:
1 deleted
55 edited
5 copied

Legend:

Unmodified
Added
Removed
  • chicken/branches/release/Makefile.bsd

    r10108 r10653  
    8585        echo "#define C_NO_APPLY_HOOK" >>$@
    8686endif
    87 ifdef HACKED_APPLY
     87ifneq ($(HACKED_APPLY),)
    8888        echo "#define C_HACKED_APPLY" >>$@
    8989endif
  • chicken/branches/release/Makefile.linux

    r10108 r10653  
    9090        echo "#define C_NO_APPLY_HOOK" >>$@
    9191endif
    92 ifdef HACKED_APPLY
     92ifneq ($(HACKED_APPLY),)
    9393        echo "#define C_HACKED_APPLY" >>$@
    9494endif
  • chicken/branches/release/Makefile.macosx

    r10108 r10653  
    9595        echo "#define C_NO_APPLY_HOOK" >>$@
    9696endif
     97ifneq ($(HACKED_APPLY),)
    9798        echo "#define C_HACKED_APPLY" >>$@
     99endif
    98100        cat chicken-defaults.h >>$@
    99101
     
    109111LINKER_OPTIONS += -arch ppc -arch i386 -isysroot /Developer/SDKs/MacOSX10.4u.sdk
    110112
    111 ifdef HACKED_APPLY
     113ifneq ($(HACKED_APPLY),)
    112114# We undefine HACKED_APPLY in order to override rules.make.
    113115HACKED_APPLY=
  • chicken/branches/release/Makefile.solaris

    r10108 r10653  
    8585        echo "#define C_NO_APPLY_HOOK" >>$@
    8686endif
    87 ifdef HACKED_APPLY
     87ifneq ($(HACKED_APPLY),)
    8888        echo "#define C_HACKED_APPLY" >>$@
    8989endif
  • chicken/branches/release/NEWS

    r10109 r10653  
     13.2.0
     2
     3- unit extras: moved lists, queues, strings to data-structures
     4- new unit data-structures
     5- unit library: symbol->string now copies its argument
     6- chicken-setup: added option -svn-trunk
     7- unit utils: added file-copy and file-move (request by the einit team)
     8- unit srfi-69: added hash-table-clear!
     9- unit srfi-69: new
     10- unit extras: moved SRFI 69 to unit srfi-69
     11
    1123.1.0
    213
  • chicken/branches/release/README

    r10109 r10653  
    33  (c)2000-2008 Felix L. Winkelmann
    44
    5   version 3.1.0
     5  version 3.2.0
    66
    77 1. Introduction:
  • chicken/branches/release/batch-driver.scm

    r10108 r10653  
    490490                    [proc (user-pass-2)] )
    491491               (when (debugging 'M "; requirements:")
    492                  (pretty-print (hash-table->alist file-requirements)))
     492                 (pretty-print (##sys#hash-table->alist file-requirements)))
    493493               (when proc
    494494                 (when verbose (printf "Secondary user pass...~%"))
  • chicken/branches/release/buildversion

    r10109 r10653  
    1 3.1.0
     13.2.0
  • chicken/branches/release/c-platform.scm

    r10108 r10653  
    100100       ##sys#profile-entry ##sys#profile-exit) ) ) )
    101101
    102 (define units-used-by-default '(library eval extras))
     102(define units-used-by-default '(library eval data-structures extras srfi-69))
    103103(define words-per-flonum 4)
    104104(define parameter-limit 1024)
  • chicken/branches/release/chicken-bug.scm

    r10108 r10653  
    2525
    2626
    27 (use srfi-13 posix utils tcp extras)
     27(use srfi-13 posix tcp data-structures utils extras)
    2828
    2929
  • chicken/branches/release/chicken-profile.scm

    r10108 r10653  
    3030  (uses srfi-1
    3131        srfi-13
     32        srfi-69
    3233        posix
    3334        utils))
  • chicken/branches/release/chicken-setup.1

    r10108 r10653  
    11.\" dummy line
    2 .TH CHICKEN-SETUP 1 "28 Feb 2008"
     2.TH CHICKEN-SETUP 1 "14 Apr 2008"
    33
    44.SH NAME
     
    206206
    207207.TP
     208.BI \-svn-trunk \ URL
     209Fetches extension sources from an SVN repository instead of
     210downloading egg from egg server. If subdirectory trunk exists in the
     211SVN repository, the egg sources are fetched from that location.
     212
     213.TP
    208214.BI \-local \ PATH
    209215Fetches extension sources from the local filesystem at
  • chicken/branches/release/chicken-setup.scm

    r10108 r10653  
    114114  "-version" "-script" "-fetch" "-host" "-proxy" "-keep" "-verbose"
    115115  "-csc-option" "-dont-ask" "-no-install" "-docindex" "-eval"
    116   "-debug" "-ls" "-release" "-test" "-fetch-tree" "-tree" "-svn"
    117   "-local" "-revision" "-host-extension" "-build-prefix"
    118   "-download-path" "-install-prefix") )
     116  "-debug" "-ls" "-release" "-test" "-fetch-tree" "-tree"
     117  "-svn" "-svn-trunk" "-local" "-revision" "-host-extension"
     118  "-build-prefix" "-download-path" "-install-prefix") )
    119119
    120120
    121121(define-constant short-options
    122   '(#\h #\u #\l #\r #\R #\P #\V #\s #\f #\H #\p #\k #\v #\c #\d #\n #\i #\e #\D #f #f #\t #f #f #f #f #f #f
    123     #f) )
     122  '(#\h #\u #\l #\r #\R #\P #\V #\s #\f #\H #\p #\k #\v #\c #\d #\n #\i #\e #\D #f #f #\t
     123        #f #f #f #f #f #f #f #f) )
    124124
    125125(define *installed-executables*
     
    211211(define *fetch-tree-only* #f)
    212212(define *svn-repository* #f)
     213(define *svn-trunk* #f)
    213214(define *local-repository* #f)
    214215(define *repository-hosts* (list (list "www.call-with-current-continuation.org" *default-eggdir* 80)))
     
    218219
    219220
     221; Convert a string with a version (such as "1.22.0") to a list of the
     222; numbers (such as (1 22 0)). If one of the version components cannot
     223; be converted to a number, then it is kept as a string.
     224
     225(define (version-string->numbers string)
     226  (map (lambda (x) (or (string->number x) (->string x)))
     227       (string-split string ".")))
     228
     229(define (numbers->version-string numbers)
     230  (string-intersperse (map ->string numbers) "."))
     231
     232; Given two lists with numbers corresponding to a software version (as returned
     233; by version-string->numbers), check if the first is greater than the second.
     234
     235(define (version-numbers> a b)
     236  (match (list a b)
     237         ((() _)   #f)
     238         ((_  ())  #t)
     239         (((a1 . an) (b1 . bn))
     240          (cond ((and (number? a1) (number? b1))
     241                 (cond ((> a1 b1) #t) ((= a1 b1) (version-numbers> an bn)) (else #f)))
     242                ((and (string? a1) (string? b1)) 
     243                 (cond ((string> a1 b1) #t) ((string= a1 b1) (version-numbers> an bn)) (else #f)))
     244                (else (version-numbers> (cons (->string a1) an) (cons (->string b1) bn)))))
     245         (else (error 'version-numbers> "invalid revisions: " a b))))
     246
    220247;;; File-system routines
    221 
    222 (define create-directory/parents
    223   (let ([create-directory create-directory])
    224     (lambda (dir)
    225       (let loop ([dir dir])
    226         (when (and dir (not (directory? dir)))
    227           (loop (pathname-directory dir))
    228           (create-directory dir))) ) ) )
    229248
    230249(define create-directory
     
    236255          (verb dir)
    237256          (system* "mkdir ~a" (quotewrap dir)))
    238           ; (create-directory/parents dir) )
    239257        (lambda (dir)
    240258          (verb dir)
     
    534552      -tree FILENAME             uses repository catalog from given file
    535553      -svn URL                   fetches extension from subversion repository
     554      -svn-trunk URL             fetches extension from trunk in subversion repository
    536555      -local PATH                fetches extension from local filesystem
    537556      -revision REV              specifies SVN revision for checkout
     
    884903      ((ext version . more)
    885904       (let ((info (extension-information ext))
    886              (version (->string version)) )
     905             (required-version (->string version)) )
    887906         (if info
    888907             (let ((ver (and (assq 'version info) (cadr (assq 'version info)))))
    889908               (cond ((not ver) (upgrade-message ext "has no associated version information"))
    890                      ((string-ci<? (->string ver) version)
     909                     ((version-numbers>
     910                       (version-string->numbers required-version)
     911                       (version-string->numbers (->string ver)))
    891912                      (upgrade-message
    892913                       ext
    893914                       (sprintf "is older than ~a, which is what this extension requires"
    894                                 version) ) )
     915                                required-version) ) )
    895916                     (else (loop more)) ) )
    896917             (upgrade-message ext "is not installed") ) ) )
     
    9951016           (copy-file (make-pathname *local-repository* p) fpath #t #f)))
    9961017
    997         (*svn-repository*
    998          (when (setup-verbose-flag) (printf "fetching from svn repository ~a ...~%" *svn-repository*))
    999          (let* ((p (->string item))
    1000                (fpath (make-pathname (setup-download-directory) p "egg-dir")))
    1001            (run (svn co ,(if *revision* (conc "--revision " *revision*) "")
    1002                      ,(make-pathname *svn-repository* p) ,(quotewrap fpath)))
    1003            fpath))
     1018        ((or *svn-trunk* *svn-repository* ) =>
     1019         (lambda (url)
     1020           (when (setup-verbose-flag) (printf "fetching from svn repository ~a ...~%" url))
     1021           (let* ((p (->string item))
     1022                  (fpath (make-pathname (setup-download-directory) p "egg-dir")))
     1023             (run (svn co ,(if *revision* (conc "--revision " *revision*) "")
     1024                       ,(make-pathname url p) ,(quotewrap fpath)))
     1025             fpath)))
    10041026
    10051027        (else
     
    10861108                   (unpack/enter fpath)
    10871109                   (let ((sfile (pathname-replace-extension f "setup")))
    1088                      (when (and (not (file-exists? sfile)) (file-exists? "tags") )
    1089                        (let ((ds (sort (directory "tags") string>=?)))
    1090                          (when (pair? ds)
    1091                            (let ((d (make-pathname "tags" (car ds))))
    1092                              (chdir d) ) )  ) )
     1110                     (when (not (file-exists? sfile))
     1111                       (cond
     1112                        (*svn-trunk*
     1113                         (when (file-exists? "trunk") (chdir "trunk")))
     1114
     1115                        ((and (not *svn-trunk*) (file-exists? "tags") )
     1116                         (let ((ds (sort (map version-string->numbers (directory "tags")) version-numbers>)))
     1117                           (when (pair? ds)
     1118                             (let ((d (make-pathname "tags" (car ds))))
     1119                               (chdir d)))) )
     1120                        ))
    10931121                     (loop sfile)
    10941122                     (clear-builddir) ) ) ) ))
     
    14231451         (set! *dont-ask* #t)
    14241452         (loop more) )
     1453        (("-svn-trunk" url . more)
     1454         (set! *svn-trunk* url)
     1455         (set! *dont-ask* #t)
     1456         (loop more) )
    14251457        (("-test" . more)
    14261458         (set! *run-tests* #t)
     
    14421474         (loop more) )
    14431475        (((or "-run" "-script" "-proxy" "-host" "-csc-option" "-ls" "-install-prefix"
    1444               "-tree" "-local" "-svn" "-eval" "-create-tree" "-build-prefix" "-download-dir"))
     1476              "-tree" "-local" "-svn" "-svn-trunk" "-eval" "-create-tree" "-build-prefix" "-download-dir"))
    14451477         (error "missing option argument" (car args)) )
    14461478        ((filename . more)
  • chicken/branches/release/chicken.h

    r10108 r10653  
    213213#endif
    214214
    215 #if defined(__BYTE_ORDER) && defined(__BIG_ENDIAN) && __BYTE_ORDER == __BIG_ENDIAN
     215#if defined(__BYTE_ORDER) && __BYTE_ORDER == __BIG_ENDIAN
    216216# define C_BIG_ENDIAN
    217217#elif defined(BYTE_ORDER) && defined(BIG_ENDIAN) && BYTE_ORDER == BIG_ENDIAN
    218218# define C_BIG_ENDIAN
    219 #elif defined(__BIG_ENDIAN__) || defined(_BIG_ENDIAN)
     219#elif defined(__BIG_ENDIAN__)
    220220# define C_BIG_ENDIAN
    221221#elif defined(__sparc__) || defined(__POWERPC__) || defined(__MC68K__) || defined(__mips__)
     
    227227#elif defined(BYTE_ORDER) && defined(LITTLE_ENDIAN) && BYTE_ORDER == LITTLE_ENDIAN
    228228# define C_LITTLE_ENDIAN
    229 #elif defined(__LITTLE_ENDIAN__) || defined(_LITTLE_ENDIAN)
     229#elif defined(__LITTLE_ENDIAN__)
    230230# define C_LITTLE_ENDIAN
    231231#elif defined (__alpha__) || defined(_M_IX86) || defined(__i386__) || defined(__x86_64__) || defined(__ia64__)
  • chicken/branches/release/chicken.scm

    r10108 r10653  
    7171  (include "chicken-more-macros")
    7272  (include "chicken-ffi-macros") )
    73 
    74 ;;(##sys#provide 'extras 'srfi-1 'srfi-4)
    7573
    7674
  • chicken/branches/release/compiler.scm

    r10108 r10653  
    283283  membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument
    284284  make-random-name final-foreign-type real-name-table real-name set-real-name! safe-globals-flag
    285   location-pointer-map
     285  location-pointer-map literal-rewrite-hook
    286286  lookup-exports-file undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info
    287287  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
     
    321321(define-constant inline-table-size 301)
    322322(define-constant constant-table-size 301)
     323(define-constant file-requirements-size 301)
    323324(define-constant real-name-table-size 997)
    324325(define-constant import-table-size 997)
     
    419420(define compiler-macro-table #f)
    420421(define compiler-macros-enabled #t)
     422(define literal-rewrite-hook #f)
    421423
    422424
     
    435437  (set! profile-info-vector-name (make-random-name 'profile-info))
    436438  (set! real-name-table (make-vector real-name-table-size '()))
    437   (set! file-requirements (make-hash-table eq?))
     439  (if file-requirements
     440      (vector-fill! file-requirements '())
     441      (set! file-requirements (make-vector file-requirements-size '())) )
    438442  (if import-table
    439443      (vector-fill! import-table '())
     
    489493          [else #f] ) )
    490494
     495  (define (walk-literal x ae me dest)
     496    (if literal-rewrite-hook
     497        (literal-rewrite-hook x (cut walk <> ae me dest))
     498        `(quote ,x) ) )
     499
    491500  (define (walk x ae me dest)
    492501    (cond ((symbol? x)
     
    498507                 ((resolve-atom x ae me dest))
    499508                 (else (##sys#alias-global-hook x))) )
    500           ((and (not-pair? x) (constant? x)) `(quote ,x))
     509          ((and (not-pair? x) (constant? x))
     510           (walk-literal x ae me dest) )
    501511          ((not-pair? x) (syntax-error "illegal atomic form" x))
    502512          ((symbol? (car x))
     
    532542                        ((quote)
    533543                         (##sys#check-syntax 'quote x '(quote _))
    534                          x)
     544                         (walk-literal (cadr x) ae me dest) )
    535545
    536546                        ((##core#check)
     
    555565                         (let ([ids (map eval (cdr x))])
    556566                           (apply ##sys#require ids)
    557                            (hash-table-update!
     567                           (##sys#hash-table-update!
    558568                            file-requirements 'syntax-requirements (cut lset-union eq? <> ids)
    559569                            (lambda () ids) )
     
    10211031            (for-each lookup-exports-file us) )
    10221032          (when (pair? us)
    1023             (hash-table-update! file-requirements 'uses (cut lset-union eq? us <>) (lambda () us))
     1033            (##sys#hash-table-update! file-requirements 'uses (cut lset-union eq? us <>) (lambda () us))
    10241034            (let ((units (map (lambda (u) (string->c-identifier (stringify u))) us)))
    10251035              (set! used-units (append used-units units)) ) ) ) )
     
    10281038        (let* ([u (cadr spec)]
    10291039               [un (string->c-identifier (stringify u))] )
    1030           (hash-table-set! file-requirements 'unit u)
     1040          (##sys#hash-table-set! file-requirements 'unit u)
    10311041          (when (and unit-name (not (string=? unit-name un)))
    10321042            (compiler-warning 'usage "unit was already given a name (new name is ignored)") )
  • chicken/branches/release/csc.scm

    r10108 r10653  
    2828(declare
    2929  (block)
    30   (uses extras srfi-1 srfi-13 utils))
     30  (uses data-structures srfi-1 srfi-13 utils extras ))
    3131
    3232#>
  • chicken/branches/release/csi.scm

    r10108 r10653  
    2626
    2727
    28 (declare (uses match))
     28(declare (uses match srfi-69))
    2929
    3030(declare
  • chicken/branches/release/debian/changelog

    r10108 r10653  
     1chicken (3.1.0-0.3) unstable; urgency=low
     2
     3  * Chicken shared library moved to libchicken0 package.
     4
     5 -- Ivan Raikov <raikov@oist.jp>  Sun, 20 Apr 2008 16:02:55 +0900
     6
     7chicken (3.1.0-0.2) unstable; urgency=low
     8
     9  * rules changed to link against host PCRE library.
     10
     11 -- Ivan Raikov <raikov@oist.jp>  Sun, 20 Apr 2008 14:18:24 +0900
     12
     13chicken (3.1.0-0.1) unstable; urgency=low
     14
     15  * New upstream version.
     16
     17 -- Ivan Raikov <raikov@oist.jp>  Mon, 24 Mar 2008 14:29:38 +0900
     18
    119chicken (3.0.0-0.1) unstable; urgency=low
    220
  • chicken/branches/release/debian/control

    r3839 r10653  
    33Priority: optional
    44Maintainer: Davide Puricelli (evo) <evo@debian.org>
    5 Build-Depends: debhelper (>> 3.0.0), autotools-dev
     5Build-Depends: debhelper (>> 3.0.0), autotools-dev, libpcre3-dev
    66Standards-Version: 3.6.2
    77
  • chicken/branches/release/debian/libchicken-dev.files

    r2616 r10653  
    11usr/include/*
    2 usr/lib/lib*.*a
    3 usr/lib/lib*.so
     2usr/lib/lib*.a
     3
  • chicken/branches/release/debian/libchicken0.files

    r5882 r10653  
    1 usr/lib/lib*.so.*
     1usr/lib/lib*.so*
    22usr/share/chicken/*.scm
    33usr/share/chicken/*.exports
  • chicken/branches/release/debian/rules

    r10108 r10653  
    2424        $(MAKE) \
    2525            MAKEINFO_PROGRAM_OPTIONS="" \
     26            USE_HOST_PCRE=1 \
    2627            CFLAGS="$(CFLAGS)" \
    2728            PREFIX="$(PREFIX)" \
  • chicken/branches/release/defaults.make

    r10108 r10653  
    174174LINKER_OUTPUT ?= $(LINKER_OUTPUT_OPTION) $@
    175175LINKER_LIBRARY_OPTION ?= -l
     176ifdef STATICBUILD
     177LINKER_LIBRARY_PREFIX ?= lib
     178LINKER_LIBRARY_SUFFIX ?= .a
     179else
    176180LINKER_LIBRARY_PREFIX ?= -l
    177181LINKER_LIBRARY_SUFFIX ?=
     182endif
    178183LINKER_LINK_SHARED_LIBRARY_OPTIONS ?= -shared
    179184LIBRARIAN_OPTIONS ?= cru
  • chicken/branches/release/distribution/manifest

    r10108 r10653  
    5555eval.c
    5656eval.exports
     57data-structures.c
     58data-structures.exports
    5759extras.c
    5860extras.exports
     
    7173scheduler.c
    7274scheduler.exports
     75srfi-69.c
     76srfi-69.exports
    7377srfi-1.c
    7478srfi-1.exports
     
    8791ueval.c
    8892uextras.c
     93udata-structures.c
    8994ulibrary.c
    9095ulolevel.c
     
    97102usrfi-18.c
    98103usrfi-4.c
     104usrfi-69.c
    99105utcp.c
    100106utils.c
     
    128134eval.scm
    129135extras.scm
     136data-structures.scm
    130137chicken-bug.1
    131138chicken-bug.scm
     
    138145html/bibliography.html
    139146html/bugs-and-limitations.html
    140 html/c-interface.html
    141147html/callbacks.html
    142148html/chicken-setup.html
     149html/c-interface.html
    143150html/data-representation.html
    144151html/declarations.html
     
    148155html/faq.html
    149156html/foreign-type-specifiers.html
     157html/getting-started.html
    150158html/index.html
    151159html/interface-to-external-functions-and-variables.html
     
    157165html/pattern-matching.html
    158166html/supported-language.html
     167html/unit-data-structures.html
    159168html/unit-eval.html
    160169html/unit-extras.html
     
    164173html/unit-posix.html
    165174html/unit-regex.html
    166 html/unit-srfi-1.html
    167175html/unit-srfi-13.html
    168176html/unit-srfi-14.html
    169177html/unit-srfi-18.html
     178html/unit-srfi-1.html
    170179html/unit-srfi-4.html
     180html/unit-srfi-69.html
    171181html/unit-tcp.html
    172182html/unit-utils.html
     
    183193runtime.c
    184194scheduler.scm
     195srfi-69.scm
    185196srfi-1.scm
    186197srfi-13.scm
     
    196207tests/runtests.sh
    197208tests/srfi-18-tests.scm
     209tests/hash-table-tests.scm
    198210tests/apply-test.scm
    199211tests/embedded1.c
  • chicken/branches/release/eval.scm

    r10108 r10653  
    8181     read write newline ##sys#eval-handler ##sys#set-dlopen-flags! cadadr ##sys#lookup-runtime-requirements
    8282     map string->keyword ##sys#abort
    83      ##sys#macroexpand-0 ##sys#macroexpand-1-local) ) ] )
     83     ##sys#macroexpand-0 ##sys#macroexpand-1-local ##sys#hash-table-update!) ) ] )
    8484
    8585(cond-expand
     
    105105
    106106(define ##sys#core-library-modules
    107   '(extras lolevel utils tcp regex regex-extras posix match srfi-1 srfi-4 srfi-13 srfi-14 srfi-18))
     107  '(extras lolevel utils tcp regex regex-extras posix match
     108    data-structures srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69))
    108109
    109110(define ##sys#explicit-library-modules '())
     
    127128; srfi-12 in unit library
    128129(define-constant builtin-features
    129   '(chicken srfi-2 srfi-6 srfi-10 srfi-12 srfi-23 srfi-28 srfi-30 srfi-31 srfi-39 srfi-69) )
     130  '(chicken srfi-2 srfi-6 srfi-10 srfi-12 srfi-23 srfi-28 srfi-30 srfi-31 srfi-39) )
    130131
    131132(define-constant builtin-features/compiled
     
    496497;;; Lo-level hashtable support:
    497498
     499;; Note:
     500;;
     501;; - Keys are compared using 'eq?'.
     502;; - The fixed "not found" value is #f. So booleans as values are suspect.
     503
    498504(define ##sys#hash-symbol
    499505  (let ([cache-s #f]
     
    517523                (loop (##sys#slot bucket 1)) ) ) ) ) ) )
    518524
    519 (define ##sys#hash-table-set!
    520   (lambda (ht key val)
    521     (let* ((k (##sys#hash-symbol key (##core#inline "C_block_size" ht)))
    522            (bucket0 (##sys#slot ht k)) )
    523       (let loop ((bucket bucket0))
    524         (if (eq? bucket '())
    525             (##sys#setslot ht k (cons (cons key val) bucket0))
    526             (let ((b (##sys#slot bucket 0)))
    527               (if (eq? key (##sys#slot b 0))
    528                   (##sys#setslot b 1 val)
    529                   (loop (##sys#slot bucket 1)) ) ) ) ) ) ) )
     525(define (##sys#hash-table-set! ht key val)
     526  (let* ((k (##sys#hash-symbol key (##core#inline "C_block_size" ht)))
     527         (bucket0 (##sys#slot ht k)) )
     528    (let loop ((bucket bucket0))
     529      (if (eq? bucket '())
     530          (##sys#setslot ht k (cons (cons key val) bucket0))
     531          (let ((b (##sys#slot bucket 0)))
     532            (if (eq? key (##sys#slot b 0))
     533                (##sys#setslot b 1 val)
     534                (loop (##sys#slot bucket 1)) ) ) ) ) ) )
     535
     536(define (##sys#hash-table-update! ht key updtfunc valufunc)
     537  (##sys#hash-table-set! ht key (updtfunc (or (##sys#hash-table-ref ht key) (valufunc)))) )
    530538
    531539(define (##sys#hash-table-for-each p ht)
     
    534542        ((fx>= i len))
    535543      (##sys#for-each (lambda (bucket)
    536                    (p (##sys#slot bucket 0)
    537                       (##sys#slot bucket 1) ) )
    538                  (##sys#slot ht i) ) ) ) )
     544                        (p (##sys#slot bucket 0) (##sys#slot bucket 1) ) )
     545                      (##sys#slot ht i) ) ) ) )
     546
     547(define (##sys#hash-table->alist ht)
     548  (let ([len (##core#inline "C_block_size" ht)] )
     549    (let loop ([i 0] [lst '()])
     550      (if (fx>= i len)
     551          lst
     552          (let loop2 ([bucket (##sys#slot vec i)]
     553                      [lst lst])
     554            (if (null? bucket)
     555                (loop (fx+ i 1) lst)
     556                (loop2 (##sys#slot bucket 1)
     557                       (let ([x (##sys#slot bucket 0)])
     558                         (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )
    539559
    540560(define ##sys#hash-table-location
     
    14061426      (define (add-req id)
    14071427        (when comp?
    1408           (hash-table-update!           ; assumes compiler has extras available - will break in the interpreter
     1428          (##sys#hash-table-update!
    14091429           ##compiler#file-requirements
    14101430           'syntax-requirements
  • chicken/branches/release/extras.scm

    r10108 r10653  
    2828(declare
    2929 (unit extras)
     30 (uses data-structures)
    3031 (usual-integrations)
    3132 (disable-warning redef)
    3233 (foreign-declare #<<EOF
    33 #define C_hashptr(x)   C_fix(x & C_MOST_POSITIVE_FIXNUM)
    3434#define C_mem_compare(to, from, n)   C_fix(C_memcmp(C_c_string(to), C_c_string(from), C_unfix(n)))
    3535EOF
     
    5757      ##sys#read-char-0 ##sys#write-char ##sys#string-append ##sys#gcd ##sys#lcm
    5858      ##sys#fudge ##sys#check-list ##sys#user-read-hook ##sys#check-closure ##sys#check-inexact
    59       ##extras#%equal?-hash
    6059      input-port? make-vector list->vector sort! merge! open-output-string floor
    6160      get-output-string current-output-port display write port? list->string
     
    6564(private extras
    6665  reverse-string-append
    67   fprintf0 generic-write
    68   unbound-value-thunk
    69   %object-uid-hash %eq?-hash %eqv?-hash %equal?-hash
    70   %hash-table-copy %hash-table-ref %hash-table-update! %hash-table-merge!
    71   %hash-table-for-each %hash-table-fold
    72   hash-table-canonical-length hash-table-rehash )
     66  fprintf0 generic-write )
    7367
    7468(declare
    7569  (hide
    76     fprintf0 generic-write
    77     unbound-value-thunk
    78     %object-uid-hash %eq?-hash %eqv?-hash %equal?-hash
    79     %hash-table-copy %hash-table-ref %hash-table-update! %hash-table-merge!
    80     %hash-table-for-each %hash-table-fold
    81     hash-table-canonical-length hash-table-rehash) )
     70    fprintf0 generic-write ) )
    8271
    8372(cond-expand
     
    10392
    10493
    105 ;;; Unbound Value:
    106 
    107 ;; This only works because of '(no-bound-checks)'
    108 
    109 (define-macro ($unbound-value)
    110  '(##sys#slot '##sys#arbitrary-unbound-symbol 0) )
    111 
    112 (define unbound-value-thunk (lambda () ($unbound-value)))
    113 
    114 (define-macro ($unbound? ?val)
    115   `(eq? ($unbound-value) ,?val) )
    116 
    117 
    118 ;;; Core Inlines:
    119 
    120 (define-macro ($quick-flonum-truncate ?flo)
    121   `(##core#inline "C_quickflonumtruncate" ,?flo) )
    122 
    123 (define-macro ($fix ?wrd)
    124   `(##core#inline "C_fix" ,?wrd) )
    125 
    126 (define-macro ($block? ?obj)
    127   `(##core#inline "C_blockp" ,?obj) )
    128 
    129 (define-macro ($special? ?obj)
    130   `(##core#inline "C_specialp" ,?obj) )
    131 
    132 (define-macro ($port? ?obj)
    133   `(##core#inline "C_portp" ,?obj) )
    134 
    135 (define-macro ($byte-block? ?obj)
    136   `(##core#inline "C_byteblockp" ,?obj) )
    137 
    138 (define-macro ($hash-string ?str)
    139   `(##core#inline "C_hash_string" ,?str) )
    140 
    141 (define-macro ($hash-string-ci ?str)
    142   `(##core#inline "C_hash_string_ci" ,?str) )
    143 
    144 
    145 ;;;
    146 
    147 (define-macro ($immediate? ?obj)
    148   `(not ($block? ,?obj)) )
    149 
    150 
    15194;;; Read expressions from file:
    15295
     
    165108          (call-with-input-file port slurp) ) ) ) )
    166109
    167 
    168 ;;; Combinators:
    169 
    170 (define (identity x) x)
    171 
    172 (define (project n)
    173   (lambda args (list-ref args n)) )
    174 
    175 (define (conjoin . preds)
    176   (lambda (x)
    177     (let loop ([preds preds])
    178       (or (null? preds)
    179           (and ((##sys#slot preds 0) x)
    180                (loop (##sys#slot preds 1)) ) ) ) ) )
    181 
    182 (define (disjoin . preds)
    183   (lambda (x)
    184     (let loop ([preds preds])
    185       (and (not (null? preds))
    186            (or ((##sys#slot preds 0) x)
    187                (loop (##sys#slot preds 1)) ) ) ) ) )
    188 
    189 (define (constantly . xs)
    190   (if (eq? 1 (length xs))
    191       (let ([x (car xs)])
    192         (lambda _ x) )
    193       (lambda _ (apply values xs)) ) )
    194 
    195 (define (flip proc) (lambda (x y) (proc y x)))
    196 
    197 (define complement
    198   (lambda (p)
    199     (lambda args (not (apply p args))) ) )
    200 
    201 (define (compose . fns)
    202   (define (rec f0 . fns)
    203     (if (null? fns)
    204         f0
    205         (lambda args
    206           (call-with-values
    207               (lambda () (apply (apply rec fns) args))
    208             f0) ) ) )
    209   (if (null? fns)
    210       values
    211       (apply rec fns) ) )
    212 
    213 (define (o . fns)
    214   (if (null? fns)
    215       identity
    216       (let loop ((fns fns))
    217         (let ((h (##sys#slot fns 0))
    218               (t (##sys#slot fns 1)) )
    219           (if (null? t)
    220               h
    221               (lambda (x) (h ((loop t) x))))))))
    222 
    223 (define (list-of pred)
    224   (lambda (lst)
    225     (let loop ([lst lst])
    226       (cond [(null? lst) #t]
    227             [(not-pair? lst) #f]
    228             [(pred (##sys#slot lst 0)) (loop (##sys#slot lst 1))]
    229             [else #f] ) ) ) )
    230 
    231 (define (noop . _) (void))
    232 
    233 (define (each . procs)
    234   (cond ((null? procs) (lambda _ (void)))
    235         ((null? (##sys#slot procs 1)) (##sys#slot procs 0))
    236         (else
    237          (lambda args
    238            (let loop ((procs procs))
    239              (let ((h (##sys#slot procs 0))
    240                    (t (##sys#slot procs 1)) )
    241                (if (null? t)
    242                    (apply h args)
    243                    (begin
    244                      (apply h args)
    245                      (loop t) ) ) ) ) ) ) ) )
    246 
    247 (define (any? x) #t)
    248 
    249 (define (none? x) #f)
    250 
    251 (define (always? . _) #t)
    252 
    253 (define (never? . _) #f)
    254 
    255 (define (left-section proc . args)
    256   (##sys#check-closure proc 'left-section)
    257   (lambda xs
    258     (##sys#apply proc (##sys#append args xs)) ) )
    259 
    260 (define right-section
    261   (let ([##sys#reverse reverse])
    262     (lambda (proc . args)
    263       (##sys#check-closure proc 'right-section)
    264       (let ([revdargs (##sys#reverse args)])
    265         (lambda xs
    266           (##sys#apply proc (##sys#reverse (##sys#append revdargs (##sys#reverse xs)))) ) ) ) ) )
    267 
    268 
    269 ;;; List operators:
    270 
    271 (define (atom? x) (##core#inline "C_i_not_pair_p" x))
    272 
    273 (define (tail? x y)
    274   (##sys#check-list y 'tail?)
    275   (or (##core#inline "C_eqp" x '())
    276       (let loop ((y y))
    277         (cond ((##core#inline "C_eqp" y '()) #f)
    278               ((##core#inline "C_eqp" x y) #t)
    279               (else (loop (##sys#slot y 1))) ) ) ) )
    280 
    281 (define intersperse
    282   (lambda (lst x)
    283     (let loop ((ns lst))
    284       (if (##core#inline "C_eqp" ns '())
    285           ns
    286           (let ((tail (cdr ns)))
    287             (if (##core#inline "C_eqp" tail '())
    288                 ns
    289                 (cons (##sys#slot ns 0) (cons x (loop tail))) ) ) ) ) ) )
    290 
    291 (define (butlast lst)
    292   (##sys#check-pair lst 'butlast)
    293   (let loop ((lst lst))
    294     (let ((next (##sys#slot lst 1)))
    295       (if (and (##core#inline "C_blockp" next) (##core#inline "C_pairp" next))
    296           (cons (##sys#slot lst 0) (loop next))
    297           '() ) ) ) )
    298 
    299 (define (flatten . lists0)
    300   (let loop ([lists lists0] [rest '()])
    301     (cond [(null? lists) rest]
    302           [else
    303            (let ([head (##sys#slot lists 0)]
    304                  [tail (##sys#slot lists 1)] )
    305              (if (list? head)
    306                  (loop head (loop tail rest))
    307                  (cons head (loop tail rest)) ) ) ] ) ) )
    308 
    309 (define chop
    310   (let ([reverse reverse])
    311     (lambda (lst n)
    312       (##sys#check-exact n 'chop)
    313       (cond-expand
    314        [(not unsafe) (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))]
    315        [else] )
    316       (let ([len (length lst)])
    317         (let loop ([lst lst] [i len])
    318           (cond [(null? lst) '()]
    319                 [(fx< i n) (list lst)]
    320                 [else
    321                  (do ([hd '() (cons (##sys#slot tl 0) hd)]
    322                       [tl lst (##sys#slot tl 1)]
    323                       [c n (fx- c 1)] )
    324                      ((fx= c 0)
    325                       (cons (reverse hd) (loop tl (fx- i n))) ) ) ] ) ) ) ) ) )
    326 
    327 (define (join lsts . lst)
    328   (let ([lst (if (pair? lst) (car lst) '())])
    329     (##sys#check-list lst 'join)
    330     (let loop ([lsts lsts])
    331       (cond [(null? lsts) '()]
    332             [(cond-expand [unsafe #f] [else (not (pair? lsts))])
    333              (##sys#not-a-proper-list-error lsts) ]
    334             [else
    335              (let ([l (##sys#slot lsts 0)]
    336                    [r (##sys#slot lsts 1)] )
    337                (if (null? r)
    338                    l
    339                    (##sys#append l lst (loop r)) ) ) ] ) ) ) )
    340 
    341 (define compress
    342   (lambda (blst lst)
    343     (let ([msg "bad argument type - not a proper list"])
    344       (##sys#check-list lst 'compress)
    345       (let loop ([blst blst] [lst lst])
    346         (cond [(null? blst) '()]
    347               [(cond-expand [unsafe #f] [else (not (pair? blst))])
    348                (##sys#signal-hook #:type-error 'compress msg blst) ]
    349               [(cond-expand [unsafe #f] [else (not (pair? lst))])
    350                (##sys#signal-hook #:type-error 'compress msg lst) ]
    351               [(##sys#slot blst 0) (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1)))]
    352               [else (loop (##sys#slot blst 1) (##sys#slot lst 1))] ) ) ) ) )
    353 
    354 (define shuffle
    355   ;; this should really shadow SORT! and RANDOM...
    356   (lambda (l)
    357     (let ((len (length l)))
    358       (map cdr
    359            (sort! (map (lambda (x) (cons (random len) x)) l)
    360                   (lambda (x y) (< (car x) (car y)))) ) ) ) )
    361 
    362 
    363 ;;; Alists:
    364 
    365 (define (alist-update! x y lst . cmp)
    366   (let* ([cmp (if (pair? cmp) (car cmp) eqv?)]
    367          [aq (cond [(eq? eq? cmp) assq]
    368                    [(eq? eqv? cmp) assv]
    369                    [(eq? equal? cmp) assoc]
    370                    [else
    371                     (lambda (x lst)
    372                       (let loop ([lst lst])
    373                         (and (pair? lst)
    374                              (let ([a (##sys#slot lst 0)])
    375                                (if (and (pair? a) (cmp (##sys#slot a 0) x))
    376                                    a
    377                                    (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ]
    378          [item (aq x lst)] )
    379     (if item
    380         (begin
    381           (##sys#setslot item 1 y)
    382           lst)
    383         (cons (cons x y) lst) ) ) )
    384 
    385 (define (alist-ref x lst #!optional (cmp eqv?) (default #f))
    386   (let* ([aq (cond [(eq? eq? cmp) assq]
    387                    [(eq? eqv? cmp) assv]
    388                    [(eq? equal? cmp) assoc]
    389                    [else
    390                     (lambda (x lst)
    391                       (let loop ([lst lst])
    392                         (and (pair? lst)
    393                              (let ([a (##sys#slot lst 0)])
    394                                (if (and (pair? a) (cmp (##sys#slot a 0) x))
    395                                    a
    396                                    (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ]
    397          [item (aq x lst)] )
    398     (if item
    399         (##sys#slot item 1)
    400         default) ) )
    401 
    402 (define (rassoc x lst . tst)
    403   (cond-expand [(not unsafe) (##sys#check-list lst 'rassoc)][else])
    404   (let ([tst (if (pair? tst) (car tst) eqv?)])
    405     (let loop ([l lst])
    406       (and (pair? l)
    407            (let ([a (##sys#slot l 0)])
    408              (cond-expand [(not unsafe) (##sys#check-pair a 'rassoc)][else])
    409              (if (tst x (##sys#slot a 1))
    410                  a
    411                  (loop (##sys#slot l 1)) ) ) ) ) ) )
    412110
    413111
     
    1048746
    1049747
    1050 ;;; Anything->string conversion:
    1051 
    1052 (define ->string
    1053   (let ([open-output-string open-output-string]
    1054         [display display]
    1055         [string string]
    1056         [get-output-string get-output-string] )
    1057     (lambda (x)
    1058       (cond [(string? x) x]
    1059             [(symbol? x) (symbol->string x)]
    1060             [(char? x) (string x)]
    1061             [(number? x) (##sys#number->string x)]
    1062             [else
    1063              (let ([o (open-output-string)])
    1064                (display x o)
    1065                (get-output-string o) ) ] ) ) ) )
    1066 
    1067 (define conc
    1068   (let ([string-append string-append])
    1069     (lambda args
    1070       (apply string-append (map ->string args)) ) ) )
    1071 
    1072 
    1073 ;;; Search one string inside another:
    1074 
    1075 (let ()
    1076   (define (traverse which where start test loc)
    1077     (##sys#check-string which loc)
    1078     (##sys#check-string where loc)
    1079     (let ([wherelen (##sys#size where)]
    1080           [whichlen (##sys#size which)] )
    1081       (##sys#check-exact start loc)
    1082       (let loop ([istart start] [iend whichlen])
    1083         (cond [(fx> iend wherelen) #f]
    1084               [(test istart whichlen) istart]
    1085               [else
    1086                (loop (fx+ istart 1)
    1087                      (fx+ iend 1) ) ] ) ) ) )
    1088   (set! ##sys#substring-index
    1089     (lambda (which where start)
    1090       (traverse
    1091        which where start
    1092        (lambda (i l) (##core#inline "C_substring_compare" which where 0 i l))
    1093        'substring-index) ) )
    1094   (set! ##sys#substring-index-ci
    1095     (lambda (which where start)
    1096       (traverse
    1097        which where start
    1098        (lambda (i l) (##core#inline "C_substring_compare_case_insensitive" which where 0 i l))
    1099        'substring-index-ci) ) ) )
    1100 
    1101 (define (substring-index which where #!optional (start 0))
    1102   (##sys#substring-index which where start) )
    1103 
    1104 (define (substring-index-ci which where #!optional (start 0))
    1105   (##sys#substring-index-ci which where start) )
    1106 
    1107 
    1108 ;;; 3-Way string comparison:
    1109 
    1110 (define (string-compare3 s1 s2)
    1111   (##sys#check-string s1 'string-compare3)
    1112   (##sys#check-string s2 'string-compare3)
    1113   (let ((len1 (##sys#size s1))
    1114         (len2 (##sys#size s2)) )
    1115     (let* ((len-diff (fx- len1 len2))
    1116            (cmp (##core#inline "C_mem_compare" s1 s2 (if (fx< len-diff 0) len1 len2))))
    1117       (if (fx= cmp 0)
    1118           len-diff
    1119           cmp))))
    1120 
    1121 (define (string-compare3-ci s1 s2)
    1122   (##sys#check-string s1 'string-compare3-ci)
    1123   (##sys#check-string s2 'string-compare3-ci)
    1124   (let ((len1 (##sys#size s1))
    1125         (len2 (##sys#size s2)) )
    1126     (let* ((len-diff (fx- len1 len2))
    1127            (cmp (##core#inline "C_string_compare_case_insensitive" s1 s2 (if (fx< len-diff 0) len1 len2))))
    1128       (if (fx= cmp 0)
    1129           len-diff
    1130           cmp))))
    1131 
    1132 
    1133 ;;; Substring comparison:
    1134 
    1135 (define (##sys#substring=? s1 s2 start1 start2 n)
    1136   (##sys#check-string s1 'substring=?)
    1137   (##sys#check-string s2 'substring=?)
    1138   (let ((len (or n
    1139                  (fxmin (fx- (##sys#size s1) start1)
    1140                         (fx- (##sys#size s2) start2) ) ) ) )
    1141     (##sys#check-exact start1 'substring=?)
    1142     (##sys#check-exact start2 'substring=?)
    1143     (##core#inline "C_substring_compare" s1 s2 start1 start2 len) ) )
    1144 
    1145 (define (substring=? s1 s2 #!optional (start1 0) (start2 0) len)
    1146   (##sys#substring=? s1 s2 start1 start2 len) )
    1147 
    1148 (define (##sys#substring-ci=? s1 s2 start1 start2 n)
    1149   (##sys#check-string s1 'substring-ci=?)
    1150   (##sys#check-string s2 'substring-ci=?)
    1151   (let ((len (or n
    1152                  (fxmin (fx- (##sys#size s1) start1)
    1153                         (fx- (##sys#size s2) start2) ) ) ) )
    1154     (##sys#check-exact start1 'substring-ci=?)
    1155     (##sys#check-exact start2 'substring-ci=?)
    1156     (##core#inline "C_substring_compare_case_insensitive"
    1157                    s1 s2 start1 start2 len) ) )
    1158 
    1159 (define (substring-ci=? s1 s2 #!optional (start1 0) (start2 0) len)
    1160   (##sys#substring-ci=? s1 s2 start1 start2 len) )
    1161 
    1162 
    1163 ;;; Split string into substrings:
    1164 
    1165 (define string-split
    1166   (lambda (str . delstr-and-flag)
    1167     (##sys#check-string str 'string-split)
    1168     (let* ([del (if (null? delstr-and-flag) "\t\n " (car delstr-and-flag))]
    1169            [flag (if (fx= (length delstr-and-flag) 2) (cadr delstr-and-flag) #f)]
    1170            [strlen (##sys#size str)] )
    1171       (##sys#check-string del 'string-split)
    1172       (let ([dellen (##sys#size del)]
    1173             [first #f] )
    1174         (define (add from to last)
    1175           (let ([node (cons (##sys#substring str from to) '())])
    1176             (if first
    1177                 (##sys#setslot last 1 node)
    1178                 (set! first node) )
    1179             node) )
    1180         (let loop ([i 0] [last #f] [from 0])
    1181           (cond [(fx>= i strlen)
    1182                  (when (or (fx> i from) flag) (add from i last))
    1183                  (or first '()) ]
    1184                 [else
    1185                  (let ([c (##core#inline "C_subchar" str i)])
    1186                    (let scan ([j 0])
    1187                      (cond [(fx>= j dellen) (loop (fx+ i 1) last from)]
    1188                            [(eq? c (##core#inline "C_subchar" del j))
    1189                             (let ([i2 (fx+ i 1)])
    1190                               (if (or (fx> i from) flag)
    1191                                   (loop i2 (add from i last) i2)
    1192                                   (loop i2 last i2) ) ) ]
    1193                            [else (scan (fx+ j 1))] ) ) ) ] ) ) ) ) ) )
    1194 
    1195 
    1196 ;;; Concatenate list of strings:
    1197 
    1198 (define (string-intersperse strs #!optional (ds " "))
    1199   (##sys#check-list strs 'string-intersperse)
    1200   (##sys#check-string ds 'string-intersperse)
    1201   (let ((dslen (##sys#size ds)))
    1202     (let loop1 ((ss strs) (n 0))
    1203       (cond ((##core#inline "C_eqp" ss '())
    1204              (if (##core#inline "C_eqp" strs '())
    1205                  ""
    1206                  (let ((str2 (##sys#allocate-vector (fx- n dslen) #t #\space #f)))
    1207                    (let loop2 ((ss2 strs) (n2 0))
    1208                      (let* ((stri (##sys#slot ss2 0))
    1209                             (next (##sys#slot ss2 1))
    1210                             (strilen (##sys#size stri)) )
    1211                        (##core#inline "C_substring_copy" stri str2 0 strilen n2)
    1212                        (let ((n3 (fx+ n2 strilen)))
    1213                          (if (##core#inline "C_eqp" next '())
    1214                              str2
    1215                              (begin
    1216                                (##core#inline "C_substring_copy" ds str2 0 dslen n3)
    1217                                (loop2 next (fx+ n3 dslen)) ) ) ) ) ) ) ) )
    1218             ((and (##core#inline "C_blockp" ss) (##core#inline "C_pairp" ss))
    1219              (let ((stri (##sys#slot ss 0)))
    1220                (##sys#check-string stri 'string-intersperse)
    1221                (loop1 (##sys#slot ss 1)
    1222                       (fx+ (##sys#size stri) (fx+ dslen n)) ) ) )
    1223             (else (##sys#not-a-proper-list-error strs)) ) ) ) )
    1224 
    1225 
    1226 ;;; Translate elements of a string:
    1227 
    1228 (define string-translate
    1229   (let ([make-string make-string]
    1230         [list->string list->string] )
    1231     (lambda (str from . to)
    1232 
    1233       (define (instring s)
    1234         (let ([len (##sys#size s)])
    1235           (lambda (c)
    1236             (let loop ([i 0])
    1237               (cond [(fx>= i len) #f]
    1238                     [(eq? c (##core#inline "C_subchar" s i)) i]
    1239                     [else (loop (fx+ i 1))] ) ) ) ) )
    1240 
    1241       (let* ([from
    1242               (cond [(char? from) (lambda (c) (eq? c from))]
    1243                     [(pair? from) (instring (list->string from))]
    1244                     [else
    1245                      (##sys#check-string from 'string-translate)
    1246                      (instring from) ] ) ]
    1247              [to
    1248               (and (pair? to)
    1249                    (let ([tx (##sys#slot to 0)])
    1250                      (cond [(char? tx) tx]
    1251                            [(pair? tx) (list->string tx)]
    1252                            [else
    1253                             (##sys#check-string tx 'string-translate)
    1254                             tx] ) ) ) ]
    1255              [tlen (and (string? to) (##sys#size to))] )
    1256         (##sys#check-string str 'string-translate)
    1257         (let* ([slen (##sys#size str)]
    1258                [str2 (make-string slen)] )
    1259           (let loop ([i 0] [j 0])
    1260             (if (fx>= i slen)
    1261                 (if (fx< j i)
    1262                     (##sys#substring str2 0 j)
    1263                     str2)
    1264                 (let* ([ci (##core#inline "C_subchar" str i)]
    1265                        [found (from ci)] )
    1266                   (cond [(not found)
    1267                          (##core#inline "C_setsubchar" str2 j ci)
    1268                          (loop (fx+ i 1) (fx+ j 1)) ]
    1269                         [(not to) (loop (fx+ i 1) j)]
    1270                         [(char? to)
    1271                          (##core#inline "C_setsubchar" str2 j to)
    1272                          (loop (fx+ i 1) (fx+ j 1)) ]
    1273                         [(cond-expand [unsafe #f] [else (fx>= found tlen)])
    1274                          (##sys#error 'string-translate "invalid translation destination" i to) ]
    1275                         [else
    1276                          (##core#inline "C_setsubchar" str2 j (##core#inline "C_subchar" to found))
    1277                          (loop (fx+ i 1) (fx+ j 1)) ] ) ) ) ) ) ) ) ) )
    1278 
    1279 (define (string-translate* str smap)
    1280   (##sys#check-string str 'string-translate*)
    1281   (##sys#check-list smap 'string-translate*)
    1282   (let ([len (##sys#size str)])
    1283     (define (collect i from total fs)
    1284       (if (fx>= i len)
    1285           (##sys#fragments->string
    1286            total
    1287            (reverse
    1288             (if (fx> i from)
    1289                 (cons (##sys#substring str from i) fs)
    1290                 fs) ) )
    1291           (let loop ([smap smap])
    1292             (if (null? smap)
    1293                 (collect (fx+ i 1) from (fx+ total 1) fs)
    1294                 (let* ([p (car smap)]
    1295                        [sm (car p)]
    1296                        [smlen (string-length sm)]
    1297                        [st (cdr p)] )
    1298                   (if (##core#inline "C_substring_compare" str sm i 0 smlen)
    1299                       (let ([i2 (fx+ i smlen)])
    1300                         (when (fx> i from)
    1301                           (set! fs (cons (##sys#substring str from i) fs)) )
    1302                         (collect
    1303                          i2 i2
    1304                          (fx+ total (string-length st))
    1305                          (cons st fs) ) )
    1306                       (loop (cdr smap)) ) ) ) ) ) )
    1307     (collect 0 0 0 '()) ) )
    1308 
    1309 
    1310 ;;; Chop string into substrings:
    1311 
    1312 (define (string-chop str len)
    1313   (##sys#check-string str 'string-chop)
    1314   (##sys#check-exact len 'string-chop)
    1315   (let ([total (##sys#size str)])
    1316     (let loop ([total total] [pos 0])
    1317       (cond [(fx<= total 0) '()]
    1318             [(fx<= total len) (list (##sys#substring str pos (fx+ pos total)))]
    1319             [else (cons (##sys#substring str pos (fx+ pos len)) (loop (fx- total len) (fx+ pos len)))] ) ) ) )
    1320            
    1321 
    1322 ;;; Remove suffix
    1323 
    1324 (define (string-chomp str #!optional (suffix "\n"))
    1325   (##sys#check-string str 'string-chomp)
    1326   (##sys#check-string suffix 'string-chomp)
    1327   (let* ((len (##sys#size str))
    1328          (slen (##sys#size suffix))
    1329          (diff (fx- len slen)) )
    1330     (if (and (fx>= len slen)
    1331              (##core#inline "C_substring_compare" str suffix diff 0 slen) )
    1332         (##sys#substring str 0 diff)
    1333         str) ) )
    1334 
    1335 
    1336748;;; Write simple formatted output:
    1337749
     
    1416828(register-feature! 'srfi-28)
    1417829
    1418 
    1419 ;;; Defines: sorted?, merge, merge!, sort, sort!
    1420 ;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
    1421 ;;;
    1422 ;;; This code is in the public domain.
    1423 
    1424 ;;; Updated: 11 June 1991
    1425 ;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
    1426 ;;; Updated: 19 June 1995
    1427 
    1428 ;;; (sorted? sequence less?)
    1429 ;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
    1430 ;;; such that for all 1 <= i <= m,
    1431 ;;;     (not (less? (list-ref list i) (list-ref list (- i 1)))).
    1432 
    1433 ; Modified by flw for use with CHICKEN:
    1434 ;
    1435 
    1436 
    1437 (define (sorted? seq less?)
    1438     (cond
    1439         ((null? seq)
    1440             #t)
    1441         ((vector? seq)
    1442             (let ((n (vector-length seq)))
    1443                 (if (<= n 1)
    1444                     #t
    1445                     (do ((i 1 (+ i 1)))
    1446                         ((or (= i n)
    1447                              (less? (vector-ref seq i)
    1448                                     (vector-ref seq (- i 1))))
    1449                             (= i n)) )) ))
    1450         (else
    1451             (let loop ((last (car seq)) (next (cdr seq)))
    1452                 (or (null? next)
    1453                     (and (not (less? (car next) last))
    1454                          (loop (car next) (cdr next)) )) )) ))
    1455 
    1456 
    1457 ;;; (merge a b less?)
    1458 ;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
    1459 ;;; and returns a new list in which the elements of a and b have been stably
    1460 ;;; interleaved so that (sorted? (merge a b less?) less?).
    1461 ;;; Note:  this does _not_ accept vectors.  See below.
    1462 
    1463 (define (merge a b less?)
    1464     (cond
    1465         ((null? a) b)
    1466         ((null? b) a)
    1467         (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
    1468             ;; The loop handles the merging of non-empty lists.  It has
    1469             ;; been written this way to save testing and car/cdring.
    1470             (if (less? y x)
    1471                 (if (null? b)
    1472                     (cons y (cons x a))
    1473                     (cons y (loop x a (car b) (cdr b)) ))
    1474                 ;; x <= y
    1475                 (if (null? a)
    1476                     (cons x (cons y b))
    1477                     (cons x (loop (car a) (cdr a) y b)) )) )) ))
    1478 
    1479 
    1480 ;;; (merge! a b less?)
    1481 ;;; takes two sorted lists a and b and smashes their cdr fields to form a
    1482 ;;; single sorted list including the elements of both.
    1483 ;;; Note:  this does _not_ accept vectors.
    1484 
    1485 (define (merge! a b less?)
    1486     (define (loop r a b)
    1487         (if (less? (car b) (car a))
    1488             (begin
    1489                 (set-cdr! r b)
    1490                 (if (null? (cdr b))
    1491                     (set-cdr! b a)
    1492                     (loop b a (cdr b)) ))
    1493             ;; (car a) <= (car b)
    1494             (begin
    1495                 (set-cdr! r a)
    1496                 (if (null? (cdr a))
    1497                     (set-cdr! a b)
    1498                     (loop a (cdr a) b)) )) )
    1499     (cond
    1500         ((null? a) b)
    1501         ((null? b) a)
    1502         ((less? (car b) (car a))
    1503             (if (null? (cdr b))
    1504                 (set-cdr! b a)
    1505                 (loop b a (cdr b)))
    1506             b)
    1507         (else ; (car a) <= (car b)
    1508             (if (null? (cdr a))
    1509                 (set-cdr! a b)
    1510                 (loop a (cdr a) b))
    1511             a)))
    1512 
    1513 
    1514 ;;; (sort! sequence less?)
    1515 ;;; sorts the list or vector sequence destructively.  It uses a version
    1516 ;;; of merge-sort invented, to the best of my knowledge, by David H. D.
    1517 ;;; Warren, and first used in the DEC-10 Prolog system.  R. A. O'Keefe
    1518 ;;; adapted it to work destructively in Scheme.
    1519 
    1520 (define (sort! seq less?)
    1521     (define (step n)
    1522         (cond
    1523             ((> n 2)
    1524                 (let* ((j (quotient n 2))
    1525                        (a (step j))
    1526                        (k (- n j))
    1527                        (b (step k)))
    1528                     (merge! a b less?)))
    1529             ((= n 2)
    1530                 (let ((x (car seq))
    1531                       (y (cadr seq))
    1532                       (p seq))
    1533                     (set! seq (cddr seq))
    1534                     (if (less? y x) (begin
    1535                         (set-car! p y)
    1536                         (set-car! (cdr p) x)))
    1537                     (set-cdr! (cdr p) '())
    1538                     p))
    1539             ((= n 1)
    1540                 (let ((p seq))
    1541                     (set! seq (cdr seq))
    1542                     (set-cdr! p '())
    1543                     p))
    1544             (else
    1545                 '()) ))
    1546     (if (vector? seq)
    1547         (let ((n (vector-length seq))
    1548               (vec seq))
    1549           (set! seq (vector->list seq))
    1550           (do ((p (step n) (cdr p))
    1551                (i 0 (+ i 1)))
    1552               ((null? p) vec)
    1553             (vector-set! vec i (car p)) ))
    1554         ;; otherwise, assume it is a list
    1555         (step (length seq)) ))
    1556 
    1557 ;;; (sort sequence less?)
    1558 ;;; sorts a vector or list non-destructively.  It does this by sorting a
    1559 ;;; copy of the sequence.  My understanding is that the Standard says
    1560 ;;; that the result of append is always "newly allocated" except for
    1561 ;;; sharing structure with "the last argument", so (append x '()) ought
    1562 ;;; to be a standard way of copying a list x.
    1563 
    1564 (define (sort seq less?)
    1565     (if (vector? seq)
    1566         (list->vector (sort! (vector->list seq) less?))
    1567         (sort! (append seq '()) less?)))
    1568 
    1569 
    1570 ;;; Binary search:
    1571 
    1572 (define binary-search
    1573   (let ([list->vector list->vector])
    1574     (lambda (vec proc)
    1575       (if (pair? vec)
    1576           (set! vec (list->vector vec))
    1577           (##sys#check-vector vec 'binary-search) )
    1578       (let ([len (##sys#size vec)])
    1579         (and (fx> len 0)
    1580              (let loop ([ps 0]
    1581                         [pe len] )
    1582                (let ([p (fx+ ps (##core#inline "C_fixnum_divide" (fx- pe ps) 2))])
    1583                  (let* ([x (##sys#slot vec p)]
    1584                         [r (proc x)] )
    1585                    (cond [(fx= r 0) p]
    1586                          [(fx< r 0) (and (not (fx= pe p)) (loop ps p))]
    1587                          [else (and (not (fx= ps p)) (loop p pe))] ) ) ) ) ) ) ) ) )
    1588 
    1589 
    1590 ;;; Generation of hash-values:
    1591 
    1592 ;; Naming Conventions:
    1593 ;; $foo - macro
    1594 ;; $*foo - local macro (no such thing but at least it looks different)
    1595 ;; %foo - private, usually unchecked, procedure
    1596 ;; ##sys#foo - public, but undocumented, un-checked procedure
    1597 ;; foo - public checked procedure
    1598 ;;
    1599 ;; All '%foo-hash' return a fixnum, not necessarily positive. The "overflow" of
    1600 ;; a, supposedly, unsigned hash value into negative is not checked during
    1601 ;; intermediate computation.
    1602 ;;
    1603 ;; The body of '%eq?-hash' is duplicated in 'eqv?-hash' and the body of '%eqv?-hash'
    1604 ;; is duplicated in '%equal?-hash' to save on procedure calls.
    1605 
    1606 ;; Fixed hash-values:
    1607 
    1608 (define-constant other-hash-value 99)
    1609 (define-constant true-hash-value 256)
    1610 (define-constant false-hash-value 257)
    1611 (define-constant null-hash-value 258)
    1612 (define-constant eof-hash-value 259)
    1613 (define-constant input-port-hash-value 260)
    1614 (define-constant output-port-hash-value 261)
    1615 (define-constant unknown-immediate-hash-value 262)
    1616 
    1617 (define-constant hash-default-bound 536870912)
    1618 
    1619 ;; Force Hash to Bounded Fixnum:
    1620 
    1621 (define-macro ($fxabs ?fxn)
    1622   `(let ([_fxn ,?fxn]) (if (fx< _fxn 0) (fxneg _fxn) _fxn ) ) )
    1623 
    1624 (define-macro ($hash/limit ?hsh ?lim)
    1625   `(fxmod (fxand (foreign-value "C_MOST_POSITIVE_FIXNUM" int)
    1626                  ($fxabs ,?hsh))
    1627           ,?lim) )
    1628 
    1629 ;; Number Hash:
    1630 
    1631 (define-constant flonum-magic 331804471)
    1632 
    1633 #| Not sure which is "better"; went with speed
    1634 (define-macro ($subbyte ?bytvec ?i)
    1635   `(##core#inline "C_subbyte" ,?bytvec ,?i) )
    1636 
    1637 (define-macro ($hash-flonum ?flo)
    1638   `(fx* flonum-magic
    1639         ,(let loop ([idx (fx- (##sys#size 1.0) 1)])
    1640             (if (fx= 0 idx)
    1641                 `($subbyte ,?flo 0)
    1642                 `(fx+ ($subbyte ,?flo ,idx)
    1643                       (fxshl ,(loop (fx- idx 1)) 1))))) )
    1644 |#
    1645 
    1646 (define-macro ($hash-flonum ?flo)
    1647   `(fx* flonum-magic ($quick-flonum-truncate ,?flo)) )
    1648 
    1649 (define (##sys#number-hash-hook obj)
    1650   (%equal?-hash obj) )
    1651 
    1652 (define-macro ($non-fixnum-number-hash ?obj)
    1653   `(cond [(flonum? obj) ($hash-flonum ,?obj)]
    1654          [else          ($fix (##sys#number-hash-hook ,?obj))] ) )
    1655 
    1656 (define-macro ($number-hash ?obj)
    1657   `(cond [(fixnum? obj) ,?obj]
    1658          [else          ($non-fixnum-number-hash ?obj)] ) )
    1659 
    1660 (define (number-hash obj #!optional (bound hash-default-bound))
    1661   (unless (number? obj)
    1662     (##sys#signal-hook #:type 'number-hash "invalid number" obj) )
    1663   (##sys#check-exact bound 'number-hash)
    1664   ($hash/limit ($number-hash obj) bound) )
    1665 
    1666 ;; Object UID Hash:
    1667 
    1668 #; ;NOT YET (no weak-reference)
    1669 (define (%object-uid-hash obj)
    1670   (%uid-hash (##sys#object->uid obj)) )
    1671 
    1672 (define (%object-uid-hash obj)
    1673   (%equal?-hash obj) )
    1674 
    1675 (define (object-uid-hash obj #!optional (bound hash-default-bound))
    1676   (##sys#check-exact bound 'object-uid-hash)
    1677   ($hash/limit (%object-uid-hash obj) bound) )
    1678 
    1679 ;; Symbol Hash:
    1680 
    1681 #; ;NOT YET (no unique-symbol-hash)
    1682 (define-macro ($symbol-hash ?obj)
    1683   `(##sys#slot ,?obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-SYMBOL-CREATION) )
    1684 
    1685 (define-macro ($symbol-hash ?obj)
    1686   `($hash-string (##sys#slot ,?obj 1)) )
    1687 
    1688 (define (symbol-hash obj #!optional (bound hash-default-bound))
    1689   (##sys#check-symbol obj 'symbol-hash)
    1690   (##sys#check-exact bound 'string-hash)
    1691   ($hash/limit ($symbol-hash obj) bound) )
    1692 
    1693 ;; Keyword Hash:
    1694 
    1695 (define (##sys#check-keyword x . y)
    1696   (unless (keyword? x)
    1697     (##sys#signal-hook #:type-error
    1698                        (and (not (null? y)) (car y))
    1699                        "bad argument type - not a keyword" x) ) )
    1700 
    1701 #; ;NOT YET (no unique-keyword-hash)
    1702 (define-macro ($keyword-hash ?obj)
    1703   `(##sys#slot ,?obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-KEYWORD-CREATION) )
    1704 
    1705 (define-macro ($keyword-hash ?obj)
    1706   `($hash-string (##sys#slot ,?obj 1)) )
    1707 
    1708 (define (keyword-hash obj #!optional (bound hash-default-bound))
    1709   (##sys#check-keyword obj 'keyword-hash)
    1710   (##sys#check-exact bound 'keyword-hash)
    1711   ($hash/limit ($keyword-hash obj) bound) )
    1712 
    1713 ;; Eq Hash:
    1714 
    1715 (define-macro ($eq?-hash-object? ?obj)
    1716   `(or ($immediate? ,?obj)
    1717        (symbol? ,?obj)
    1718        #; ;NOT YET (no keyword vs. symbol issue)
    1719        (keyword? ,?obj) ) )
    1720 
    1721 (define (%eq?-hash obj)
    1722   (cond [(fixnum? obj)          obj]
    1723         [(char? obj)            (char->integer obj)]
    1724         [(eq? obj #t)           true-hash-value]
    1725         [(eq? obj #f)           false-hash-value]
    1726         [(null? obj)            null-hash-value]
    1727         [(eof-object? obj)      eof-hash-value]
    1728         [(symbol? obj)          ($symbol-hash obj)]
    1729         #; ;NOT YET (no keyword vs. symbol issue)
    1730         [(keyword? obj)         ($keyword-hash obj)]
    1731         [($immediate? obj)      unknown-immediate-hash-value]
    1732         [else                   (%object-uid-hash obj) ] ) )
    1733 
    1734 (define (eq?-hash obj #!optional (bound hash-default-bound))
    1735   (##sys#check-exact bound 'eq?-hash)
    1736   ($hash/limit (%eq?-hash obj) bound) )
    1737 
    1738 (define hash-by-identity eq?-hash)
    1739 
    1740 ;; Eqv Hash:
    1741 
    1742 (define-macro ($eqv?-hash-object? ?obj)
    1743   `(or ($eq?-hash-object? ,?obj)
    1744        (number? ,?obj)) )
    1745 
    1746 (define (%eqv?-hash obj)
    1747   (cond [(fixnum? obj)          obj]
    1748         [(char? obj)            (char->integer obj)]
    1749         [(eq? obj #t)           true-hash-value]
    1750         [(eq? obj #f)           false-hash-value]
    1751         [(null? obj)            null-hash-value]
    1752         [(eof-object? obj)      eof-hash-value]
    1753         [(symbol? obj)          ($symbol-hash obj)]
    1754         #; ;NOT YET (no keyword vs. symbol issue)
    1755         [(keyword? obj)         ($keyword-hash obj)]
    1756         [(number? obj)          ($non-fixnum-number-hash obj)]
    1757         [($immediate? obj)      unknown-immediate-hash-value]
    1758         [else                   (%object-uid-hash obj) ] ) )
    1759 
    1760 (define (eqv?-hash obj #!optional (bound hash-default-bound))
    1761   (##sys#check-exact bound 'eqv?-hash)
    1762   ($hash/limit (%eqv?-hash obj) bound) )
    1763 
    1764 ;; Equal Hash:
    1765 
    1766 ;XXX Be nice if these were parameters
    1767 (define-constant recursive-hash-max-depth 4)
    1768 (define-constant recursive-hash-max-length 4)
    1769 
    1770 (define-macro ($*list-hash ?obj)
    1771   `(fx+ (length ,?obj)
    1772         (recursive-atomic-hash (##sys#slot ,?obj 0) depth)) )
    1773 
    1774 (define-macro ($*pair-hash ?obj)
    1775   `(fx+ (fxshl (recursive-atomic-hash (##sys#slot ,?obj 0) depth) 16)
    1776         (recursive-atomic-hash (##sys#slot ,?obj 1) depth)) )
    1777 
    1778 (define-macro ($*port-hash ?obj)
    1779   `(fx+ (fxshl (##sys#peek-fixnum ,?obj 0) 4) ; Little extra "identity"
    1780         (if (input-port? ,?obj)
    1781             input-port-hash-value
    1782             output-port-hash-value)) )
    1783 
    1784 (define-macro ($*special-vector-hash ?obj)
    1785   `(vector-hash ,?obj (##sys#peek-fixnum ,?obj 0) depth 1) )
    1786 
    1787 (define-macro ($*regular-vector-hash ?obj)
    1788   `(vector-hash ,?obj 0 depth 0) )
    1789 
    1790 (define (%equal?-hash obj)
    1791 
    1792   ; Recurse into some portion of the vector's slots
    1793   (define (vector-hash obj seed depth start)
    1794     (let ([len (##sys#size obj)])
    1795       (let loop ([hsh (fx+ len seed)]
    1796                  [i start]
    1797                  [len (fx- (fxmin recursive-hash-max-length len) start)] )
    1798         (if (fx= len 0)
    1799             hsh
    1800             (loop (fx+ hsh
    1801                        (fx+ (fxshl hsh 4)
    1802                             (recursive-hash (##sys#slot obj i) (fx+ depth 1))))
    1803                   (fx+ i 1)
    1804                   (fx- len 1) ) ) ) ) )
    1805 
    1806   ; Don't recurse into structured objects
    1807   (define (recursive-atomic-hash obj depth)
    1808     (if (or ($eqv?-hash-object? obj)
    1809             ($byte-block? obj))
    1810         (recursive-hash obj (fx+ depth 1))
    1811         other-hash-value ) )
    1812 
    1813   ; Recurse into structured objects
    1814   (define (recursive-hash obj depth)
    1815     (cond [(fx>= depth recursive-hash-max-depth)
    1816                                   other-hash-value]
    1817           [(fixnum? obj)          obj]
    1818           [(char? obj)            (char->integer obj)]
    1819           [(eq? obj #t)           true-hash-value]
    1820           [(eq? obj #f)           false-hash-value]
    1821           [(null? obj)            null-hash-value]
    1822           [(eof-object? obj)      eof-hash-value]
    1823           [(symbol? obj)          ($symbol-hash obj)]
    1824           #; ;NOT YET (no keyword vs. symbol issue)
    1825           [(keyword? obj)         ($keyword-hash obj)]
    1826           [(number? obj)          ($non-fixnum-number-hash obj)]
    1827           [($immediate? obj)      unknown-immediate-hash-value]
    1828           [($byte-block? obj)     ($hash-string obj)]
    1829           [(list? obj)            ($*list-hash obj)]
    1830           [(pair? obj)            ($*pair-hash obj)]
    1831           [($port? obj)           ($*port-hash obj)]
    1832           [($special? obj)        ($*special-vector-hash obj)]
    1833           [else                   ($*regular-vector-hash obj)] ) )
    1834 
    1835   ;
    1836   (recursive-hash obj 0) )
    1837 
    1838 (define (equal?-hash obj #!optional (bound hash-default-bound))
    1839   (##sys#check-exact bound 'hash)
    1840   ($hash/limit (%equal?-hash obj) bound) )
    1841 
    1842 (define hash equal?-hash)
    1843 
    1844 ;; String Hash:
    1845 
    1846 (define (string-hash str #!optional (bound hash-default-bound))
    1847   (##sys#check-string str 'string-hash)
    1848   (##sys#check-exact bound 'string-hash)
    1849   ($hash/limit ($hash-string str) bound) )
    1850 
    1851 (define (string-ci-hash str #!optional (bound hash-default-bound))
    1852   (##sys#check-string str 'string-ci-hash)
    1853   (##sys#check-exact bound 'string-ci-hash)
    1854   ($hash/limit ($hash-string-ci str) bound) )
    1855 
    1856 
    1857 ;;; Hash-Tables:
    1858 
    1859 ; Predefined sizes for the hash tables:
    1860 ;
    1861 ; Starts with 307; each element is the smallest prime that is at least twice in
    1862 ; magnitude as the previous element in the list.
    1863 ;
    1864 ; The last number is an exception: it is the largest 32-bit fixnum we can represent.
    1865 
    1866 (define-constant hash-table-prime-lengths
    1867   '(307 617
    1868     1237 2477 4957 9923
    1869     19853 39709 79423
    1870     158849 317701 635413
    1871     1270849 2541701 5083423
    1872     10166857 20333759 40667527 81335063 162670129
    1873     325340273 650680571
    1874     ;
    1875     1073741823))
    1876 
    1877 (define-constant hash-table-default-length 307)
    1878 (define-constant hash-table-max-length 1073741823)
    1879 (define-constant hash-table-new-length-factor 2)
    1880 
    1881 (define-constant hash-table-default-min-load 0.5)
    1882 (define-constant hash-table-default-max-load 0.8)
    1883 
    1884 ;; Restrict hash-table length to tabled lengths:
    1885 
    1886 (define (hash-table-canonical-length tab req)
    1887   (let loop ([tab tab])
    1888     (let ([cur (##sys#slot tab 0)]
    1889           [nxt (##sys#slot tab 1)])
    1890       (if (or (fx>= cur req)
    1891               (null? nxt))
    1892           cur
    1893           (loop nxt) ) ) ) )
    1894 
    1895 ;; "Raw" make-hash-table:
    1896 
    1897 (define %make-hash-table
    1898   (let ([make-vector make-vector])
    1899     (lambda (test hash len min-load max-load weak-keys weak-values initial
    1900              #!optional (vec (make-vector len '())))
    1901       (##sys#make-structure 'hash-table
    1902        vec 0 test hash min-load max-load #f #f initial) ) ) )
    1903 
    1904 ;; SRFI-69 & SRFI-90'ish.
    1905 ;;
    1906 ;; Argument list is the pattern
    1907 ;;
    1908 ;; (make-hash-table #!optional test hash size
    1909 ;;                  #!key test hash size initial min-load max-load weak-keys weak-values)
    1910 ;;
    1911 ;; where a keyword argument takes precedence over the corresponding optional
    1912 ;; argument. Keyword arguments MUST come after optional & required
    1913 ;; arugments.
    1914 ;;
    1915 ;; Wish DSSSL (extended) argument list processing Did-What-I-Want (DWIW).
    1916 
    1917 (define make-hash-table
    1918   (let ([core-eq? eq?]
    1919         [core-eqv? eqv?]
    1920         [core-equal? equal?]
    1921         [core-string=? string=?]
    1922         [core-string-ci=? string-ci=?]
    1923         [core= =] )
    1924     (lambda arguments0
    1925       (let ([arguments arguments0]
    1926             [test equal?]
    1927             [hash #f]
    1928             [size hash-table-default-length]
    1929             [initial #f]
    1930             [min-load hash-table-default-min-load]
    1931             [max-load hash-table-default-max-load]
    1932             [weak-keys #f]
    1933             [weak-values #f])
    1934         (let ([hash-for-test
    1935                 (lambda ()
    1936                   (cond [(or (eq? core-eq? test)
    1937                              (eq? eq? test))              eq?-hash]
    1938                         [(or (eq? core-eqv? test)
    1939                              (eq? eqv? test))             eqv?-hash]
    1940                         [(or (eq? core-equal? test)
    1941                              (eq? equal? test))           equal?-hash]
    1942                         [(or (eq? core-string=? test)
    1943                              (eq? string=? test))         string-hash]
    1944                         [(or (eq? core-string-ci=? test)
    1945                              (eq? string-ci=? test))      string-ci-hash]
    1946                         [(or (eq? core= test)
    1947                              (eq? = test))                number-hash]
    1948                         [else                             #f] ) ) ] )
    1949           ; Process optional arguments
    1950           (unless (null? arguments)
    1951             (let ([arg (car arguments)])
    1952               (unless (keyword? arg)
    1953                 (##sys#check-closure arg 'make-hash-table)
    1954                 (set! test arg)
    1955                 (set! arguments (cdr arguments)) ) ) )
    1956           (unless (null? arguments)
    1957             (let ([arg (car arguments)])
    1958               (unless (keyword? arg)
    1959                 (##sys#check-closure arg 'make-hash-table)
    1960                 (set! hash arg)
    1961                 (set! arguments (cdr arguments)) ) ) )
    1962           (unless (null? arguments)
    1963             (let ([arg (car arguments)])
    1964               (unless (keyword? arg)
    1965                 (##sys#check-exact arg 'make-hash-table)
    1966                 (unless (fx< 0 arg)
    1967                   (error 'make-hash-table "invalid size" arg) )
    1968                 (set! size (fxmin hash-table-max-size arg))
    1969                 (set! arguments (cdr arguments)) ) ) )
    1970           ; Process keyword arguments
    1971           (let loop ([args arguments])
    1972             (unless (null? args)
    1973               (let ([arg (car args)])
    1974                 (let ([invarg-err
    1975                         (lambda (msg)
    1976                           (error 'make-hash-table msg arg arguments0))])
    1977                   (if (keyword? arg)
    1978                       (let* ([nxt (cdr args)]
    1979                              [val (if (pair? nxt)
    1980                                       (car nxt)
    1981                                       (invarg-err "missing keyword value"))])
    1982                         (case arg
    1983                           [(#:test)
    1984                             (##sys#check-closure val 'make-hash-table)
    1985                             (set! test val)]
    1986                           [(#:hash)
    1987                             (##sys#check-closure val 'make-hash-table)
    1988                             (set! hash val)]
    1989                           [(#:size)
    1990                             (##sys#check-exact val 'make-hash-table)
    1991                             (unless (fx< 0 val)
    1992                               (error 'make-hash-table "invalid size" val) )
    1993                             (set! size (fxmin hash-table-max-size val))]
    1994                           [(#:initial)
    1995                             (set! initial (lambda () val))]
    1996                           [(#:min-load)
    1997                             (##sys#check-inexact val 'make-hash-table)
    1998                             (unless (and (fp< 0.0 val) (fp< val 1.0))
    1999                               (error 'make-hash-table "invalid min-load" val) )
    2000                             (set! min-load val)]
    2001                           [(#:max-load)
    2002                             (##sys#check-inexact val 'make-hash-table)
    2003                             (unless (and (fp< 0.0 val) (fp< val 1.0))
    2004                               (error 'make-hash-table "invalid max-load" val) )
    2005                             (set! max-load val)]
    2006                           [(#:weak-keys)
    2007                             (set! weak-keys (and val #t))]
    2008                           [(#:weak-values)
    2009                             (set! weak-values (and val #t))]
    2010                           [else
    2011                             (invarg-err "unknown keyword")])
    2012                         (loop (cdr nxt)) )
    2013                       (invarg-err "missing keyword") ) ) ) ) )
    2014           ; Load must be a proper interval
    2015           (when (fp< max-load min-load)
    2016             (error 'make-hash-table "min-load greater than max-load" min-load max-load) )
    2017           ; Force canonical hash-table vector length
    2018           (set! size (hash-table-canonical-length hash-table-prime-lengths size))
    2019           ; Decide on a hash function when not supplied
    2020           (unless hash
    2021             (let ([func (hash-for-test)])
    2022               (if func
    2023                   (set! hash func)
    2024                   (begin
    2025                     (warning 'make-hash-table "user test without user hash")
    2026                     (set! hash equal?-hash) ) ) ) )
    2027           ; Done
    2028           (%make-hash-table test hash size min-load max-load weak-keys weak-values initial) ) ) ) ) )
    2029 
    2030 ;; Hash-Table Predicate:
    2031 
    2032 (define (hash-table? obj)
    2033   (##sys#structure? obj 'hash-table) )
    2034 
    2035 ;; Hash-Table Properties:
    2036 
    2037 (define (hash-table-size ht)
    2038   (##sys#check-structure ht 'hash-table 'hash-table-size)
    2039   (##sys#slot ht 2) )
    2040 
    2041 (define (hash-table-equivalence-function ht)
    2042   (##sys#check-structure ht 'hash-table 'hash-table-equivalence-function)
    2043   (##sys#slot ht 3) )
    2044 
    2045 (define (hash-table-hash-function ht)
    2046   (##sys#check-structure ht 'hash-table 'hash-table-hash-function)
    2047   (##sys#slot ht 4) )
    2048 
    2049 (define (hash-table-min-load ht)
    2050   (##sys#check-structure ht 'hash-table 'hash-table-min-load)
    2051   (##sys#slot ht 5) )
    2052 
    2053 (define (hash-table-max-load ht)
    2054   (##sys#check-structure ht 'hash-table 'hash-table-max-load)
    2055   (##sys#slot ht 6) )
    2056 
    2057 (define (hash-table-weak-keys ht)
    2058   (##sys#check-structure ht 'hash-table 'hash-table-weak-keys)
    2059   (##sys#slot ht 7) )
    2060 
    2061 (define (hash-table-weak-values ht)
    2062   (##sys#check-structure ht 'hash-table 'hash-table-weak-values)
    2063   (##sys#slot ht 8) )
    2064 
    2065 (define (hash-table-has-initial? ht)
    2066   (##sys#check-structure ht 'hash-table 'hash-table-has-initial?)
    2067   (and (##sys#slot ht 9)
    2068        #t ) )
    2069 
    2070 (define (hash-table-initial ht)
    2071   (##sys#check-structure ht 'hash-table 'hash-table-initial)
    2072   (and-let* ([thunk (##sys#slot ht 9)])
    2073     (thunk) ) )
    2074 
    2075 ;; hash-table-copy:
    2076 
    2077 (define %hash-table-copy
    2078   (let ([make-vector make-vector])
    2079     (lambda (ht)
    2080       (let* ([vec1 (##sys#slot ht 1)]
    2081              [len (##sys#size vec1)]
    2082              [vec2 (make-vector len '())] )
    2083         (do ([i 0 (fx+ i 1)])
    2084             [(fx>= i len)
    2085              (%make-hash-table
    2086               (##sys#slot ht 3) (##sys#slot ht 4)
    2087               (##sys#slot ht 2)
    2088               (##sys#slot ht 5) (##sys#slot ht 6)
    2089               (##sys#slot ht 7) (##sys#slot ht 8)
    2090               (##sys#slot ht 9)
    2091               vec2)]
    2092           (##sys#setslot vec2 i
    2093            (let copy-loop ([bucket (##sys#slot vec1 i)])
    2094              (if (null? bucket)
    2095                  '()
    2096                  (let ([pare (##sys#slot bucket 0)])
    2097                    (cons (cons (##sys#slot pare 0) (##sys#slot pare 1))
    2098                          (copy-loop (##sys#slot bucket 1))))))) ) ) ) ) )
    2099 
    2100 (define (hash-table-copy ht)
    2101   (##sys#check-structure ht 'hash-table 'hash-table-copy)
    2102   (%hash-table-copy ht) )
    2103 
    2104 ;; hash-table-update!:
    2105 ;;
    2106 ;; This one was suggested by Sven Hartrumpf (and subsequently added in SRFI-69).
    2107 ;; Modified for ht props min & max load.
    2108 
    2109 (define (hash-table-rehash vec1 vec2 hash)
    2110   (let ([len1 (##sys#size vec1)]
    2111         [len2 (##sys#size vec2)] )
    2112     (do ([i 0 (fx+ i 1)])
    2113         [(fx>= i len1)]
    2114       (let loop ([bucket (##sys#slot vec1 i)])
    2115         (unless (null? bucket)
    2116           (let* ([pare (##sys#slot bucket 0)]
    2117                  [key (##sys#slot pare 0)]
    2118                  [hshidx (hash key len2)] )
    2119             (##sys#setslot vec2 hshidx
    2120                            (cons (cons key (##sys#slot pare 1))
    2121                                  (##sys#slot vec2 hshidx)))
    2122             (loop (##sys#slot bucket 1)) ) ) ) ) ) )
    2123 
    2124 (define %hash-table-update!
    2125   (let ([core-eq? eq?]
    2126         [floor floor] )
    2127     (lambda (ht key func thunk)
    2128       (let ([hash (##sys#slot ht 4)]
    2129             [test (##sys#slot ht 3)]
    2130             [newsiz (fx+ (##sys#slot ht 2) 1)]
    2131             [min-load (##sys#slot ht 5)]
    2132             [max-load (##sys#slot ht 6)] )
    2133         (let re-enter ()
    2134           (let* ([vec (##sys#slot ht 1)]
    2135                  [len (##sys#size vec)] )
    2136             (let ([min-load-len (inexact->exact (floor (* len min-load)))]
    2137                   [max-load-len (inexact->exact (floor (* len max-load)))]
    2138                   [hshidx (hash key len)] )
    2139               ; Need to resize table?
    2140               (if (and (fx< len hash-table-max-length)
    2141                        (fx<= min-load-len newsiz) (fx<= newsiz max-load-len))
    2142                   ; then resize the table:
    2143                   (let ([vec2 (make-vector
    2144                                (hash-table-canonical-length
    2145                                 hash-table-prime-lengths
    2146                                 (fxmin hash-table-max-length
    2147                                        (fx* len hash-table-new-length-factor)))
    2148                                '())])
    2149                     (hash-table-rehash vec vec2 hash)
    2150                     (##sys#setslot ht 1 vec2)
    2151                     (re-enter) )
    2152                   ; else update the table:
    2153                   (let ([bucket0 (##sys#slot vec hshidx)])
    2154                     (if (eq? core-eq? test)
    2155                         ; Fast path (eq? is rewritten by the compiler):
    2156                         (let loop ([bucket bucket0])
    2157                           (cond [(null? bucket)
    2158                                  (let ([val (func (thunk))])
    2159                                    (##sys#setslot vec hshidx (cons (cons key val) bucket0))
    2160                                    (##sys#setslot ht 2 newsiz)
    2161                                    val) ]
    2162                                 [else
    2163                                  (let ([pare (##sys#slot bucket 0)])
    2164                                    (if (eq? key (##sys#slot pare 0))
    2165                                        (let ([val (func (##sys#slot pare 1))])
    2166                                          (##sys#setslot pare 1 val)
    2167                                          val)
    2168                                        (loop (##sys#slot bucket 1)) ) ) ] ) )
    2169                         ; Slow path
    2170                         (let loop ([bucket bucket0])
    2171                           (cond [(null? bucket)
    2172                                  (let ([val (func (thunk))])
    2173                                    (##sys#setslot vec hshidx (cons (cons key val) bucket0))
    2174                                    (##sys#setslot ht 2 newsiz)
    2175                                    val) ]
    2176                                 [else
    2177                                  (let ([pare (##sys#slot bucket 0)])
    2178                                    (if (test key (##sys#slot pare 0))
    2179                                        (let ([val (func (##sys#slot pare 1))])
    2180                                          (##sys#setslot pare 1 val)
    2181                                          val)
    2182                                        (loop (##sys#slot bucket 1)) ) ) ] ) ) ) ) ) ) ) ) ) ) ) )
    2183 
    2184 (define (hash-table-update!
    2185          ht key
    2186          #!optional (func identity)
    2187                     (thunk
    2188                      (let ([thunk (##sys#slot ht 9)])
    2189                        (or thunk
    2190                            (lambda ()
    2191                              (##sys#signal-hook #:access-error
    2192                               'hash-table-update!
    2193                               "hash-table does not contain key" key ht))))))
    2194   (##sys#check-structure ht 'hash-table 'hash-table-update!)
    2195   (##sys#check-closure func 'hash-table-update!)
    2196   (##sys#check-closure thunk 'hash-table-update!)
    2197   (%hash-table-update! ht key func thunk) )
    2198 
    2199 (define (hash-table-update!/default ht key func def)
    2200   (##sys#check-structure ht 'hash-table 'hash-table-update!/default)
    2201   (##sys#check-closure func 'hash-table-update!/default)
    2202   (%hash-table-update! ht key func (lambda () def)) )
    2203 
    2204 (define (hash-table-set! ht key val)
    2205   (##sys#check-structure ht 'hash-table 'hash-table-set!)
    2206   (let ([thunk (lambda _ val)])
    2207     (%hash-table-update! ht key thunk thunk) )
    2208   (void) )
    2209 
    2210 ;; Hash-Table Reference:
    2211 
    2212 (define %hash-table-ref
    2213   (let ([core-eq? eq?])
    2214     (lambda (ht key def)
    2215        (let  ([vec (##sys#slot ht 1)]
    2216               [test (##sys#slot ht 3)] )
    2217          (let* ([hash (##sys#slot ht 4)]
    2218                 [hshidx (hash key (##sys#size vec))] )
    2219            (if (eq? core-eq? test)
    2220                ; Fast path (eq? is rewritten by the compiler):
    2221                (let loop ([bucket (##sys#slot vec hshidx)])
    2222                  (if (null? bucket)
    2223                      (def)
    2224                      (let ([pare (##sys#slot bucket 0)])
    2225                        (if (eq? key (##sys#slot pare 0))
    2226                            (##sys#slot pare 1)
    2227                            (loop (##sys#slot bucket 1)) ) ) ) )
    2228                ; Slow path
    2229                (let loop ([bucket (##sys#slot vec hshidx)])
    2230                  (if (null? bucket)
    2231                      (def)
    2232                      (let ([pare (##sys#slot bucket 0)])
    2233                        (if (test key (##sys#slot pare 0))
    2234                            (##sys#slot pare 1)
    2235                            (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
    2236 
    2237 (define hash-table-ref
    2238   (getter-with-setter
    2239    (lambda (ht key #!optional (def (lambda ()
    2240                                      (##sys#signal-hook #:access-error
    2241                                       'hash-table-ref
    2242                                       "hash-table does not contain key" key ht))))
    2243      (##sys#check-structure ht 'hash-table 'hash-table-ref)
    2244      (##sys#check-closure def 'hash-table-ref)
    2245      (%hash-table-ref ht key def) )
    2246    hash-table-set!))
    2247 
    2248 (define (hash-table-ref/default ht key default)
    2249   (##sys#check-structure ht 'hash-table 'hash-table-ref/default)
    2250   (%hash-table-ref ht key (lambda () default)) )
    2251 
    2252 (define (hash-table-exists? ht key)
    2253   (##sys#check-structure ht 'hash-table 'hash-table-exists?)
    2254   (not ($unbound? (%hash-table-ref ht key unbound-value-thunk))) )
    2255 
    2256 ;; hash-table-delete!:
    2257 
    2258 (define hash-table-delete!
    2259   (let ([core-eq? eq?])
    2260     (lambda (ht key)
    2261       (##sys#check-structure ht 'hash-table 'hash-table-delete!)
    2262       (let* ([vec (##sys#slot ht 1)]
    2263              [len (##sys#size vec)] )
    2264         (let* ([hash (##sys#slot ht 4)]
    2265                [hshidx (hash key len)] )
    2266           (let ([test (##sys#slot ht 3)]
    2267                 [newsiz (fx- (##sys#slot ht 2) 1)]
    2268                 [bucket0 (##sys#slot vec hshidx)] )
    2269             (if (eq? core-eq? test)
    2270                 ; Fast path (eq? is rewritten by the compiler):
    2271                 (let loop ([prev #f] [bucket bucket0])
    2272                   (and (not (null? bucket))
    2273                        (let ([pare (##sys#slot bucket 0)]
    2274                              [nxt (##sys#slot bucket 1)])
    2275                          (if (eq? key (##sys#slot pare 0))
    2276                              (begin
    2277                                (if prev
    2278                                    (##sys#setslot prev 1 nxt)
    2279                                    (##sys#setslot vec hshidx nxt) )
    2280                                (##sys#setslot ht 2 newsiz)
    2281                                #t )
    2282                              (loop bucket nxt) ) ) ) )
    2283                 ; Slow path
    2284                 (let loop ([prev #f] [bucket bucket0])
    2285                   (and (not (null? bucket))
    2286                        (let ([pare (##sys#slot bucket 0)]
    2287                              [nxt (##sys#slot bucket 1)])
    2288                          (if (test key (##sys#slot pare 0))
    2289                              (begin
    2290                                (if prev
    2291                                    (##sys#setslot prev 1 nxt)
    2292                                    (##sys#setslot vec hshidx nxt) )
    2293                                (##sys#setslot ht 2 newsiz)
    2294                                #t )
    2295                              (loop bucket nxt) ) ) ) ) ) ) ) ) ) ) )
    2296 
    2297 ;; hash-table-remove!:
    2298 
    2299 (define (hash-table-remove! ht func)
    2300   (##sys#check-structure ht 'hash-table 'hash-table-remove!)
    2301   (##sys#check-closure func 'hash-table-remove!)
    2302   (let* ([vec (##sys#slot ht 1)]
    2303          [len (##sys#size vec)] )
    2304     (let ([siz (##sys#slot ht 2)])
    2305       (do ([i 0 (fx+ i 1)])
    2306           [(fx>= i len) (##sys#setislot ht 2 siz)]
    2307         (let loop ([prev #f] [bucket (##sys#slot vec i)])
    2308           (and (not (null? bucket))
    2309                (let ([pare (##sys#slot bucket 0)]
    2310                      [nxt (##sys#slot bucket 1)])
    2311                  (if (func (##sys#slot pare 0) (##sys#slot pare 1))
    2312                      (begin
    2313                        (if prev
    2314                            (##sys#setslot prev 1 nxt)
    2315                            (##sys#setslot vec i nxt) )
    2316                        (set! siz (fx- siz 1))
    2317                        #t )
    2318                      (loop bucket nxt ) ) ) ) ) ) ) ) )
    2319 
    2320 ;; Hash Table Merge:
    2321 
    2322 (define (%hash-table-merge! ht1 ht2)
    2323   (let* ([vec (##sys#slot ht2 1)]
    2324          [len (##sys#size vec)] )
    2325     (do ([i 0 (fx+ i 1)])
    2326         [(fx>= i len) ht1]
    2327       (do ([lst (##sys#slot vec i) (##sys#slot lst 1)])
    2328           [(null? lst)]
    2329         (let ([b (##sys#slot lst 0)])
    2330           (%hash-table-update! ht1 (##sys#slot b 0)
    2331                                    identity (lambda () (##sys#slot b 1))) ) ) ) ) )
    2332 
    2333 (define (hash-table-merge! ht1 ht2)
    2334   (##sys#check-structure ht1 'hash-table 'hash-table-merge!)
    2335   (##sys#check-structure ht2 'hash-table 'hash-table-merge!)
    2336   (%hash-table-merge! ht1 ht2) )
    2337 
    2338 (define (hash-table-merge ht1 ht2)
    2339   (##sys#check-structure ht1 'hash-table 'hash-table-merge)
    2340   (##sys#check-structure ht2 'hash-table 'hash-table-merge)
    2341   (%hash-table-merge! (%hash-table-copy ht1) ht2) )
    2342 
    2343 ;; Hash-Table <-> Association-List:
    2344 
    2345 (define (hash-table->alist ht)
    2346   (##sys#check-structure ht 'hash-table 'hash-table->alist)
    2347   (let* ([vec (##sys#slot ht 1)]
    2348          [len (##sys#size vec)] )
    2349     (let loop ([i 0] [lst '()])
    2350       (if (fx>= i len)
    2351           lst
    2352           (let loop2 ([bucket (##sys#slot vec i)]
    2353                       [lst lst])
    2354             (if (null? bucket)
    2355                 (loop (fx+ i 1) lst)
    2356                 (loop2 (##sys#slot bucket 1)
    2357                        (let ([x (##sys#slot bucket 0)])
    2358                          (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )
    2359 
    2360 (define alist->hash-table
    2361   (let ([make-hash-table make-hash-table])
    2362     (lambda (alist . rest)
    2363       (##sys#check-list alist 'alist->hash-table)
    2364       (let ([ht (apply make-hash-table rest)])
    2365         (for-each (lambda (x)
    2366                     (%hash-table-update! ht (##sys#slot x 0)
    2367                                             identity (lambda () (##sys#slot x 1))) )
    2368                   alist)
    2369         ht ) ) ) )
    2370 
    2371 ;; Hash-Table Keys & Values:
    2372 
    2373 (define (hash-table-keys ht)
    2374   (##sys#check-structure ht 'hash-table 'hash-table-keys)
    2375   (let* ([vec (##sys#slot ht 1)]
    2376          [len (##sys#size vec)] )
    2377     (let loop ([i 0] [lst '()])
    2378       (if (fx>= i len)
    2379           lst
    2380           (let loop2 ([bucket (##sys#slot vec i)]
    2381                       [lst lst])
    2382             (if (null? bucket)
    2383                 (loop (fx+ i 1) lst)
    2384                 (loop2 (##sys#slot bucket 1)
    2385                        (let ([x (##sys#slot bucket 0)])
    2386                          (cons (##sys#slot x 0) lst) ) ) ) ) ) ) ) )
    2387 
    2388 (define (hash-table-values ht)
    2389   (##sys#check-structure ht 'hash-table 'hash-table-values)
    2390   (let* ([vec (##sys#slot ht 1)]
    2391          [len (##sys#size vec)] )
    2392     (let loop ([i 0] [lst '()])
    2393       (if (fx>= i len)
    2394           lst
    2395           (let loop2 ([bucket (##sys#slot vec i)]
    2396                       [lst lst])
    2397             (if (null? bucket)
    2398                 (loop (fx+ i 1) lst)
    2399                 (loop2 (##sys#slot bucket 1)
    2400                        (let ([x (##sys#slot bucket 0)])
    2401                          (cons (##sys#slot x 1) lst) ) ) ) ) ) ) ) )
    2402 
    2403 ;; Mapping Over Hash-Table Keys & Values:
    2404 ;;
    2405 ;; hash-table-for-each:
    2406 ;; hash-table-walk:
    2407 ;; hash-table-fold:
    2408 ;; hash-table-map:
    2409 
    2410 (define (%hash-table-for-each ht proc)
    2411   (let* ([vec (##sys#slot ht 1)]
    2412          [len (##sys#size vec)] )
    2413     (do ([i 0 (fx+ i 1)] )
    2414         [(fx>= i len)]
    2415       (##sys#for-each (lambda (bucket)
    2416                         (proc (##sys#slot bucket 0) (##sys#slot bucket 1)) )
    2417                       (##sys#slot vec i)) ) ) )
    2418 
    2419 (define (%hash-table-fold ht func init)
    2420   (let* ([vec (##sys#slot ht 1)]
    2421          [len (##sys#size vec)] )
    2422     (let loop ([i 0] [acc init])
    2423       (if (fx>= i len)
    2424           acc
    2425           (let fold2 ([bucket (##sys#slot vec i)]
    2426                       [acc acc])
    2427             (if (null? bucket)
    2428                 (loop (fx+ i 1) acc)
    2429                 (let ([pare (##sys#slot bucket 0)])
    2430                   (fold2 (##sys#slot bucket 1)
    2431                          (func (##sys#slot pare 0) (##sys#slot pare 1) acc) ) ) ) ) ) ) ) )
    2432 
    2433 (define (hash-table-fold ht func init)
    2434   (##sys#check-structure ht 'hash-table 'hash-table-fold)
    2435   (##sys#check-closure func 'hash-table-fold)
    2436   (%hash-table-fold ht func init) )
    2437 
    2438 (define (hash-table-for-each ht proc)
    2439   (##sys#check-structure ht 'hash-table 'hash-table-for-each)
    2440   (##sys#check-closure proc 'hash-table-for-each)
    2441   (%hash-table-for-each ht proc) )
    2442 
    2443 (define (hash-table-walk ht proc)
    2444   (##sys#check-structure ht 'hash-table 'hash-table-walk)
    2445   (##sys#check-closure proc 'hash-table-walk)
    2446   (%hash-table-for-each ht proc) )
    2447 
    2448 (define (hash-table-map ht func)
    2449   (##sys#check-structure ht 'hash-table 'hash-table-map)
    2450   (##sys#check-closure func 'hash-table-map)
    2451   (%hash-table-fold ht (lambda (k v a) (cons (func k v) a)) '()) )
    2452 
    2453 ;; Done with Hash-Tables:
    2454 
    2455 (register-feature! 'srfi-69)
    2456 
    2457 
    2458 ; Support for queues
    2459 ;
    2460 ; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
    2461 ;
    2462 ; This code is in the public domain.
    2463 ;
    2464 ; (heavily adapated for use with CHICKEN by felix)
    2465 ;
    2466 
    2467 
    2468 ; Elements in a queue are stored in a list.  The last pair in the list
    2469 ; is stored in the queue type so that datums can be added in constant
    2470 ; time.
    2471 
    2472 (define (make-queue) (##sys#make-structure 'queue '() '()))
    2473 (define (queue? x) (##sys#structure? x 'queue))
    2474 
    2475 (define (queue-empty? q)
    2476   (##sys#check-structure q 'queue 'queue-empty?)
    2477   (eq? '() (##sys#slot q 1)) )
    2478 
    2479 (define queue-first
    2480   (lambda (q)
    2481     (##sys#check-structure q 'queue 'queue-first)
    2482     (let ((first-pair (##sys#slot q 1)))
    2483       (cond-expand
    2484        [(not unsafe)
    2485         (when (eq? '() first-pair)
    2486           (##sys#error 'queue-first "queue is empty" q)) ]
    2487        [else] )
    2488       (##sys#slot first-pair 0) ) ) )
    2489 
    2490 (define queue-last
    2491   (lambda (q)
    2492     (##sys#check-structure q 'queue 'queue-last)
    2493     (let ((last-pair (##sys#slot q 2)))
    2494       (cond-expand
    2495        [(not unsafe)
    2496         (when (eq? '() last-pair)
    2497           (##sys#error 'queue-last "queue is empty" q)) ]
    2498        [else] )
    2499       (##sys#slot last-pair 0) ) ) )
    2500 
    2501 (define (queue-add! q datum)
    2502   (##sys#check-structure q 'queue 'queue-add!)
    2503   (let ((new-pair (cons datum '())))
    2504     (cond ((eq? '() (##sys#slot q 1)) (##sys#setslot q 1 new-pair))
    2505           (else (##sys#setslot (##sys#slot q 2) 1 new-pair)) )
    2506     (##sys#setslot q 2 new-pair)
    2507     (##core#undefined) ) )
    2508 
    2509 (define queue-remove!
    2510   (lambda (q)
    2511     (##sys#check-structure q 'queue 'queue-remove!)
    2512     (let ((first-pair (##sys#slot q 1)))
    2513       (cond-expand
    2514        [(not unsafe)
    2515         (when (eq? '() first-pair)
    2516           (##sys#error 'queue-remove! "queue is empty" q) ) ]
    2517        [else] )
    2518       (let ((first-cdr (##sys#slot first-pair 1)))
    2519         (##sys#setslot q 1 first-cdr)
    2520         (if (eq? '() first-cdr)
    2521             (##sys#setslot q 2 '()) )
    2522         (##sys#slot first-pair 0) ) ) ) )
    2523 
    2524 (define (queue->list q)
    2525   (##sys#check-structure q 'queue 'queue->list)
    2526   (##sys#slot q 1) )
    2527 
    2528 (define (list->queue lst0)
    2529   (##sys#check-list lst0 'list->queue)
    2530   (##sys#make-structure
    2531    'queue lst0
    2532    (if (eq? lst0 '())
    2533        '()
    2534        (do ((lst lst0 (##sys#slot lst 1)))
    2535            ((eq? (##sys#slot lst 1) '()) lst)
    2536          (if (or (not (##core#inline "C_blockp" lst))
    2537                  (not (##core#inline "C_pairp" lst)) )
    2538              (##sys#not-a-proper-list-error lst0 'list->queue) ) ) ) ) )
    2539 
    2540 
    2541 ; (queue-push-back! queue item)
    2542 ; Pushes an item into the first position of a queue.
    2543 
    2544 (define (queue-push-back! q item)
    2545   (##sys#check-structure q 'queue 'queue-push-back!)
    2546   (let ((newlist (cons item (##sys#slot q 1))))
    2547     (##sys#setslot q 1 newlist)
    2548     (if (eq? '() (##sys#slot q 2))
    2549         (##sys#setslot q 2 newlist))))
    2550 
    2551 ; (queue-push-back-list! queue item-list)
    2552 ; Pushes the items in item-list back onto the queue,
    2553 ; so that (car item-list) becomes the next removable item.
    2554 
    2555 (define-macro (last-pair lst0)
    2556   `(do ((lst ,lst0 (##sys#slot lst 1)))
    2557        ((eq? (##sys#slot lst 1) '()) lst)))
    2558 
    2559 (define (queue-push-back-list! q itemlist)
    2560   (##sys#check-structure q 'queue 'queue-push-back-list!)
    2561   (##sys#check-list itemlist 'queue-push-back-list!)
    2562   (let* ((newlist (append itemlist (##sys#slot q 1)))
    2563          (newtail (if (eq? newlist '())
    2564                        '()
    2565                        (last-pair newlist))))
    2566     (##sys#setslot q 1 newlist)
    2567     (##sys#setslot q 2 newtail)))
  • chicken/branches/release/library.scm

    r10108 r10653  
    11721172(define (symbol->string s)
    11731173  (##sys#check-symbol s 'symbol->string)
    1174   (##sys#symbol->string s) )
     1174  (string-copy (##sys#symbol->string s) ) )
    11751175
    11761176(define string->symbol
     
    32773277             (string-append "\t[" spec " ]") )
    32783278         (if (not (zero? rev))
    3279              (##sys#string-append "\nSVN rev. " (number->string rev))
    3280              "")
    3281          "\t" +build-tag+))
     3279             (string-append
     3280              "\nSVN rev. " (number->string rev) "\t")
     3281             "\n")
     3282         +build-tag+))
    32823283      +build-version+) )
    32833284
  • chicken/branches/release/lolevel.scm

    r10108 r10653  
    2828(declare
    2929  (unit lolevel)
    30   (uses extras)
    3130  (usual-integrations)
    3231  (disable-warning var redef)
     
    5453    (no-procedure-checks-for-usual-bindings)
    5554    (bound-to-procedure
    56      ##sys#symbol-hash-toplevel-binding? ##sys#make-locative ##sys#become! make-hash-table
    57      hash-table-ref/default ##sys#make-string make-vector hash-table-set! hash-table-set!
     55     ##sys#hash-table-ref ##sys#hash-table-set!
     56     ##sys#make-locative ##sys#become!
     57     ##sys#make-string
    5858     make-property-condition make-composite-condition signal ##sys#set-pointer-address! ##sys#make-vector
    5959     ##sys#make-pointer make-string make-byte-vector ##sys#not-a-proper-list-error ##sys#check-pointer
     
    461461;;; Copy arbitrary object:
    462462
    463 (define object-copy
    464   (let ([make-vector make-vector])
    465     (lambda (x)
    466       (let copy ([x x])
    467         (cond [(not (##core#inline "C_blockp" x)) x]
    468               [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
    469               [else
    470                (let* ([n (##sys#size x)]
    471                       [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
    472                       [y (##core#inline "C_copy_block" x (make-vector words))] )
    473                  (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
    474                    (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    475                        ((fx>= i n))
    476                      (##sys#setslot y i (copy (##sys#slot y i))) ) )
    477                  y) ] ) ) ) ) )
     463(define (object-copy x)
     464  (let copy ([x x])
     465    (cond [(not (##core#inline "C_blockp" x)) x]
     466          [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
     467          [else
     468            (let* ([n (##sys#size x)]
     469                   [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
     470                   [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
     471              (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
     472                (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     473                    ((fx>= i n))
     474                  (##sys#setslot y i (copy (##sys#slot y i))) ) )
     475              y) ] ) ) )
    478476
    479477
    480478;;; Evict objects into static memory:
     479
     480(define-constant evict-table-size 301)
    481481
    482482(define (object-evicted? x) (##core#inline "C_permanentp" x))
     
    488488                 (car allocator)
    489489                 (foreign-lambda c-pointer "C_malloc" int) ) ]
    490             [tab (make-hash-table eq?)] )
     490            [tab (##sys#make-vector evict-table-size '())] )
    491491        (let evict ([x x])
    492492          (cond [(not (##core#inline "C_blockp" x)) x]
    493                 [(hash-table-ref/default tab x #f)]
     493                [(##sys#hash-table-ref tab x)]
    494494                [else
    495495                 (let* ([n (##sys#size x)]
     
    497497                        [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
    498498                   (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
    499                    (hash-table-set! tab x y)
     499                   (##sys#hash-table-set! tab x y)
    500500                   (unless (##core#inline "C_byteblockp" x)
    501501                     (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
     
    538538                  #f) ]
    539539             [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
    540              [tab (make-hash-table eq?)]
     540             [tab (##sys#make-vector evict-table-size '())]
    541541             [x2
    542542              (let evict ([x x])
    543543                (cond [(not (##core#inline "C_blockp" x)) x]
    544                       [(hash-table-ref/default tab x #f)]
     544                      [(##sys#hash-table-ref tab x)]
    545545                      [else
    546546                       (let* ([n (##sys#size x)]
     
    561561                           (when (symbol? x) (##sys#setislot y 0 (##core#undefined)))
    562562                           (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
    563                            (hash-table-set! tab x y)
     563                           (##sys#hash-table-set! tab x y)
    564564                           (unless (##core#inline "C_byteblockp" x)
    565565                             (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
     
    574574(define object-size
    575575    (lambda (x)
    576       (let ([tab (make-hash-table eq?)])
     576      (let ([tab (##sys#make-vector evict-table-size '())])
    577577        (let evict ([x x])
    578578          (cond [(not (##core#inline "C_blockp" x)) 0]
    579                 [(hash-table-ref/default tab x #f) 0]
     579                [(##sys#hash-table-ref tab x) 0]
    580580                [else
    581581                 (let* ([n (##sys#size x)]
     
    583583                         (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
    584584                              (##core#inline "C_bytes" 1) ) ] )
    585                    (hash-table-set! tab x #t)
     585                   (##sys#hash-table-set! tab x #t)
    586586                   (unless (##core#inline "C_byteblockp" x)
    587587                     (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
     
    597597      (define (err x)
    598598        (##sys#signal-hook #:type-error 'object-unevict "can not copy object" x) )
    599       (let ([tab (make-hash-table eq?)])
     599      (let ([tab (##sys#make-vector evict-table-size '())])
    600600        (let copy ([x x])
    601601          (cond [(not (##core#inline "C_blockp" x)) x]
    602602                [(not (##core#inline "C_permanentp" x)) x]
    603                 [(hash-table-ref/default tab x #f)]
     603                [(##sys#hash-table-ref tab x)]
    604604                [(##core#inline "C_byteblockp" x)
    605605                 (if full
    606606                     (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
    607                        (hash-table-set! tab x y)
     607                       (##sys#hash-table-set! tab x y)
    608608                       y)
    609609                     x) ]
    610610                [(symbol? x)
    611611                 (let ([y (##sys#intern-symbol (##sys#slot x 1))])
    612                    (hash-table-set! tab x y)
     612                   (##sys#hash-table-set! tab x y)
    613613                   y) ]
    614614                [else
    615615                 (let* ([words (##sys#size x)]
    616                         [y (##core#inline "C_copy_block" x (make-vector words))] )
    617                    (hash-table-set! tab x y)
     616                        [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
     617                   (##sys#hash-table-set! tab x y)
    618618                   (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    619619                       ((fx>= i words))
     
    648648  (let* ((n (##sys#size old))
    649649         (words (##core#inline "C_words" n))
    650          (y (##core#inline "C_copy_block" old (make-vector words))) )
     650         (y (##core#inline "C_copy_block" old (##sys#make-vector words))) )
    651651    (##sys#become! (list (cons old (proc y))))
    652652    y) )
  • chicken/branches/release/manual/Acknowledgements

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

    r5945 r10653  
    5454dynamically into a running application.
    5555
    56 Previous: [[The User's Manual]]
     56Previous: [[Getting started]]
    5757Next: [[Using the compiler]]
  • chicken/branches/release/manual/Non-standard read syntax

    r5945 r10653  
    1515 #;EXPRESSION
    1616
    17 Treats {{EXPRESSION}} as a comment.
    18 
     17Treats {{EXPRESSION}} as a comment.  That is, the comment runs through the whole S-expression, regardless of newlines, which saves you from having to comment out every line, or add a newline in the middle of your parens to make the commenting of the last line work, or other things like that.
    1918=== External Representation
    2019
  • chicken/branches/release/manual/Supported language

    r5945 r10653  
    1313* [[Unit library]] basic Scheme definitions
    1414* [[Unit eval]] evaluation and macro-handling
     15* [[Unit data-structures]] data structures
    1516* [[Unit extras]] useful utility definitions
    16 * [[Unit srfi-1]] List Library
    17 * [[Unit srfi-4]] Homogeneous numeric vectors
    18 * [[Unit srfi-13]] String library
     17* [[Unit srfi-1]] list library
     18* [[Unit srfi-4]] homogeneous numeric vectors
     19* [[Unit srfi-13]] string library
    1920* [[Unit srfi-14]] character set library             
     21* [[Unit srfi-69]] hash tables             
    2022* [[Unit match]] pattern matching runtime-support
    2123* [[Unit regex]] regular expressions
  • chicken/branches/release/manual/The User's Manual

    r10109 r10653  
    33== The User's Manual
    44
    5 This is the user's manual for the Chicken Scheme compiler, version 3.1.0
     5This is the user's manual for the Chicken Scheme compiler, version 3.2.0
    66
    7 ; [[Overview]] : What is Chicken?
     7; [[Getting started]] : What is CHICKEN and how do I use it?
    88
    99; [[Basic mode of operation]] : Compiling Scheme files.
  • chicken/branches/release/manual/Unit extras

    r10108 r10653  
    44== Unit extras
    55
    6 This unit contains a collection of useful utility definitions.
     6This unit contains a collection of useful utility definitions. 
    77This unit is used by default, unless the program
    88is compiled with the {{-explicit-use}} option.
    9 
    10 
    11 
    12 === Lists
    13 
    14 
    15 ==== alist-ref
    16 
    17  [procedure] (alist-ref KEY ALIST [TEST [DEFAULT]])
    18 
    19 Looks up {{KEY}} in {{ALIST}} using {{TEST}} as the comparison function (or {{eqv?}} if
    20 no test was given) and returns the cdr of the found pair, or {{DEFAULT}} (which defaults to {{#f}}).
    21 
    22 
    23 ==== alist-update!
    24 
    25  [procedure] (alist-update! KEY VALUE ALIST [TEST])
    26 
    27 If the list {{ALIST}} contains a pair of the form {{(KEY . X)}}, then this procedure
    28 replaces {{X}} with {{VALUE}} and returns {{ALIST}}. If {{ALIST}} contains no such item, then
    29 {{alist-update!}} returns {{((KEY . VALUE) . ALIST)}}. The optional argument
    30 {{TEST}} specifies the comparison procedure to search a matching pair in {{ALIST}}
    31 and defaults to {{eqv?}}.
    32 
    33 
    34 ==== atom?
    35 
    36  [procedure] (atom? X)
    37 
    38 Returns {{#t}} if {{X}} is not a pair. This is identical to {{not-pair?}} from [[Unit srfi-1]] but
    39 kept for historical reasons.
    40 
    41 
    42 ==== rassoc
    43 
    44  [procedure] (rassoc KEY LIST [TEST])
    45 
    46 Similar to {{assoc}}, but compares {{KEY}} with the {{cdr}} of each pair in {{LIST}} using
    47 {{TEST}} as the comparison procedures (which defaults to {{eqv?}}.
    48 
    49 
    50 ==== butlast
    51 
    52  [procedure] (butlast LIST)
    53 
    54 Returns a fresh list with all elements but the last of {{LIST}}.
    55 
    56 
    57 ==== chop
    58 
    59  [procedure] (chop LIST N)
    60 
    61 Returns a new list of sublists, where each sublist contains {{N}}
    62 elements of {{LIST}}. If {{LIST}} has a length that is not
    63 a multiple of {{N}}, then the last sublist contains the remaining
    64 elements.
    65 
    66 <enscript highlight=scheme>
    67 (chop '(1 2 3 4 5 6) 2) ==> ((1 2) (3 4) (5 6))
    68 (chop '(a b c d) 3)     ==> ((a b c) (d))
    69 </enscript>
    70 
    71 
    72 ==== compress
    73 
    74  [procedure] (compress BLIST LIST)
    75 
    76 Returns a new list with elements taken from {{LIST}} with
    77 corresponding true values in the list {{BLIST}}.
    78 
    79 <enscript highlight=scheme>
    80 (define nums '(99 100 110 401 1234))
    81 (compress (map odd? nums) nums)      ==> (99 401)
    82 </enscript>
    83 
    84 
    85 ==== flatten
    86 
    87  [procedure] (flatten LIST1 ...)
    88 
    89 Returns {{LIST1 ...}} concatenated together, with nested lists
    90 removed (flattened).
    91 
    92 
    93 ==== intersperse
    94 
    95  [procedure] (intersperse LIST X)
    96 
    97 Returns a new list with {{X}} placed between each element.
    98 
    99 
    100 ==== join
    101 
    102  [procedure] (join LISTOFLISTS [LIST])
    103 
    104 Concatenates the lists in {{LISTOFLISTS}} with {{LIST}} placed
    105 between each sublist. {{LIST}} defaults to the empty list.
    106 
    107 <enscript highlight=scheme>
    108 (join '((a b) (c d) (e)) '(x y)) ==> (a b x y c d x y e)
    109 (join '((p q) () (r (s) t)) '(-))  ==> (p q - - r (s) t)
    110 </enscript>
    111 
    112 {{join}} could be implemented as follows:
    113 
    114 <enscript highlight=scheme>
    115 (define (join lstoflsts #!optional (lst '()))
    116   (apply append (intersperse lstoflists lst)) )
    117 </enscript>
    118 
    119 
    120 ==== shuffle
    121 
    122  [procedure] (shuffle LIST)
    123 
    124 Returns {{LIST}} with its elements sorted in a random order.
    125 
    126 
    127 ==== tail?
    128 
    129  [procedure] (tail? X LIST)
    130 
    131 Returns true if {{X}} is one of the tails (cdr's) of {{LIST}}.
    132 
    1339
    13410
     
    228104
    229105
    230 === Hash tables
    231 
    232 CHICKEN implements SRFI 69 with SRFI 90 extensions. For more information, see
    233 [[http://srfi.schemers.org/srfi-69/srfi-69.html|SRFI-69]] and
    234 [[http://srfi.schemers.org/srfi-90/srfi-90.html|SRFI-90]].
    235 
    236 
    237 ==== make-hash-table
    238 
    239  [procedure] (make-hash-table [TEST HASH SIZE] #:TEST #:HASH #:SIZE #:INITIAL #:MIN-LOAD #:MAX-LOAD #:WEAK-KEYS #:WEAK-VALUES)
    240 
    241 Returns a new {{HASH-TABLE}} with the supplied configuration.
    242 
    243 ; {{TEST}} : The equivalence function.
    244 ; {{HASH}} : The hash function.
    245 ; {{SIZE}} : The expected number of table elements.
    246 ; {{INITIAL}} : The default initial value.
    247 ; {{MIN-LOAD}} : The minimum load factor. A {{flonum}} in (0.0 1.0).
    248 ; {{MAX-LOAD}} : The maximum load factor. A {{flonum}} in (0.0 1.0).
    249 ; {{WEAK-KEYS}} : Use weak references for keys. (Ignored)
    250 ; {{WEAK-VALUES}} : Use weak references for values. (Ignored)
    251 
    252 (No, the keyword parameters are not uppercase.)
    253 
    254 
    255 ==== hash-table?
    256 
    257  [procedure] (hash-table? OBJECT)
    258 
    259 Is the {{OBJECT}} a {{hash-table}}?
    260 
    261 
    262 ==== hash-table-size
    263 
    264  [procedure] (hash-table-size HASH-TABLE)
    265 
    266 The {{HASH-TABLE}} size.
    267 
    268 
    269 ==== hash-table-equivalence-function
    270 
    271  [procedure] (hash-table-equivalence-function HASH-TABLE)
    272 
    273 The {{HASH-TABLE}} {{equivalence-function}}.
    274 
    275 
    276 ==== hash-table-hash-function
    277 
    278  [procedure] (hash-table-hash-function HASH-TABLE)
    279 
    280 The {{HASH-TABLE}} {{hash-function}}.
    281 
    282 
    283 ==== hash-table-min-load
    284 
    285  [procedure] (hash-table-min-load HASH-TABLE)
    286 
    287 The {{HASH-TABLE}} minimum load factor.
    288 
    289 
    290 ==== hash-table-max-load
    291 
    292  [procedure] (hash-table-max-load HASH-TABLE)
    293 
    294 The {{HASH-TABLE}} maximum load factor.
    295 
    296 
    297 ==== hash-table-weak-keys
    298 
    299  [procedure] (hash-table-weak-keys HASH-TABLE)
    300 
    301 Does the {{HASH-TABLE}} weak references for keys?
    302 
    303 
    304 ==== hash-table-weak-values
    305 
    306  [procedure] (hash-table-weak-values HASH-TABLE)
    307 
    308 Does the {{HASH-TABLE}} weak references for values?
    309 
    310 
    311 ==== hash-table-has-initial?
    312 
    313  [procedure] (hash-table-has-initial? HASH-TABLE)
    314 
    315 Does the {{HASH-TABLE}} have a default initial value?
    316 
    317 
    318 ==== hash-table-initial
    319 
    320  [procedure] (hash-table-initial HASH-TABLE)
    321 
    322 The {{HASH-TABLE}} default initial value.
    323 
    324 
    325 ==== hash-table-keys
    326 
    327  [procedure] (hash-table-keys HASH-TABLE)
    328 
    329 Returns a list of the keys in the {{HASH-TABLE}} population.
    330 
    331 
    332 ==== hash-table-values
    333 
    334  [procedure] (hash-table-values HASH-TABLE)
    335 
    336 Returns a list of the values in the {{HASH-TABLE}} population.
    337 
    338 
    339 ==== hash-table->alist
    340 
    341  [procedure] (hash-table->alist HASH-TABLE)
    342 
    343 Returns the population of the {{HASH-TABLE}} as an {{association-list}}.
    344 
    345 
    346 ==== alist->hash-table
    347 
    348  [procedure] (alist->hash-table ASSOCIATION-LIST [MAKE-HASH-TABLE-PARAMETER ...])
    349 
    350 Returns a new {{HASH-TABLE}}, configured using the optional
    351 {{MAKE-HASH-TABLE-PARAMETER ...}}. The {{HASH-TABLE}} is populated from the
    352 {{ASSOCIATION-LIST}}.
    353 
    354 
    355 ==== hash-table-ref
    356 
    357  [procedure] (hash-table-ref HASH-TABLE KEY)
    358 
    359 Returns the {{VALUE}} for the {{KEY}} in the {{HASH-TABLE}}.
    360 
    361 Aborts with an exception when the {{KEY}} is missing.
    362 
    363 
    364 ==== hash-table-ref/default
    365 
    366  [procedure] (hash-table-ref/default HASH-TABLE KEY DEFAULT)
    367 
    368 Returns the {{VALUE}} for the {{KEY}} in the {{HASH-TABLE}}, or the {{DEFAULT}}
    369 when the {{KEY}} is missing.
    370 
    371 
    372 ==== hash-table-exists?
    373 
    374  [procedure] (hash-table-exists? HASH-TABLE KEY)
    375 
    376 Does the {{KEY}} exist in the {{HASH-TABLE}}?
    377 
    378 
    379 ==== hash-table-set!
    380 
    381  [procedure] (hash-table-set! HASH-TABLE KEY VALUE)
    382 
    383 Set the {{VALUE}} for the {{KEY}} in the {{HASH-TABLE}}.
    384 
    385 A setter for {{hash-table-ref}} is defined, so
    386 
    387 <enscript highlight=scheme>
    388 (set! (hash-table-ref HASH-TABLE KEY) VALUE)
    389 </enscript>
    390 
    391 is equivalent to
    392 
    393 <enscript highlight=scheme>
    394 (hash-table-set! HASH-TABLE KEY VALUE)
    395 </enscript>
    396 
    397 
    398 ==== hash-table-update!
    399 
    400  [procedure] (hash-table-update! HASH-TABLE KEY [UPDATE-FUNCTION [DEFAULT-VALUE-FUNCTION]])
    401 
    402 Sets or replaces the {{VALUE}} for {{KEY}} in the {{HASH-TABLE}}.
    403 
    404 The {{UPDATE-FUNCTION}} takes the existing {{VALUE}} for {{KEY}} and returns
    405 the new {{VALUE}}. The default is {{identity}}
    406 
    407 The {{DEFAULT-VALUE-FUNCTION}} is called when the entry for {{KEY}} is missing.
    408 The default uses the {{(hash-table-initial-value)}}, if provided. Otherwise
    409 aborts with an exception.
    410 
    411 Returns the new {{VALUE}}.
    412 
    413 
    414 ==== hash-table-update!/default
    415 
    416  [procedure] (hash-table-update! HASH-TABLE KEY UPDATE-FUNCTION DEFAULT-VALUE)
    417 
    418 Sets or replaces the {{VALUE}} for {{KEY}} in the {{HASH-TABLE}}.
    419 
    420 The {{UPDATE-FUNCTION}} takes the existing {{VALUE}} for {{KEY}} and returns
    421 the new {{VALUE}}.
    422 
    423 The {{DEFAULT-VALUE}} is used when the entry for {{KEY}} is missing.
    424 
    425 Returns the new {{VALUE}}.
    426 
    427 
    428 ==== hash-table-copy
    429 
    430  [procededure] (hash-table-copy HASH-TABLE)
    431 
    432 Returns a shallow copy of the {{HASH-TABLE}}.
    433 
    434 
    435 ==== hash-table-delete!
    436 
    437  [procedure] (hash-table-delete! HASH-TABLE KEY)
    438 
    439 Deletes the entry for {{KEY}} in the {{HASH-TABLE}}.
    440 
    441 
    442 ==== hash-table-remove!
    443 
    444  [procedure] (hash-table-remove! HASH-TABLE PROC)
    445 
    446 Calls {{PROC}} for all entries in {{HASH-TABLE}} with the key and value of each
    447 entry. If {{PROC}} returns true, then that entry is removed.
    448 
    449 
    450 ==== hash-table-merge
    451 
    452  [procedure] (hash-table-merge HASH-TABLE-1 HASH-TABLE-2)
    453 
    454 Returns a new {{HASH-TABLE}} with the union of {{HASH-TABLE-1}} and
    455 {{HASH-TABLE-2}}.
    456 
    457 
    458 ==== hash-table-merge!
    459 
    460  [procedure] (hash-table-merge! HASH-TABLE-1 HASH-TABLE-2)
    461 
    462 Returns {{HASH-TABLE-1}} as the union of {{HASH-TABLE-1}} and
    463 {{HASH-TABLE-2}}.
    464 
    465 
    466 ==== hash-table-map
    467 
    468  [procedure] (hash-table-map HASH-TABLE FUNC)
    469 
    470 Calls {{FUNC}} for all entries in {{HASH-TABLE}} with the key and value of each
    471 entry.
    472 
    473 Returns a list of the results of each call.
    474 
    475 
    476 ==== hash-table-fold
    477 
    478  [procedure] (hash-table-fold HASH-TABLE FUNC INIT)
    479 
    480 Calls {{FUNC}} for all entries in {{HASH-TABLE}} with the key and value of each
    481 entry, and the current folded value. The initial folded value is {{INIT}}.
    482 
    483 Returns the final folded value.
    484 
    485 
    486 ==== hash-table-for-each
    487 
    488  [procedure] (hash-table-for-each HASH-TABLE PROC)
    489 
    490 Calls {{PROC}} for all entries in {{HASH-TABLE}} with the key and value of each
    491 entry.
    492 
    493 
    494 ==== hash-table-walk
    495 
    496  [procedure] (hash-table-walk HASH-TABLE PROC)
    497 
    498 Calls {{PROC}} for all entries in {{HASH-TABLE}} with the key and value of each
    499 entry.
    500 
    501 
    502 === Hash Functions
    503 
    504 All hash functions return a {{fixnum}} in the range [0 {{BOUND}}).
    505 
    506 
    507 ==== number-hash
    508 
    509  [procedure] (number-hash NUMBER [BOUND])
    510 
    511 For use with {{=}} as a {{hash-table-equivalence-function}}.
    512 
    513 
    514 ==== object-uid-hash
    515 
    516  [procedure] (object-uid-hash OBJECT [BOUND])
    517 
    518 Currently a synonym for {{equal?-hash}}.
    519 
    520 
    521 ==== symbol-hash
    522 
    523  [procedure] (symbol-hash SYMBOL [BOUND])
    524 
    525 For use with {{eq?}} as a {{hash-table-equivalence-function}}.
    526 
    527 
    528 ==== keyword-hash
    529 
    530  [procedure] (keyword-hash KEYWORD [BOUND])
    531 
    532 For use with {{eq?}} as a {{hash-table-equivalence-function}}.
    533 
    534 
    535 ==== string-hash
    536 
    537  [procedure] (string-hash STRING [BOUND])
    538 
    539 For use with {{string=?}} as a {{hash-table-equivalence-function}}.
    540 
    541 
    542 ==== string-ci-hash
    543 
    544  [procedure] (string-ci-hash STRING [BOUND])
    545 
    546 For use with {{string-ci=?}} as a {{hash-table-equivalence-function}}.
    547 
    548 
    549 ==== eq?-hash
    550 
    551  [procedure] (eq?-hash OBJECT [BOUND])
    552 
    553 For use with {{eq?}} as a {{hash-table-equivalence-function}}.
    554 
    555 
    556 ==== eqv?-hash
    557 
    558  [procedure] (eqv?-hash OBJECT [BOUND])
    559 
    560 For use with {{eqv?}} as a {{hash-table-equivalence-function}}.
    561 
    562 
    563 ==== equal?-hash
    564 
    565  [procedure] (equal?-hash OBJECT [BOUND])
    566 
    567 For use with {{equal?}} as a {{hash-table-equivalence-function}}.
    568 
    569 
    570 ==== hash
    571 
    572  [procedure] (hash OBJECT [BOUND])
    573 
    574 Synonym for {{equal?-hash}}.
    575 
    576 
    577 ==== hash-by-identity
    578 
    579  [procedure] (hash-by-identity OBJECT [BOUND])
    580 
    581 Synonym for {{eq?-hash}}.
    582 
    583 
    584 
    585 === Queues
    586 
    587 
    588 ==== list->queue
    589 
    590  [procedure] (list->queue LIST)
    591 
    592 Returns {{LIST}} converted into a queue, where the first element
    593 of the list is the same as the first element of the queue. The resulting
    594 queue may share memory with the list and the list should not be modified
    595 after this operation.
    596 
    597 
    598 ==== make-queue
    599 
    600  [procedure] (make-queue)
    601 
    602 Returns a newly created queue.
    603 
    604 
    605 ==== queue?
    606 
    607  [procedure] (queue? X)
    608 
    609 Returns {{#t}} if {{X}} is a queue, or {{#f}} otherwise.
    610 
    611 
    612 ==== queue->list
    613 
    614  [procedure] (queue->list QUEUE)
    615 
    616 Returns {{QUEUE}} converted into a list, where the first element
    617 of the list is the same as the first element of the queue. The resulting
    618 list may share memory with the queue object and should not be modified.
    619 
    620 
    621 ==== queue-add!
    622 
    623  [procedure] (queue-add! QUEUE X)
    624 
    625 Adds {{X}} to the rear of {{QUEUE}}.
    626 
    627 
    628 ==== queue-empty?
    629 
    630  [procedure] (queue-empty? QUEUE)
    631 
    632 Returns {{#t}} if {{QUEUE}} is empty, or {{#f}} otherwise.
    633 
    634 
    635 ==== queue-first
    636 
    637  [procedure] (queue-first QUEUE)
    638 
    639 Returns the first element of {{QUEUE}}. If {{QUEUE}} is empty
    640 an error is signaled
    641 
    642 
    643 ==== queue-last
    644 
    645  [procedure] (queue-last QUEUE)
    646 
    647 Returns the last element of {{QUEUE}}. If {{QUEUE}} is empty
    648 an error is signaled
    649 
    650 
    651 ==== queue-remove!
    652 
    653  [procedure] (queue-remove! QUEUE)
    654 
    655 Removes and returns the first element of {{QUEUE}}. If {{QUEUE}}
    656 is empty an error is signaled
    657 
    658 
    659 ==== queue-push-back!
    660 
    661  [procedure] (queue-push-back! QUEUE ITEM)
    662 
    663 Pushes an item into the first position of a queue, i.e. the next
    664 {{queue-remove!}} will return {{ITEM}}.
    665 
    666 
    667 ==== queue-push-back-list!
    668 
    669  [procedure] (queue-push-back-list! QUEUE LIST)
    670 
    671 Pushes the items in item-list back onto the queue,
    672 so that {{(car LIST)}} becomes the next removable item.
    673 
    674 
    675 
    676 === Sorting
    677 
    678 
    679 ==== merge
    680 
    681  [procedure] (merge LIST1 LIST2 LESS?)
    682  [procedure] (merge! LIST1 LIST2 LESS?)
    683 
    684 Joins two lists in sorted order. {{merge!}} is the destructive
    685 version of merge. {{LESS?  }} should be a procedure of two arguments,
    686 that returns true if the first argument is to be ordered before the
    687 second argument.
    688 
    689 
    690 ==== sort
    691 
    692  [procedure] (sort SEQUENCE LESS?)
    693  [procedure] (sort! SEQUENCE LESS?)
    694 
    695 Sort {{SEQUENCE}}, which should be a list or a vector. {{sort!}}
    696 is the destructive version of sort.
    697 
    698 
    699 ==== sorted?
    700 
    701  [procedure] (sorted? SEQUENCE LESS?)
    702 
    703 Returns true if the list or vector {{SEQUENCE}} is already sorted.
    704 
    705 
    706 
    707106=== Random numbers
    708107
     
    712111 [procedure] (random-seed [SEED])
    713112
    714 Seeds the random number generator with {{SEED}} (an exact integer) or
     113Seeds the random number generator with {{SEED}} (an exact integer) or 
    715114{{(current-seconds)}} if {{SEED}} is not given.
    716115
     
    796195input is read from the port that is the current value of {{(current-input-port)}}.
    797196After all expressions are read, and if the argument is a port, then the port will
    798 not be closed. The {{READER}} argument specifies the procedure used to read
     197not be closed. The {{READER}} argument specifies the procedure used to read 
    799198expressions from the given file or port and defaults to {{read}}. The reader
    800199procedure will be called with a single argument (an input port).
     
    833232
    834233Read or write {{NUM}} characters from/to {{PORT}}, which defaults to the
    835 value of {{(current-input-port)}} or {{(current-output-port)}}, respectively.
     234value of {{(current-input-port)}} or {{(current-output-port)}}, respectively. 
    836235If {{NUM}} is {{#f}} or not given, then all data
    837236up to the end-of-file is read, or, in the case of {{write-string}} the whole
     
    877276
    878277
    879 === Strings
    880 
    881 
    882 ==== conc
    883 
    884  [procedure] (conc X ...)
    885 
    886 Returns a string with the string-represenation of all arguments concatenated
    887 together. {{conc}} could be implemented as
    888 
    889 <enscript highlight=scheme>
    890 (define (conc . args)
    891   (apply string-append (map ->string args)) )
    892 </enscript>
    893 
    894 
    895 
    896 ==== ->string
    897 
    898  [procedure] (->string X)
    899 
    900 Returns a string-representation of {{X}}.
    901 
    902 
    903 ==== string-chop
    904 
    905  [procedure] (string-chop STRING LENGTH)
    906 
    907 Returns a list of substrings taken by ''chopping'' {{STRING}} every {{LENGTH}}
    908 characters:
    909 
    910 <enscript highlight=scheme>
    911 (string-chop "one two three" 4)  ==>  ("one " "two " "thre" "e")
    912 </enscript>
    913 
    914 
    915 
    916 ==== string-chomp
    917 
    918  [procedure] (string-chomp STRING [SUFFIX])
    919 
    920 If {{STRING}} ends with {{SUFFIX}}, then this procedure returns a copy of its first argument with the suffix
    921 removed, otherwise returns {{STRING}} unchanged. {{SUFFIX}} defaults to {{"\n"}}.
    922 
    923 
    924 ==== string-compare3
    925 
    926  [procedure] (string-compare3 STRING1 STRING2)
    927  [procedure] (string-compare3-ci STRING1 STRING2)
    928 
    929 Perform a three-way comparison between the {{STRING1}} and {{STRING2}},
    930 returning either {{-1}} if {{STRING1}} is lexicographically less
    931 than {{STRING2}}, {{0}} if it is equal, or {{1}} if it s greater.
    932 {{string-compare3-ci}} performs a case-insensitive comparison.
    933 
    934 
    935 ==== string-intersperse
    936 
    937  [procedure] (string-intersperse LIST [STRING])
    938 
    939 Returns a string that contains all strings in {{LIST}} concatenated
    940 together.  {{STRING}} is placed between each concatenated string and
    941 defaults to {{" "}}.
    942 
    943 <enscript highlight=scheme>
    944 (string-intersperse '("one" "two") "three")
    945 </enscript>
    946 
    947 is equivalent to
    948 
    949 <enscript highlight=scheme>
    950 (apply string-append (intersperse '("one" "two") "three"))
    951 </enscript>
    952 
    953 
    954 ==== string-split
    955 
    956  [procedure] (string-split STRING [DELIMITER-STRING [KEEPEMPTY]])
    957 
    958 Split string into substrings separated by the given delimiters. If
    959 no delimiters are specified, a string comprising the tab, newline and space characters
    960 is assumed. If the
    961 parameter {{KEEPEMPTY}} is given and not {{#f}}, then empty
    962 substrings are retained:
    963 
    964 <enscript highlight=scheme>
    965 (string-split "one  two  three") ==> ("one" "two" "three")
    966 (string-split "foo:bar::baz:" ":" #t) ==> ("foo" "bar" "" "baz" "")
    967 </enscript>
    968 
    969 
    970 ==== string-translate
    971 
    972  [procedure] (string-translate STRING FROM [TO])
    973 
    974 Returns a fresh copy of {{STRING}} with characters matching
    975 {{FROM}} translated to {{TO}}.  If {{TO}} is omitted, then
    976 matching characters are removed. {{FROM}} and {{TO}} may be
    977 a character, a string or a list. If both {{FROM}} and {{TO}}
    978 are strings, then the character at the same position in {{TO}}
    979 as the matching character in {{FROM}} is substituted.
    980 
    981 
    982 ==== string-translate*
    983 
    984  [procedure] (string-translate* STRING SMAP)
    985 
    986 Substitutes elements of {{STRING}} according to {{SMAP}}.
    987 {{SMAP}} should be an association-list where each element of the list
    988 is a pair of the form {{(MATCH \. REPLACEMENT)}}. Every occurrence of
    989 the string {{MATCH}} in {{STRING}} will be replaced by the string
    990 {{REPLACEMENT}}:
    991 
    992 <enscript highlight=scheme>
    993 (string-translate*
    994   "<h1>this is a \"string\"</h1>"
    995   '(("<" . "&lt;") (">" . "&gt;") ("\"" . "&quot;")) )
    996 =>  "&lt;h1&gt;this is a &quot;string&quot;&lt;/h1&gt;"
    997 </enscript>
    998 
    999 
    1000 ==== substring=?
    1001 
    1002  [procedure] (substring=? STRING1 STRING2 [START1 [START2 [LENGTH]]])
    1003  [procedure] (substring-ci=? STRING1 STRING2 [START1 [START2 [LENGTH]]])
    1004 
    1005 Returns {{#t}} if the strings {{STRING1}} and {{STRING2}} are equal, or
    1006 {{#f}} otherwise.
    1007 The comparison starts at the positions {{START1}} and {{START2}} (which default
    1008 to 0), comparing {{LENGTH}} characters (which defaults to the minimum of the remaining
    1009 length of both strings).
    1010 
    1011 
    1012 ==== substring-index
    1013 
    1014  [procedure] (substring-index WHICH WHERE [START])
    1015  [procedure] (substring-index-ci WHICH WHERE [START])
    1016 
    1017 Searches for first index in string {{WHERE}} where string
    1018 {{WHICH}} occurs.  If the optional argument {{START}} is given,
    1019 then the search starts at that index.  {{substring-index-ci}}
    1020 is a case-insensitive version of {{substring-index}}.
    1021 
    1022 
    1023 
    1024 === Combinators
    1025 
    1026 
    1027 ==== any?
    1028 
    1029  [procedure] (any? X)
    1030 
    1031 Ignores its argument and always returns {{#t}}. This is actually useful sometimes.
    1032 
    1033 
    1034 ==== none?
    1035 
    1036  [procedure] (none? X)
    1037 
    1038 Ignores its argument and always returns {{#f}}. This is actually useful sometimes.
    1039 
    1040 
    1041 ==== always?
    1042 
    1043  [procedure] (always? ...)
    1044 
    1045 Ignores its arguments and always returns {{#t}}. This is actually useful sometimes.
    1046 
    1047 
    1048 ==== never?
    1049 
    1050  [procedure] (never? ...)
    1051 
    1052 Ignores its arguments and always returns {{#f}}. This is actually useful sometimes.
    1053 
    1054 
    1055 ==== constantly
    1056 
    1057  [procedure] (constantly X ...)
    1058 
    1059 Returns a procedure that always returns the values {{X ...}} regardless of the number and value of its arguments.
    1060 
    1061 <enscript highlight=scheme>
    1062 (constantly X) <=> (lambda args X)
    1063 </enscript>
    1064 
    1065 
    1066 ==== complement
    1067 
    1068  [procedure] (complement PROC)
    1069 
    1070 Returns a procedure that returns the boolean inverse of {{PROC}}.
    1071 
    1072 <enscript highlight=scheme>
    1073 (complement PROC) <=> (lambda (x) (not (PROC x)))
    1074 </enscript>
    1075 
    1076 
    1077 ==== compose
    1078 
    1079  [procedure] (compose PROC1 PROC2 ...)
    1080 
    1081 Returns a procedure that represents the composition of the
    1082 argument-procedures {{PROC1 PROC2 ...}}.
    1083 
    1084 <enscript highlight=scheme>
    1085 (compose F G) <=> (lambda args
    1086                       (call-with-values
    1087                          (lambda () (apply G args))
    1088                          F))
    1089 </enscript>
    1090 
    1091 {{(compose)}} is equivalent to {{values}}.
    1092 
    1093 
    1094 ==== conjoin
    1095 
    1096  [procedure] (conjoin PRED ...)
    1097 
    1098 Returns a procedure that returns {{#t}} if its argument satisfies the
    1099 predicates {{PRED ...}}.
    1100 <enscript highlight=scheme>
    1101 ((conjoin odd? positive?) 33)   ==>  #t
    1102 ((conjoin odd? positive?) -33)  ==>  #f
    1103 </enscript>
    1104 
    1105 
    1106 ==== disjoin
    1107 
    1108  [procedure] (disjoin PRED ...)
    1109 
    1110 Returns a procedure that returns {{#t}} if its argument satisfies any
    1111 predicate {{PRED ...}}.
    1112 <enscript highlight=scheme>
    1113 ((disjoin odd? positive?) 32)    ==>  #t
    1114 ((disjoin odd? positive?) -32)   ==>  #f
    1115 </enscript>
    1116 
    1117 
    1118 ==== each
    1119 
    1120  [procedure] (each PROC ...)
    1121 
    1122 Returns a procedure that applies {{PROC ...}} to its arguments, and returns the result(s)
    1123 of the last procedure application. For example
    1124 
    1125 <enscript highlight=scheme>
    1126 (each pp eval)
    1127 </enscript>
    1128 
    1129 is equivalent to
    1130 
    1131 <enscript highlight=scheme>
    1132 (lambda args
    1133   (apply pp args)
    1134   (apply eval args) )
    1135 </enscript>
    1136 
    1137 {{(each PROC)}} is equivalent to {{PROC}} and {{(each)}} is equivalent to
    1138 {{noop}}.
    1139 
    1140 
    1141 ==== flip
    1142 
    1143  [procedure] (flip PROC)
    1144 
    1145 Returns a two-argument procedure that calls {{PROC}} with its
    1146 arguments swapped:
    1147 <enscript highlight=scheme>
    1148 (flip PROC) <=> (lambda (x y) (PROC y x))
    1149 </enscript>
    1150 
    1151 
    1152 ==== identity
    1153 
    1154  [procedure] (identity X)
    1155 
    1156 Returns its sole argument {{X}}.
    1157 
    1158 
    1159 ==== project
    1160 
    1161  [procedure] (project N)
    1162 
    1163 Returns a procedure that returns its {{N}}th argument (starting from 0).
    1164 
    1165 
    1166 ==== list-of
    1167 
    1168  [procedure] (list-of PRED)
    1169 
    1170 Returns a procedure of one argument that returns {{#t}} when
    1171 applied to a list of elements that all satisfy the predicate procedure
    1172 {{PRED}}, or {{#f}} otherwise.
    1173 
    1174 <enscript highlight=scheme>
    1175 ((list-of even?) '(1 2 3))   ==> #f
    1176 ((list-of number?) '(1 2 3)) ==> #t
    1177 </enscript>
    1178 
    1179 
    1180 ==== noop
    1181 
    1182  [procedure] (noop X ...)
    1183 
    1184 Ignores it's arguments, does nothing and returns an unspecified value.
    1185 
    1186 
    1187 ==== o
    1188 
    1189  [procedure] (o PROC ...)
    1190 
    1191 A single value version of {{compose}} (slightly faster). {{(o)}} is equivalent
    1192 to {{identity}}.
    1193 
    1194 
    1195 ==== left-section
    1196 
    1197  [procedure] (left-section PROC ARG0 ...)
    1198 
    1199 Returns an n-ary procedure that partially applies its' arguments {{ARG0 ...}}
    1200 from the left (normal order). Sort of a n-ary curry.
    1201 
    1202 
    1203 ==== right-section
    1204 
    1205  [procedure] (right-section PROC ARG0 ...)
    1206 
    1207 Returns an n-ary procedure that partially applies its' arguments {{ARG0 ...}}
    1208 from the right (reverse order). Sort of a n-ary curry.
    1209 
    1210 
    1211 === Binary searching
    1212 
    1213 
    1214 ==== binary-search
    1215 
    1216  [procedure] (binary-search SEQUENCE PROC)
    1217 
    1218 Performs a binary search in {{SEQUENCE}}, which should be a sorted
    1219 list or vector.  {{PROC}} is called to compare items in the sequence,
    1220 should accept a single argument and return an exact integer: zero if the
    1221 searched value is equal to the current item, negative if the searched
    1222 value is ''less'' than the current item, and positive otherwise.
    1223 Returns the index of the found value or {{#f}} otherwise.
    1224 
    1225 Previous: [[Unit eval]]
     278Previous: [[Unit data-structures]]
    1226279
    1227280Next: [[Unit srfi-1]]
  • chicken/branches/release/manual/Unit library

    r10108 r10653  
    105105is negative or {{0}} if {{N}} is zero. {{signum}} is exactness preserving.
    106106
     107
    107108==== finite?
    108109
     
    111112Returns {{#f}} if {{N}} is negative or positive infinity, and {{#t}} otherwise.
    112113
    113 ==== flonum-print-precision
    114 
    115  [procedure] (flonum-print-precision [PRECISION])
    116 
    117 Returns the existing number of digits after the decimal place used in printing
    118 a {{flonum}}.
    119 
    120 The optional {{non-negative-fixnum}} {{PRECISION}} sets the current print
    121 precision.
    122114
    123115
  • chicken/branches/release/manual/Unit posix

    r10108 r10653  
    8484==== create-directory
    8585
    86  [procedure] (create-directory NAME)
    87 
    88 Creates a directory with the pathname {{NAME}}.
     86 [procedure] (create-directory NAME #!optional PARENTS?)
     87
     88Creates a directory with the pathname {{NAME}}.  If the {{PARENTS?}} argument
     89is given and not false, any nonextant parent directories are also created.
    8990
    9091==== delete-directory
     
    114115 [procedure] (glob PATTERN1 ...)
    115116
    116 Returns a list of the pathnames of all existing files matching
    117 {{PATTERN1 ...}}, which should be strings containing the usual
    118 file-patterns (with {{*}} matching zero or more characters and
    119 {{?}} matching zero or one character).
     117Returns a list of the pathnames of all existing files matching {{PATTERN1 ...}}, which should be strings containing the usual file-patterns (with {{*}} matching zero or more characters and {{?}} matching zero or one character).  Bug: wildcard characters are only recognized in the rightmost portion of the pattern.
    120118
    121119==== canonical-path
     
    124122
    125123Returns a canonical path for {{NAME}}, which should be a string
    126 containing a path-or-filename.  The string returned by
     124containing a path-or-filename.  The string returned by 
    127125{{canonical-path}} is OS dependent; it may be quoted and used in
    128126a shell on the calling machine. (Quoting is suggested as shell
     
    132130
    133131The prefix for {{NAME}} determines what path to prepend.  If {{NAME}}
    134 begins with a {{"~/"}}, this prefix is stripped and the user's
     132begins with a {{"~/"}}, this prefix is stripped and the user's 
    135133home directory is added.  If beginning with {{/}} or a DRIVE-LETTER:\\
    136134combination, no additional path is added.  Otherwise, the current
     
    139137a {{/}} or is empty, the appropriate slash is appended to the tail.
    140138
    141 No directories or files are actually tested for existence; this
     139No directories or files are actually tested for existence; this 
    142140procedure only canonicalises path syntax.
    143141
     
    467465 [procedure] (stat-socket? FILENAME)
    468466
    469 These procedures return {{#t}} if the {{FILENAME}} given is of the
     467These procedures return {{#t}} if the {{FILENAME}} given is of the 
    470468appropriate type.
    471469
     
    802800for the signal with the code {{SIGNUM}}. {{PROC}} is called
    803801with the signal number as its sole argument. If the argument {{PROC}} is {{#f}}
    804 then any signal handler will be removed.
     802then any signal handler will be removed, and the corresponding signal set to {{SIG_IGN}}.
    805803
    806804Note that is is unspecified in which thread of execution the signal handler will be invoked.
     
    949947 [procedure] (seconds->local-time SECONDS)
    950948
    951 Converts the time value represented in {{SECONDS}} into a ten-element vector
    952 ({{TIME-VECTOR}}) of the form {{#(seconds minutes hours mday month year wday
    953 yday dstflag timezone)}}, in the following format:
     949Breaks down the time value represented in {{SECONDS}} into a 10
     950element vector of the form {{#(seconds minutes hours mday month
     951year wday yday dstflag timezone)}}, in the following format:
    954952
    955953; seconds (0) : the number of seconds after the minute (0 - 59)
     
    966964==== local-time->seconds
    967965
    968  [procedure] (local-time->seconds TIME-VECTOR)
    969 
    970 Converts the {{TIME-VECTOR}} representing the time value relative to the
    971 current timezone into the number of seconds since the first of January, 1970
    972 UTC.
     966 [procedure] (local-time->seconds VECTOR)
     967
     968Converts the ten-element vector {{VECTOR}} representing the time value relative to
     969the current timezone into
     970the number of seconds since the first of January, 1970 UTC.
    973971
    974972==== local-timezone-abbreviation
     
    982980 [procedure] (seconds->string SECONDS)
    983981
    984 Converts the local time represented in {{SECONDS}} into a string of the form
    985 {{"Tue May 21 13:46:22 1991"}}.
     982Converts the local time represented in {{SECONDS}} into a string
     983of the form {{"Tue May 21 13:46:22 1991"}}.
    986984
    987985==== seconds->utc-time
     
    989987 [procedure] (seconds->utc-time SECONDS)
    990988
    991 Similar to {{seconds->local-time}}, but interprets {{SECONDS}} as UTC time.
     989Similar to {{seconds->local-time}}, but interpretes {{SECONDS}}
     990as UTC time.
    992991
    993992==== utc-time->seconds
    994993
    995  [procedure] (utc-time->seconds TIME-VECTOR)
    996 
    997 Converts the {{TIME-VECTOR}} representing the UTC time value into the number of
    998 seconds since the first of January, 1970 UTC.
     994 [procedure] (utc-time->seconds VECTOR)
     995
     996Converts the ten-element vector {{VECTOR}} representing the UTC time value into
     997the number of seconds since the first of January, 1970 UTC.
    999998
    1000999==== time->string
    10011000
    1002  [procedure] (time->string TIME-VECTOR [FORMAT-STRING])
    1003 
    1004 Converts the {{TIME-VECTOR}} into a string of the form {{"Tue May 21 13:46:22
     1001 [procedure] (time->string VECTOR)
     1002
     1003Converts the broken down time represented in the 10 element vector
     1004{{VECTOR}} into a string of the form {{"Tue May 21 13:46:22
    100510051991"}}.
    1006 
    1007 When the optional {{FORMAT-STRING}} is supplied the time is formatted using
    1008 the C library routine {{strftime}}.
    1009 
    1010 ==== string->time
    1011 
    1012  [procedure] (string->time TIME-STRING [FORMAT-STRING])
    1013 
    1014 Parse the {{TIME-STRING}} using the C library routine {{strptime}} and return a
    1015 {{TIME-VECTOR}}.
    1016 
    1017 Not available for the ''Windows'' platform.
    10181006
    10191007
     
    12651253 set-root-directory!
    12661254 utc-time->seconds
    1267  string->time
    12681255
    12691256==== Additional Definitions
  • chicken/branches/release/manual/Unit regex

    r10108 r10653  
    1313<enscript highlight=scheme>
    1414(require 'regex)
    15 (test-feature? 'pcre) => t
     15(feature? 'pcre) => #t
    1616</enscript>
    1717
  • chicken/branches/release/manual/Unit srfi-14

    r5945 r10653  
    1717Previous: [[Unit srfi-13]]
    1818
    19 Next: [[Unit match]]
     19Next: [[Unit srfi-69]]
  • chicken/branches/release/manual/Unit srfi-18

    r7276 r10653  
    8585the number of milliseconds since process startup.
    8686
     87=== milliseconds->time
     88
     89 [procedure] (milliseconds->time ms)
     90
     91Converts into a time object an exact integer representing
     92the number of milliseconds since process startup.
     93
     94This procedure may be useful in combination with {{thread-sleep!}} when your compilation unit is using {{(declare fixnum-arithmetic)}}.  In that case you won't be able to pass an inexact value to {{thread-sleep!}}, but you can do the following:
     95
     96 (define (thread-sleep!/ms ms)
     97   (thread-sleep!
     98    (milliseconds->time (+ ms (current-milliseconds)))))
    8799
    88100Previous: [[Unit regex]]
  • chicken/branches/release/manual/Unit utils

    r7276 r10653  
    136136
    137137
     138=== File move/copy
     139
     140==== file-copy
     141
     142 [procedure] (file-copy ORIGFILE NEWFILE #!optional CLOBBER BLOCKSIZE)
     143
     144Copies {{ORIGFILE}} (a string denoting some filename) to {{NEWFILE}},
     145{{BLOCKSIZE}} bytes at a time.  {{BLOCKSIZE}} defaults to 1024, and must be
     146a positive integer.  Returns the number of bytes copied on success, or errors
     147on failure.  {{CLOBBER}} determines the behaviour of {{file-copy}} when
     148{{NEWFILE}} is already extant.  When set to {{#f}} (default), an error is
     149signalled.  When set to any other value, {{NEWFILE}} is overwritten.
     150{{file-copy}} will work across filesystems and devices and is not
     151platform-dependent.
     152
     153==== file-move
     154
     155 [procedure] (file-move ORIGFILE NEWFILE #!optional CLOBBER BLOCKSIZE)
     156
     157Moves {{ORIGFILE}} (a string denoting some filename) to {{NEWFILE}}, with
     158the same semantics as {{file-copy}}, above.  {{file-move}} is safe across
     159filesystems and devices (unlike {{file-rename}}).  It is possible for an
     160error to be signalled despite partial success if {{NEWFILE}} could be created
     161and fully written but removing {{ORIGFILE}} fails.
     162
     163
    138164=== Iterating over input lines and files
    139165
  • chicken/branches/release/manual/chicken-setup

    r10108 r10653  
    546546; {{-tree FILENAME}} : Download and show the repository catalog
    547547; {{-svn URL}} : Fetch extension from [[http://subversion.tigris.org|Subversion]] repository
     548; {{-svn-trunk URL}} : Fetch extension from trunk in [[http://subversion.tigris.org|Subversion]] repository
    548549; {{-revision REV}} : Specifies SVN revision to check out
    549550; {{-local PATHNAME}} : Fetch extension from local file
  • chicken/branches/release/posixunix.scm

    r10108 r10653  
    118118#ifdef HAVE_GRP_H
    119119static C_TLS struct group *C_group;
     120#else
     121static C_TLS struct {
     122  char *gr_name, gr_passwd;
     123  int gr_gid;
     124  char *gr_mem[ 1 ];
     125} C_group = { "", "", 0, { "" } };
     126#endif
    120127static C_TLS int C_pipefds[ 2 ];
    121 #endif
    122128static C_TLS time_t C_secs;
    123129static C_TLS struct tm C_tm;
     
    856862;;; Directory stuff:
    857863
     864(define-inline (create-directory-helper name)
     865    (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string name)))
     866            (posix-error #:file-error 'create-directory
     867                         "cannot create directory" name)))
     868
     869(define-inline (create-directory-check name)
     870    (if (file-exists? name)
     871        (if (fx< (##core#inline "C_stat" (##sys#make-c-string name)) 0)
     872            (posix-error #:file-error 'create-directory
     873                         "cannot stat file" name)
     874            (or (foreign-value "C_isdir" bool)
     875                (posix-error #:file-error 'create-directory
     876                             "path segment is a file" name)))
     877        #f))
     878
     879(define-inline (create-directory-helper-silent name)
     880    (unless (create-directory-check name)
     881            (create-directory-helper name)))
     882
     883(define-inline (create-directory-helper-parents name)
     884    (let ((c   ""))
     885        (for-each
     886             (lambda (x)
     887                 (set! c (string-append c "/" x))
     888                 (create-directory-helper-silent c))
     889             (string-split name "/"))))
     890
    858891(define create-directory
    859   (lambda (name)
     892  (lambda (name #!optional parents?)
    860893    (##sys#check-string name 'create-directory)
    861     (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string (##sys#expand-home-path name))))
    862       (posix-error #:file-error 'create-directory "cannot create directory" name) ) ) )
     894    (if parents?
     895        (create-directory-helper-parents (canonical-path name))
     896        (create-directory-helper (canonical-path name)))))
     897;    (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string (##sys#expand-home-path name))))
     898;      (posix-error #:file-error 'create-directory "cannot create directory" name) ) ) )
    863899
    864900(define change-directory
  • chicken/branches/release/posixwin.scm

    r10108 r10653  
    11641164;;; Directory stuff:
    11651165
     1166(define-inline (create-directory-helper name)
     1167    (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string name)))
     1168            (##sys#update-errno)
     1169            (##sys#signal-hook #:file-error 'create-directory
     1170                               "cannot create directory" name)))
     1171
     1172(define-inline (create-directory-check name)
     1173    (if (file-exists? name)
     1174        (let ((i   (##sys#file-info name)))
     1175            (and i
     1176                 (fx= 1 (##sys#slot i 4))))
     1177        #f))
     1178
     1179(define-inline (create-directory-helper-silent name)
     1180    (unless (create-directory-check name)
     1181            (create-directory-helper name)))
     1182
     1183(define-inline (create-directory-helper-parents name)
     1184    (let* ((l   (string-split name "\\"))
     1185           (c   (car l)))
     1186        (for-each
     1187             (lambda (x)
     1188                 (set! c (string-append c "\\" x))
     1189                 (create-directory-helper-silent c))
     1190             (cdr l))))
     1191
    11661192(define create-directory
    1167   (lambda (name)
     1193  (lambda (name #!optional parents?)
    11681194    (##sys#check-string name 'create-directory)
    1169     (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string (##sys#expand-home-path name))))
    1170       (##sys#update-errno)
    1171       (##sys#signal-hook #:file-error 'create-directory "cannot create directory" name) ) ) )
     1195    (if parents?
     1196        (create-directory-helper-parents (canonical-path name))
     1197        (create-directory-helper (canonical-path name)))))
     1198;(define create-directory
     1199;  (lambda (name)
     1200;    (##sys#check-string name 'create-directory)
     1201;    (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string (##sys#expand-home-path name))))
     1202;      (##sys#update-errno)
     1203;      (##sys#signal-hook #:file-error 'create-directory "cannot create directory" name) ) ) )
    11721204
    11731205(define change-directory
  • chicken/branches/release/rules.make

    r10277 r10653  
    2929
    3030LIBCHICKEN_OBJECTS_1 = \
    31        library eval extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
    32        srfi-14 srfi-18 $(POSIXFILE) regex scheduler \
     31       library eval data-structures extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
     32       srfi-14 srfi-18 srfi-69 $(POSIXFILE) regex scheduler \
    3333       profiler stub match runtime
    3434LIBCHICKEN_SHARED_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=$(O))
     
    3636
    3737LIBUCHICKEN_OBJECTS_1 = \
    38        ulibrary ueval uextras ulolevel uutils utcp usrfi-1 usrfi-4 \
    39        usrfi-13 usrfi-14 usrfi-18 u$(POSIXFILE) uregex scheduler \
     38       ulibrary ueval udata-structures uextras ulolevel uutils utcp usrfi-1 usrfi-4 \
     39       usrfi-13 usrfi-14 usrfi-18 usrfi-69 u$(POSIXFILE) uregex scheduler \
    4040       profiler stub match uruntime
    4141LIBUCHICKEN_SHARED_OBJECTS = $(LIBUCHICKEN_OBJECTS_1:=$(O))
     
    4343
    4444LIBCHICKENGUI_OBJECTS_1 = \
    45        library eval extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
    46        srfi-14 srfi-18 $(POSIXFILE) regex scheduler \
     45       library eval data-structures extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
     46       srfi-14 srfi-18 srfi-69 $(POSIXFILE) regex scheduler \
    4747       profiler stub match gui-runtime
    4848LIBCHICKENGUI_SHARED_OBJECTS = $(LIBCHICKENGUI_OBJECTS_1:=$(O))
     
    9494          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
    9595          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
     96data-structures$(O): data-structures.c chicken.h $(CHICKEN_CONFIG_H)
     97        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     98          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
     99          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
    96100extras$(O): extras.c chicken.h $(CHICKEN_CONFIG_H)
    97101        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     
    146150          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
    147151          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
     152srfi-69$(O): srfi-69.c chicken.h $(CHICKEN_CONFIG_H)
     153        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     154          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
     155          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
    148156srfi-4$(O): srfi-4.c chicken.h $(CHICKEN_CONFIG_H)
    149157        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     
    168176          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
    169177ueval$(O): ueval.c chicken.h $(CHICKEN_CONFIG_H)
     178        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     179          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
     180          $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
     181udata-structures$(O): udata-structures.c chicken.h $(CHICKEN_CONFIG_H)
    170182        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
    171183          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
     
    211223          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
    212224          $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
     225usrfi-69$(O): usrfi-69.c chicken.h $(CHICKEN_CONFIG_H)
     226        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     227          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
     228          $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
    213229usrfi-4$(O): usrfi-4.c chicken.h $(CHICKEN_CONFIG_H)
    214230        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     
    237253          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
    238254          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
     255data-structures-static$(O): data-structures.c chicken.h $(CHICKEN_CONFIG_H)
     256        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     257          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
     258          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
    239259extras-static$(O): extras.c chicken.h $(CHICKEN_CONFIG_H)
    240260        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     
    289309          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
    290310          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
     311srfi-69-static$(O): srfi-69.c chicken.h $(CHICKEN_CONFIG_H)
     312        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     313          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
     314          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
    291315srfi-4-static$(O): srfi-4.c chicken.h $(CHICKEN_CONFIG_H)
    292316        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     
    311335          $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
    312336ueval-static$(O): ueval.c chicken.h $(CHICKEN_CONFIG_H)
     337        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     338          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
     339          $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
     340udata-structures-static$(O): udata-structures.c chicken.h $(CHICKEN_CONFIG_H)
    313341        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
    314342          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
     
    354382          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
    355383          $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
     384usrfi-69-static$(O): usrfi-69.c chicken.h $(CHICKEN_CONFIG_H)
     385        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     386          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
     387          $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
    356388usrfi-4-static$(O): usrfi-4.c chicken.h $(CHICKEN_CONFIG_H)
    357389        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     
    590622# assembler objects
    591623
    592 ifdef HACKED_APPLY
     624ifneq ($(HACKED_APPLY),)
    593625$(APPLY_HACK_OBJECT): apply-hack.$(ARCH).s
    594626        $(ASSEMBLER) $(ASSEMBLER_OPTIONS) $(ASSEMBLER_COMPILE_OPTION) $< $(ASSEMBLER_OUTPUT)
     
    654686
    655687
    656 libchickengui$(SO): $(LIBCHICKENGUI_SHARED_OBJECTS) $(PCRE_SHARED_OBJECTS) $(APPLY_HACK_OBJECT)
     688libchickengui$(SO): $(APPLY_HACK_OBJECT) $(LIBCHICKENGUI_SHARED_OBJECTS) $(PCRE_SHARED_OBJECTS)
    657689        $(LINKER) $(LINKER_OPTIONS) $(LINKER_LINK_SHARED_LIBRARY_OPTIONS) $(LIBCHICKENGUI_SO_LINKER_OPTIONS) \
    658690        $(LINKER_OUTPUT) $^ $(LIBCHICKENGUI_SO_LIBRARIES)
     
    725757        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) $(LIBUCHICKEN_IMPORT_LIBRARY) $(DESTDIR)$(ILIBDIR)
    726758ifdef WINDOWS
    727 #       $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) libchickengui$(A) $(DESTDIR)$(ILIBDIR)
     759        -$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) libchickengui$(A) $(DESTDIR)$(ILIBDIR)
    728760        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) $(LIBCHICKENGUI_IMPORT_LIBRARY) $(DESTDIR)$(ILIBDIR)
    729761endif
     
    845877          $(DESTDIR)$(IMANDIR)/chicken-bug.1
    846878        $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IINCDIR)/chicken.h $(DESTDIR)$(IINCDIR)/chicken-config.h
     879        $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IINCDIR)/chicken.gch
    847880        $(REMOVE_COMMAND) $(REMOVE_COMMAND_RECURSIVE_OPTIONS) $(DESTDIR)$(IDATADIR)
    848881        $(UNINSTALLINFO_PROGRAM) $(UNINSTALLINFO_PROGRAM_OPTIONS) --infodir=$(DESTDIR)$(IINFODIR) chicken.info
     
    860893eval.c: eval.scm
    861894        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
     895data-structures.c: data-structures.scm private-namespace.scm
     896        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend private-namespace.scm
    862897extras.c: extras.scm private-namespace.scm
    863898        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend private-namespace.scm
     
    876911srfi-18.c: srfi-18.scm
    877912        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
     913srfi-69.c: srfi-69.scm private-namespace.scm
     914        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend private-namespace.scm
    878915utils.c: utils.scm
    879916        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
     
    897934ueval.c: eval.scm
    898935        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
     936udata-structures.c: data-structures.scm private-namespace.scm
     937        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@ -extend private-namespace.scm
    899938uextras.c: extras.scm private-namespace.scm
    900939        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@ -extend private-namespace.scm
     
    913952usrfi-18.c: srfi-18.scm
    914953        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
     954usrfi-69.c: srfi-69.scm private-namespace.scm
     955        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@ -extend private-namespace.scm
    915956uutils.c: utils.scm
    916957        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
     
    952993.PHONY: distfiles
    953994
    954 distfiles: buildsvnrevision library.c eval.c extras.c lolevel.c utils.c \
    955         tcp.c srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c \
     995distfiles: buildsvnrevision library.c eval.c data-structures.c extras.c lolevel.c utils.c \
     996        tcp.c srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c \
    956997        posixunix.c posixwin.c regex.c scheduler.c profiler.c stub.c match.c \
    957         ulibrary.c ueval.c uextras.c ulolevel.c \
     998        ulibrary.c ueval.c udata-structures.c uextras.c ulolevel.c \
    958999        uutils.c utcp.c usrfi-1.c usrfi-4.c usrfi-13.c usrfi-14.c \
    959         usrfi-18.c uposixunix.c uposixwin.c uregex.c \
     1000        usrfi-18.c usrfi-69.c uposixunix.c uposixwin.c uregex.c \
    9601001        chicken-profile.c chicken-setup.c csc.c csi.c \
    9611002        chicken.c batch-driver.c compiler.c optimizer.c support.c \
     
    9871028
    9881029spotless: distclean
    989         -$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) library.c eval.c extras.c lolevel.c utils.c \
    990           tcp.c srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c \
     1030        -$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) library.c eval.c data-structures.c extras.c lolevel.c utils.c \
     1031          tcp.c srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c \
    9911032          posixunix.c posixwin.c regex.c scheduler.c profiler.c stub.c match.c \
    992           ulibrary.c ueval.c uextras.c ulolevel.c \
     1033          ulibrary.c ueval.c udata-structures.c uextras.c ulolevel.c \
    9931034          uutils.c utcp.c usrfi-1.c usrfi-4.c usrfi-13.c usrfi-14.c \
    994           usrfi-18.c uposixunix.c uposixwin.c uregex.c chicken-profile.c chicken-setup.c chicken-bug.c \
     1035          usrfi-18.c usrfi-69.c uposixunix.c uposixwin.c uregex.c chicken-profile.c chicken-setup.c chicken-bug.c \
    9951036          csc.c csi.c \
    9961037          chicken.c batch-driver.c compiler.c optimizer.c support.c \
     
    10321073.PHONY: bootstrap bootstrap.tar.gz
    10331074
    1034 bootstrap:
     1075bootstrap: bootstrap.tar.gz
    10351076        gzip -d -c bootstrap.tar.gz | tar xvf -
    10361077        touch *.c
     
    10401081
    10411082bootstrap.tar.gz: posixunix.c posixwin.c
    1042         tar cfz bootstrap.tar.gz library.c eval.c extras.c lolevel.c utils.c tcp.c \
    1043           srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c posixunix.c posixwin.c regex.c \
     1083        tar cfz bootstrap.tar.gz library.c eval.c data-structures.c extras.c lolevel.c utils.c tcp.c \
     1084          srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c posixunix.c posixwin.c regex.c \
    10441085          scheduler.c profiler.c stub.c match.c $(COMPILER_OBJECTS_1:=.c)
  • chicken/branches/release/runtime.c

    r10108 r10653  
    20702070C_regparm int C_fcall hash_string(int len, C_char *str, unsigned int m)
    20712071{
    2072   unsigned int key = 0;
    2073 
    2074 # if 0
    2075   /* Zbigniew's suggested change for extended significance & ^2 table sizes. */
    2076   while(len--) key += (key << 5) + *(str++);
    2077 # else
    2078   while(len--) key = (key << 4) + *(str++);
    2079 # endif
     2072  unsigned int key = 2166136261U;
     2073
     2074  while(len--) key = ((key * 16777619U) + (*str++));
    20802075
    20812076  return (int)(key % m);
     
    38223817C_regparm C_word C_fcall C_hash_string(C_word str)
    38233818{
    3824   unsigned C_word key = 0;
     3819  unsigned C_word key = 2166136261U;
    38253820  int len = C_header_size(str);
    38263821  C_byte *ptr = C_data_pointer(str);
    38273822
    3828   while(len--) key = (key << 4) + *(ptr++);
     3823  while(len--) key = ((key * 16777619U) + (*ptr++));
    38293824
    38303825  return C_fix(key & C_MOST_POSITIVE_FIXNUM);
     
    38343829C_regparm C_word C_fcall C_hash_string_ci(C_word str)
    38353830{
    3836   unsigned C_word key = 0;
     3831  unsigned C_word key = 2166136261U;
    38373832  int len = C_header_size(str);
    38383833  C_byte *ptr = C_data_pointer(str);
    38393834
    3840   while(len--) key = (key << 4) + C_tolower(*(ptr++));
     3835  while(len--) key = ((key * 16777619U) + C_tolower(*ptr++));
    38413836
    38423837  return C_fix(key & C_MOST_POSITIVE_FIXNUM);
  • chicken/branches/release/scripts/makehtml.scm

    r10108 r10653  
    8585(define manual-wiki-files
    8686  '("The User's Manual"
    87     "Overview"
     87    "Getting started"
    8888    "Basic mode of operation"
    8989    "Using the compiler"
     
    9999    "Unit library"
    100100    "Unit eval"
     101    "Unit data-structures"
    101102    "Unit extras"
    102103    "Unit srfi-1"
     
    104105    "Unit srfi-13"
    105106    "Unit srfi-14"
     107    "Unit srfi-69"
    106108    "Unit match"
    107109    "Unit regex"
     
    195197
    196198(define (usage code)
    197   (print "makedoc --fetch-manual")
    198   (print "makedoc --extension-path=EXTPATH [--pdf] [--wikipath=PATH] [--only=PAGENAME]")
     199  (print "makehtml --fetch-manual")
     200  (print "makehtml --extension-path=EXTPATH [--pdf] [--wikipath=PATH] [--only=PAGENAME]")
    199201  (exit code) )
    200202
  • chicken/branches/release/scripts/maketexi.scm

    r10108 r10653  
    55(require-extension syntax-case)
    66(require-extension srfi-1)
     7(require-extension srfi-69)
    78(require-extension posix)
    89(require-extension utils)
     10(require-extension srfi-40)
     11(require-extension html-stream)
     12(require-extension stream-ext)
    913(require-extension stream-wiki)
    10 (require-extension stream-ext)
    1114
    1215(define extensions (make-hash-table))
    1316
    14 (load-extensions-from-file extensions "enscript-texinfo.scm")
     17(load-extensions-from-file extensions (or (file-exists? "enscript-texinfo.scm")
     18                                          (file-exists? "scripts/enscript-texinfo.scm")))
    1519
    16 (define wikipath (optional (command-line-arguments) "chicken-manual"))
     20(define wikipath (optional (command-line-arguments) "manual"))
    1721
    1822(define file-list (map (lambda (x) (make-pathname wikipath x))
    1923                       (list "The User's Manual"
    20                              "Overview"
     24                             "Getting started"
    2125                             "Basic mode of operation"
    2226                             "Using the compiler"
     
    3236                             "Unit library"
    3337                             "Unit eval"
     38                             "Unit data-structures"
    3439                             "Unit extras"
    3540                             "Unit srfi-1"
     
    3742                             "Unit srfi-13"
    3843                             "Unit srfi-14"
     44                             "Unit srfi-69"
    3945                             "Unit match"
    4046                             "Unit regex"
  • chicken/branches/release/scripts/setversion

    r10108 r10653  
    99(define buildbinaryversion (car (read-file "buildbinaryversion")))
    1010
    11 (define files '("README" "manual/The User's Manual"))
     11(define files
     12  '("README"
     13    "manual/The User's Manual"))
    1214
    1315(define (patch which rx subst)
  • chicken/branches/release/srfi-4.scm

    r10108 r10653  
    601601            (cond [(or (eq? tag 'f) (eq? tag 'F)) #f]
    602602                  [(memq tag consers) => (lambda (c) ((##sys#slot (##sys#slot c 1) 0) (read port)))]
    603                   [else (##sys#error "illegal bytevector syntax" tag)] ) )
     603                  [else (##sys#read-error port "illegal bytevector syntax" tag)] ) )
    604604          (old-hook char port) ) ) ) )
    605605
  • chicken/branches/release/stub.scm

    r10108 r10653  
    2828(declare
    2929  (unit default_stub)
    30   (uses library eval extras)
     30  (uses library eval data-structures extras)
    3131  (not safe) )
    3232
  • chicken/branches/release/tcp.scm

    r10108 r10653  
    2828(declare
    2929  (unit tcp)
    30   (uses extras scheduler)
     30  (uses data-structures extras scheduler)
    3131  (usual-integrations)
    3232  (fixnum-arithmetic)
  • chicken/branches/release/utils.scm

    r10108 r10653  
    2828(declare
    2929  (unit utils)
    30   (uses regex extras)
     30  (uses regex data-structures extras)
    3131  (usual-integrations)
    3232  (fixnum)
     
    195195      (and (file-exists? file) (delete-file file) #t) ) ) )
    196196
     197;;; file-copy and file-move : they do what you'd think.
     198(define (file-copy origfile newfile #!optional (clobber #f) (blocksize 1024))
     199    (##sys#check-string origfile 'file-copy)
     200    (##sys#check-string newfile 'file-copy)
     201    (##sys#check-number blocksize 'file-copy)
     202    (or (and (integer? blocksize) (> blocksize 0))
     203        (##sys#error (string-append
     204                         "invalid blocksize given: not a positive integer - "
     205                         (number->string blocksize))))
     206    (or (file-exists? origfile)
     207        (##sys#error (string-append "origfile does not exist - " origfile)))
     208    (and (file-exists? newfile)
     209         (or clobber
     210             (##sys#error (string-append
     211                              "newfile exists but clobber is false - "
     212                              newfile))))
     213    (let* ((i   (condition-case (open-input-file origfile)
     214                    (val ()
     215                        (##sys#error (string-append
     216                                         "could not open origfile for read - "
     217                                         origfile)))))
     218           (o   (condition-case (open-output-file newfile)
     219                    (val ()
     220                        (##sys#error (string-append
     221                                         "could not open newfile for write - "
     222                                         newfile)))))
     223           (s   (make-string blocksize)))
     224        (let loop ((d   (read-string! blocksize s i))
     225                   (l   0))
     226            (if (= 0 d)
     227                (begin
     228                    (close-input-port i)
     229                    (close-output-port o)
     230                    l)
     231                (begin
     232                    (condition-case (write-string s d o)
     233                        (val ()
     234                            (close-input-port i)
     235                            (close-output-port o)
     236                            (##sys#error (string-append
     237                                             "error writing file starting at "
     238                                             (number->string l)))))
     239                    (loop (read-string! blocksize s i) (+ d l)))))))
     240
     241(define (file-move origfile newfile #!optional (clobber #f) (blocksize 1024))
     242    (##sys#check-string origfile 'file-move)
     243    (##sys#check-string newfile 'file-move)
     244    (##sys#check-number blocksize 'file-move)
     245    (or (and (integer? blocksize) (> blocksize 0))
     246        (##sys#error (string-append
     247                         "invalid blocksize given: not a positive integer - "
     248                         (number->string blocksize))))
     249    (or (file-exists? origfile)
     250        (##sys#error (string-append "origfile does not exist - " origfile)))
     251    (and (file-exists? newfile)
     252         (or clobber
     253             (##sys#error (string-append
     254                              "newfile exists but clobber is false - "
     255                              newfile))))
     256    (let* ((i   (condition-case (open-input-file origfile)
     257                    (val ()
     258                        (##sys#error (string-append
     259                                         "could not open origfile for read - "
     260                                         origfile)))))
     261           (o   (condition-case (open-output-file newfile)
     262                    (val ()
     263                        (##sys#error (string-append
     264                                         "could not open newfile for write - "
     265                                         newfile)))))
     266           (s   (make-string blocksize)))
     267        (let loop ((d   (read-string! blocksize s i))
     268                   (l   0))
     269            (if (= 0 d)
     270                (begin
     271                    (close-input-port i)
     272                    (close-output-port o)
     273                    (condition-case (delete-file origfile)
     274                        (val ()
     275                            (##sys#error (string-append
     276                                             "could not remove origfile - "
     277                                             origfile))))
     278                    l)
     279                (begin
     280                    (condition-case (write-string s d o)
     281                        (val ()
     282                            (close-input-port i)
     283                            (close-output-port o)
     284                            (##sys#error (string-append
     285                                             "error writing file starting at "
     286                                             (number->string l)))))
     287                    (loop (read-string! blocksize s i) (+ d l)))))))
    197288
    198289;;; Pathname operations:
  • chicken/branches/release/version.scm

    r10109 r10653  
    1 (define-constant +build-version+ "3.1.0")
     1(define-constant +build-version+ "3.2.0")
     2
Note: See TracChangeset for help on using the changeset viewer.