Changeset 7931 in project


Ignore:
Timestamp:
01/25/08 23:22:28 (11 years ago)
Author:
felix
Message:

merged from prerelease branch rev. 7930 - release version 3.0.0; fixed wrong version numbers in some files

Location:
chicken/branches/release
Files:
1 added
34 edited
1 copied

Legend:

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

    r7276 r7931  
    3333# Germany
    3434
    35 
    3635# platform configuration
    3736
     
    4039# commands
    4140
    42 POSTINSTALL_STATIC_LIBRARY = ranlib
    4341POSTINSTALL_PROGRAM = install_name_tool
    4442
     
    5149C_COMPILER_OPTIMIZATION_OPTIONS ?= -Os -fomit-frame-pointer
    5250endif
    53 LINKER_LINK_SHARED_LIBRARY_OPTIONS = -dynamiclib -compatibility_version 1 -current_version 1.0
     51LINKER_LINK_SHARED_LIBRARY_OPTIONS = -dynamiclib -compatibility_version 1 -current_version 1.0 -install_name $@
    5452POSTINSTALL_PROGRAM_FLAGS = -change libchicken$(SO) $(LIBDIR)/libchicken$(SO)
    55 
    56 ifeq ($(ARCH),x86-64)
    57 C_COMPILER_OPTIONS += -m64
    58 LINKER_OPTIONS += -m64
    59 endif
     53LIBRARIAN_OPTIONS = scru
    6054
    6155# file extensions
     
    111105        cat chicken-defaults.h >>$@
    112106
     107# architectures
     108
     109ifeq ($(ARCH),x86-64)
     110C_COMPILER_OPTIONS += -m64
     111LINKER_OPTIONS += -m64
     112else
     113
     114ifeq ($(ARCH),universal)
     115C_COMPILER_OPTIONS += -arch ppc -arch i386 -isysroot /Developer/SDKs/MacOSX10.4u.sdk
     116LINKER_OPTIONS += -arch ppc -arch i386 -isysroot /Developer/SDKs/MacOSX10.4u.sdk
     117
     118ifdef HACKED_APPLY
     119# We undefine HACKED_APPLY in order to override rules.make.
     120HACKED_APPLY=
     121apply-hack.ppc.darwin$(O): apply-hack.ppc.darwin.s
     122        as -arch ppc -o $@ $<
     123apply-hack.x86$(O): apply-hack.x86.s
     124        as -arch i386 -o $@ $<
     125$(APPLY_HACK_OBJECT): apply-hack.x86$(O) apply-hack.ppc.darwin$(O)
     126        lipo -create -output $(APPLY_HACK_OBJECT) $^
     127endif
     128
     129endif
     130endif
     131
    113132include rules.make
  • chicken/branches/release/NEWS

    r7279 r7931  
     13.0.0rc1
     2
     3- upgraded scheme-complete.el to version 0.6 [Thanks to Alex Shinn]
     4- unit library: added "blob=?"
     5- the library can optionally be built with an already installed libpcre
     6- chicken-setup accesses a separate set of eggs, specific on the major CHICKEN
     7  version (3)
     8- added csi options "-p" ("-print") and "-P" ("-pretty-print")
     9- support for Mac OS X universal binaries hase been added [Thanks to Zbigniew]
     10- `cond-expand' is available in the set of core macros [Thanks to Alex Shinn]
     11- On sparc64 architectures more than 126 procedure arguments are allowed
     12  [Thanks to Peter Bex]
     13- posix unit: "seconds->string" and "time->string" have now their trailing
     14  #\newline character removed. THIS IS A BACKWARD-INCOMPATIBLE CHANGE.
     15
    1162.739
    217
  • chicken/branches/release/README

    r7332 r7931  
    11
    22  README file for the CHICKEN compiler
    3   (c)2000-2007 Felix L. Winkelmann
    4 
    5   version 2.740
     3  (c)2000-2008 Felix L. Winkelmann
     4
     5  version 3.0.0
    66
    77
     
    7979        which will unpack a tarball containing precompiled C sources
    8080        that are recent enough to generate the current version. After
    81         building a statically linked "chicken" executable, all Scheme
    82         sources are recompiled with it. From this stage on
    83         bootstrapping isn't necessary anymore, as long as you have a
    84         compiler binary in your source tree.
     81        building a statically linked "chicken" executable, the system
     82        is rebuilt using the static compiler.
    8583
    8684        The build may show errors when creating the info(1)
     
    257255            http://www.opendarwin.org/projects/dlcompat
    258256
     257        - On Mac OS X, Chicken and its eggs can be built as universal
     258          binaries which will work on either Intel or PowerPC.
     259
     260            make PLATFORM=macosx ARCH=universal
     261
    259262        - On Mac OS X, Chicken can be built in 64-bit mode on Intel
    260263          Core 2 Duo systems--basically, most recent machines.  The default
  • chicken/branches/release/banner.scm

    r5968 r7931  
    66)
    77
    8 (define-constant +copyright+ "(c)2000-2007 Felix L. Winkelmann")
     8(define-constant +copyright+ "(c)2000-2008 Felix L. Winkelmann")
  • chicken/branches/release/buildversion

    r7332 r7931  
    1 2.740
     12.741
  • chicken/branches/release/c-backend.scm

    r7276 r7931  
    493493        (unless (zero? n)
    494494          (gen #t #t "static C_TLS C_word lf[" n "];") )
     495        (gen #t "static double C_possibly_force_alignment;")
    495496        (do ((i 0 (add1 i))
    496497             (llits lliterals (cdr llits)))
     
    498499          (let* ((ll (##sys#lambda-info->string (car llits)))
    499500                 (llen (string-length ll)))
    500             (gen #t "static C_char C_TLS li" i "[]={C_lihdr("
     501            (gen #t "static C_char C_TLS li" i "[] C_aligned={C_lihdr("
    501502                 (arithmetic-shift llen -16) #\,
    502503                 (bitwise-and #xff (arithmetic-shift llen -8)) #\,
     
    506507                ((>= n llen))
    507508              (gen #\, (char->integer (string-ref ll n))) )
     509            (do ((n (remainder llen 8) (sub1 n))) ; fill up with zeros to align following entry
     510                ((zero? n))
     511              (gen ",0") )
    508512            (gen "};")))))
    509513 
  • chicken/branches/release/chicken-bug.scm

    r7276 r7931  
    3232  (print "\n--------------------------------------------------\n")
    3333  (print "This is a bug report generated by chicken-bug(1).\n")
    34   (print "Date:\t" (seconds->string (current-seconds)) "\n")
     34  (print "Date:\t" (seconds->string (current-seconds)) "\n\n")
    3535  (printf "User information:\t~s~%~%" (user-information (current-user-id)))
    3636  (print "Host information:\n")
  • chicken/branches/release/chicken-more-macros.scm

    r7276 r7931  
    383383                            `(let ((,var ,(cadr b)))
    384384                               (if ,var ,(fold bs2) #f) ) ) ] ) ) ) ) ) ) ) )
    385 
    386 (##sys#register-macro-2
    387  'cond-expand
    388    (lambda (clauses)
    389 
    390      (define (err x)
    391        (##sys#error "syntax error in `cond-expand' form" x (cons 'cond-expand clauses)) )
    392 
    393      (define (test fx)
    394        (cond ((symbol? fx) (##sys#feature? fx))
    395              ((not (pair? fx)) (err fx))
    396              (else
    397               (let ((rest (##sys#slot fx 1)))
    398                 (case (##sys#slot fx 0)
    399                   ((and)
    400                    (or (eq? rest '())
    401                        (if (pair? rest)
    402                            (and (test (##sys#slot rest 0))
    403                                 (test `(and ,@(##sys#slot rest 1))) )
    404                            (err fx) ) ) )
    405                   ((or)
    406                    (and (not (eq? rest '()))
    407                         (if (pair? rest)
    408                             (or (test (##sys#slot rest 0))
    409                                 (test `(or ,@(##sys#slot rest 1))) )
    410                             (err fx) ) ) )
    411                   ((not) (not (test (cadr fx))))
    412                   (else (err fx)) ) ) ) ) )
    413 
    414      (let expand ((cls clauses))
    415        (cond ((eq? cls '())
    416               (##sys#apply
    417                ##sys#error "no matching clause in `cond-expand' form"
    418                (map (lambda (x) (car x)) clauses) ) )
    419              ((not (pair? cls)) (err cls))
    420              (else
    421               (let ((clause (##sys#slot cls 0))
    422                     (rclauses (##sys#slot cls 1)) )
    423                 (if (not (pair? clause))
    424                     (err clause)
    425                     (let ((id (##sys#slot clause 0)))
    426                       (cond ((eq? id 'else)
    427                              (let ((rest (##sys#slot clause 1)))
    428                                (if (eq? rest '())
    429                                    '(##core#undefined)
    430                                    `(begin ,@rest) ) ) )
    431                             ((test id) `(begin ,@(##sys#slot clause 1)))
    432                             (else (expand rclauses)) ) ) ) ) ) ) ) ) )
    433385
    434386(##sys#register-macro-2
  • chicken/branches/release/chicken-setup.1

    r6226 r7931  
    5050.SH OPTIONS
    5151
    52 .TP
    53 .B \-check
    54 Downloads the repository-index and lists locally installed extensions for which a newer
    55 release is available for download.
    56 
    5752.TP
    5853.BI \-csc\-option option
  • chicken/branches/release/chicken-setup.scm

    r7276 r7931  
    147147(define *target-lib-home* (foreign-value "C_TARGET_LIB_HOME" c-string))
    148148
     149(define *major-version* (##sys#fudge 41))
     150(define *default-eggdir* (conc "eggs/" *major-version*))
     151
    149152(define *windows*
    150153  (and (eq? (software-type) 'windows)
     
    188191(define *local-repository* #f)
    189192(define *destdir* #f)
    190 (define *repository-hosts* '(("www.call-with-current-continuation.org" "eggs" 80)))
     193(define *repository-hosts*
     194  (list (list "www.call-with-current-continuation.org" *default-eggdir* 80)))
    191195(define *revision* #f)
    192196(define *run-tests* #f)
     
    11411145    (with-output-to-file (doc-index)
    11421146      (lambda ()
    1143         (printf "<html><head><title>Egg documentation index for ~a</title><link rel=\"stylesheet\" type=\"text/css\" href=\"style.css\"/></head>~%" hn)
    1144         (printf "<body><a id=\"official-index\" href=\"http://www.call-with-current-continuation.org/eggs/index.html\">Visit the official egg index</a>~%")
    1145         (printf "<h1 id=\"title\">Egg documentation index:</h1>~%")
     1147        (print "<html><head><title>Egg documentation index for " hn
     1148               "</title><link rel=\"stylesheet\" type=\"text/css\" href=\"style.css\"/></head>")
     1149        (print "<body><a id=\"official-index\" href=\"http://www.call-with-current-continuation.org/"
     1150               *default-eggdir* "/index.html\">Visit the official egg index</a>")
     1151        (print "<h1 id=\"title\">Egg documentation index:</h1>")
    11461152        (printf "<p id=\"install-info\">CHICKEN: ~a<br>Host: ~a<br>Repository path: ~a<br><p>~%"
    11471153                (chicken-version #t)
    11481154                (get-host-name)
    11491155                rpath)
    1150         (printf "<table id=\"egg-index\">~%")
    1151         (printf "<thead><tr><th>Egg name</th><th>Version</th><th>Release</th></tr></thead>~%<tbody>~%")
     1156        (print "<table id=\"egg-index\">")
     1157        (print "<thead><tr><th>Egg name</th><th>Version</th><th>Release</th></tr></thead>\n<tbody>")
    11521158        (let ((c 0))
    11531159          (for-each
     
    12391245    (set! *repository-hosts*
    12401246      (cons (match (string-match "(.+)\\:([0-9]+)" host)
    1241               ((_ host port) (list host (if eggdir "eggs" "") (string->number port)))
    1242               (_ (list host (if eggdir "eggs" "") 80)) )
     1247              ((_ host port) (list host (if eggdir *default-eggdir* "") (string->number port)))
     1248              (_ (list host (if eggdir (conc *default-eggdir* "") 80)) ) )
    12431249            *repository-hosts*) )  )
    12441250  (setup-root-directory *base-directory*)
  • chicken/branches/release/chicken.h

    r7276 r7931  
    3939#ifndef ___CHICKEN
    4040#define ___CHICKEN
     41
     42#define C_MAJOR_VERSION       3
    4143
    4244/*
     
    505507#  define C_noret                 __attribute__ ((noreturn))
    506508#  define C_noret_decl(name)
     509#  define C_aligned               __attribute__ ((aligned))
    507510# endif
    508511# ifdef __i386__
     
    532535#ifndef C_ccall
    533536# define C_ccall
     537#endif
     538
     539#ifndef C_aligned
     540# define C_aligned
    534541#endif
    535542
     
    767774#define C_mk_bool(x)               ((x) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
    768775#define C_mk_nbool(x)              ((x) ? C_SCHEME_FALSE : C_SCHEME_TRUE)
    769 #define C_port_file(p)             ((C_FILEPTR)C_u_i_car(p))
     776#define C_port_file(p)             ((C_FILEPTR)C_block_item(p, 0))
    770777#define C_data_pointer(x)          ((void *)((C_SCHEME_BLOCK *)(x))->data)
    771778#define C_invert_flag(f)           (!(f))
     
    813820#define C_boundp(x)               C_mk_bool(((C_SCHEME_BLOCK *)(x))->data[ 0 ] != C_SCHEME_UNBOUND)
    814821#define C_blockp(x)               C_mk_bool(!C_immediatep(x))
     822#define C_forwardedp(x)           C_mk_bool((C_block_header(x) & C_GC_FORWARDING_BIT) != 0)
    815823#define C_immp(x)                 C_mk_bool(C_immediatep(x))
    816824#define C_flonump(x)              C_mk_bool(C_block_header(x) == C_FLONUM_TAG)
  • chicken/branches/release/compiler.scm

    r7276 r7931  
    22982298   
    22992299    (define (immediate-literal x)
    2300       (make-node '##core#immediate
    2301                  (cond ((fixnum? x) `(fix ,x))
    2302                        ((boolean? x) `(bool ,x))
    2303                        ((char? x) `(char ,x))
    2304                        ((null? x) '(nil))
    2305                        ((eof-object? x) '(eof))
    2306                        (else (bomb "bad immediate (prepare)")) )
    2307                  '() ) )
     2300      (if (eq? (void) x)
     2301          (make-node '##core#undefined '() '())
     2302          (make-node '##core#immediate
     2303                     (cond ((fixnum? x) `(fix ,x))
     2304                           ((boolean? x) `(bool ,x))
     2305                           ((char? x) `(char ,x))
     2306                           ((null? x) '(nil))
     2307                           ((eof-object? x) '(eof))
     2308                           (else (bomb "bad immediate (prepare)")) )
     2309                     '() ) ) )
    23082310   
    23092311    (debugging 'p "preparation phase...")
  • chicken/branches/release/config-arch.sh

    r5931 r7931  
    4141            *) echo "ppc.sysv";;
    4242        esac;;
     43    sparc64) echo "sparc64";;
    4344    amd64|x86_64) echo "x86-64";;
    4445    *) ;;
  • chicken/branches/release/csi.scm

    r7332 r7931  
    9191    -i  -case-insensitive       enable case-insensitive reading
    9292    -e  -eval EXPRESSION        evaluate given expression
     93    -p  -print EXPRESSION       evaluate and print result(s)
     94    -P  -pretty-print EXPRESSION  evaluate and print result(s) prettily
    9395    -D  -feature SYMBOL         register feature identifier
    9496    -q  -quiet                  do not print banner
     
    797799
    798800(define-constant short-options
    799   '(#\k #\s #\v #\h #\D #\e #\i #\R #\b #\n #\q #\w #\- #\I #f #f) )
     801  '(#\k #\s #\v #\h #\D #\e #\i #\R #\b #\n #\q #\w #\- #\I #\p #\P) )
    800802
    801803(define-constant long-options
    802   '("-keyword-style" "-script" "-version" "-help" "--help" "--" "-feature" "-eval" "-case-insensitive"
    803     "-require-extension" "-batch" "-quiet" "-no-warnings" "-no-init" "-include-path" "-release" "-ss") )
     804  '("-keyword-style" "-script" "-version" "-help" "--help" "--" "-feature"
     805    "-eval" "-case-insensitive"
     806    "-require-extension" "-batch" "-quiet" "-no-warnings" "-no-init"
     807    "-include-path" "-release" "-ss"
     808    "-print" "-pretty-print") )
    804809
    805810(define (canonicalize-args args)
     
    848853           (and-let* ([p (member "--" args)])
    849854             (set-cdr! p '()) ) ] )
    850     (let* ([eval? (member* '("-e" "-eval") args)]
     855    (let* ([eval? (member* '("-e" "-p" "-P" "-eval" "-print" "-pretty-print") args)]
    851856           [batch (or script (member* '("-b" "-batch") args) eval?)]
    852857           [quietflag (member* '("-q" "-quiet") args)]
     
    869874                (when (file-exists? fn)
    870875                  (load fn) ) ) ) ) )
     876      (define (evalstring str #!optional (rec (lambda _ (void))))
     877        (let ((in (open-input-string str)))
     878          (do ([x (read in) (read in)])
     879              ((eof-object? x))
     880            (rec (receive (eval x))) ) ) )
    871881      (when quietflag (set! ##sys#eval-debug-level 0))
    872882      (when (member* '("-h" "-help" "--help") args)
     
    919929          (cond ((member
    920930                  arg
    921                   '("--" "-batch" "-quiet" "-no-init" "-no-warnings" "-script" "-b" "-q" "-n" "-w" "-s" "-i"
     931                  '("--" "-batch" "-quiet" "-no-init" "-no-warnings" "-script"
     932                    "-b" "-q" "-n" "-w" "-s" "-i"
    922933                    "-case-insensitive" "-ss") ) )
    923                 ((member arg '("-feature" "-include-path" "-keyword-style" "-D" "-I" "-k"))
     934                ((member arg '("-feature" "-include-path" "-keyword-style"
     935                               "-D" "-I" "-k"))
    924936                 (set! args (cdr args)) )
    925937                ((or (string=? "-R" arg) (string=? "-require-extension" arg))
     
    927939                 (set! args (cdr args)) )
    928940                ((or (string=? "-e" arg) (string=? "-eval" arg))
    929                  (let ([in (open-input-string (cadr args))])
    930                    (do ([x (read in) (read in)])
    931                        ((eof-object? x))
    932                      (eval x) )
    933                    (set! args (cdr args)) ) )
     941                 (evalstring (cadr args))
     942                 (set! args (cdr args)) )
     943                ((or (string=? "-p" arg) (string=? "-print" arg))
     944                 (evalstring
     945                  (cadr args)
     946                  (cut for-each print <...>) )
     947                 (set! args (cdr args)) )
     948                ((or (string=? "-P" arg) (string=? "-pretty-print" arg))
     949                 (evalstring
     950                  (cadr args)
     951                  (cut for-each pretty-print <...>) )
     952                 (set! args (cdr args)) )
    934953                (else
    935954                 (load arg)
  • chicken/branches/release/debian/rules

    r7276 r7931  
    2222        dh_testdir
    2323#       CFLAGS="$(CFLAGS)" ./configure --prefix=/usr --mandir=\$${prefix}/share/man --infodir=\$${prefix}/share/info
    24         $(MAKE) MAKEINFO_PROGRAM_OPTIONS="" CFLAGS="$(CFLAGS)" PREFIX="$(PREFIX)" MANDIR="$(PREFIX)/share/man" INFODIR="$(PREFIX)/share/info" SHAREDIR="$(PREFIX)/share" EGGDIR="/var/lib/chicken/$(BINARYVERSION)" MAKEINFO_PROGRAM_OPTIONS= HOSTNAME=debian
     24        $(MAKE) \
     25            MAKEINFO_PROGRAM_OPTIONS="" \
     26            CFLAGS="$(CFLAGS)" \
     27            PREFIX="$(PREFIX)" \
     28            MANDIR="$(PREFIX)/share/man" \
     29            INFODIR="$(PREFIX)/share/info" \
     30            SHAREDIR="$(PREFIX)/share" \
     31            EGGDIR="/var/lib/chicken/$(BINARYVERSION)" \
     32            MAKEINFO_PROGRAM_OPTIONS= \
     33            HOSTNAME=debian
    2534        touch build-stamp
    2635
     
    4958# i.e. /var/lib/chicken, then those files will be installed on the
    5059# build system, but will not end up in the package.
    51         $(MAKE) install PREFIX="$(CURDIR)/debian/tmp/usr" MANDIR="$(CURDIR)/debian/tmp/usr/share/man" INFODIR="$(CURDIR)/debian/tmp/usr/share/info" SHAREDIR="$(CURDIR)/debian/tmp/usr/share" EGGDIR="$(CURDIR)/debian/tmp/var/lib/chicken/$(BINARYVERSION)" MAKEINFO_PROGRAM_OPTIONS= HOSTNAME=debian
     60        $(MAKE) \
     61            install \
     62            PREFIX="$(CURDIR)/debian/tmp/usr" \
     63            MANDIR="$(CURDIR)/debian/tmp/usr/share/man" \
     64            INFODIR="$(CURDIR)/debian/tmp/usr/share/info" \
     65            SHAREDIR="$(CURDIR)/debian/tmp/usr/share" \
     66            EGGDIR="$(CURDIR)/debian/tmp/var/lib/chicken/$(BINARYVERSION)" \
     67            MAKEINFO_PROGRAM_OPTIONS= \
     68            HOSTNAME=debian
    5269
    5370binary-common:
  • chicken/branches/release/defaults.make

    r7332 r7931  
    3636# basic parameters
    3737
    38 BINARYVERSION ?= 3
     38BINARYVERSION = 3
    3939NURSERY ?= (128*1024)
    4040STACKDIRECTION ?= 1
     
    232232O ?= .o
    233233A ?= .a
    234 # EXE =
     234# EXE ?=
    235235SO ?= .so
    236236
  • chicken/branches/release/eval.scm

    r7276 r7931  
    20212021 (lambda (x) `(##sys#make-promise (lambda () ,x))) )
    20222022
     2023(##sys#register-macro-2
     2024 'cond-expand
     2025   (lambda (clauses)
     2026
     2027     (define (err x)
     2028       (##sys#error "syntax error in `cond-expand' form" x (cons 'cond-expand clauses)) )
     2029
     2030     (define (test fx)
     2031       (cond ((symbol? fx) (##sys#feature? fx))
     2032             ((not (pair? fx)) (err fx))
     2033             (else
     2034              (let ((rest (##sys#slot fx 1)))
     2035                (case (##sys#slot fx 0)
     2036                  ((and)
     2037                   (or (eq? rest '())
     2038                       (if (pair? rest)
     2039                           (and (test (##sys#slot rest 0))
     2040                                (test `(and ,@(##sys#slot rest 1))) )
     2041                           (err fx) ) ) )
     2042                  ((or)
     2043                   (and (not (eq? rest '()))
     2044                        (if (pair? rest)
     2045                            (or (test (##sys#slot rest 0))
     2046                                (test `(or ,@(##sys#slot rest 1))) )
     2047                            (err fx) ) ) )
     2048                  ((not) (not (test (cadr fx))))
     2049                  (else (err fx)) ) ) ) ) )
     2050
     2051     (let expand ((cls clauses))
     2052       (cond ((eq? cls '())
     2053              (##sys#apply
     2054               ##sys#error "no matching clause in `cond-expand' form"
     2055               (map (lambda (x) (car x)) clauses) ) )
     2056             ((not (pair? cls)) (err cls))
     2057             (else
     2058              (let ((clause (##sys#slot cls 0))
     2059                    (rclauses (##sys#slot cls 1)) )
     2060                (if (not (pair? clause))
     2061                    (err clause)
     2062                    (let ((id (##sys#slot clause 0)))
     2063                      (cond ((eq? id 'else)
     2064                             (let ((rest (##sys#slot clause 1)))
     2065                               (if (eq? rest '())
     2066                                   '(##core#undefined)
     2067                                   `(begin ,@rest) ) ) )
     2068                            ((test id) `(begin ,@(##sys#slot clause 1)))
     2069                            (else (expand rclauses)) ) ) ) ) ) ) ) ) )
     2070
    20232071
    20242072;;; SRFI-0 support code:
  • chicken/branches/release/extras.scm

    r7276 r7931  
    373373             [limit (and parg (pair? (cdr args)) (cadr args))])
    374374        (##sys#check-port p 'read-line)
    375         (cond ((##sys#slot p 8) => (lambda (rl) (rl p limit)))
     375        (cond ((##sys#slot (##sys#slot p 2) 8) => (lambda (rl) (rl p limit)))
    376376              (else
    377377               (let* ((buffer-len (if limit limit 256))
     
    410410        (define (doread port)
    411411          (let loop ((lns '())
    412                      (n (or max 1000000)) )
     412                     (n (or max 1000000000)) ) ; this is silly
    413413            (if (eq? n 0)
    414414                (reverse lns)
     
    766766               (out (##sys#lambda-info->string obj) col)
    767767               (out "#>" col) )
    768               (else               (out "#<unprintable object>" col)) ) )
     768              (else (out "#<unprintable object>" col)) ) )
    769769
    770770      (define (pp obj col)
  • chicken/branches/release/library.scm

    r7332 r7931  
    913913
    914914(define (imag-part n)
    915   (##sys#check-number n 'real-part)
     915  (##sys#check-number n 'imag-part)
    916916  0)
     917
     918(define (numerator n)
     919  (##sys#check-number n 'numerator)
     920  (if (##core#inline "C_i_integerp" n)
     921      n
     922      (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" n) ) )
     923
     924(define (denominator n)
     925  (##sys#check-number n 'denominator)
     926  (if (##core#inline "C_i_integerp" n)
     927      1
     928      (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" n) ) )
    917929
    918930(define magnitude abs)
     
    16711683          #f                            ; read-string!
    16721684          (lambda (p limit)             ; read-line
    1673             (let ((buffer-len (if limit limit 256))
    1674                   (buffer (make-string buffer-len)))
     1685            (let* ((buffer-len (if limit limit 256))
     1686                   (buffer (make-string buffer-len)))
    16751687              (let loop ([len buffer-len]
    16761688                         [buffer buffer]
     
    27612773                ((eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))
    27622774                 (outstr port "#<unbound value>") )
    2763                 ((not (##core#inline "C_blockp" x)) (outstr port "#<unprintable object>"))
     2775                ((not (##core#inline "C_blockp" x)) (outstr port "#<invalid immediate object>"))
     2776                ((##core#inline "C_forwardedp" x) (outstr port "#<invalid forwarded object>"))
    27642777                ((##core#inline "C_symbolp" x)
    27652778                 (cond [(fx= 0 (##sys#byte (##sys#slot x 1) 0))
     
    30103023         n))
    30113024     (lambda (p limit)                  ; read-line
    3012        (let ((pos (##sys#slot p 10))
    3013              (size (##sys#slot p 11))
    3014              (buf (##sys#slot p 12))
    3015              (end (if limit (fx+ pos limit) size)))
     3025       (let* ((pos (##sys#slot p 10))
     3026              (size (##sys#slot p 11))
     3027              (buf (##sys#slot p 12))
     3028              (end (if limit (fx+ pos limit) size)))
    30163029         (if (fx>= pos size)
    30173030             #!eof
     
    30363049                ((and (eq? c #\return)
    30373050                      (fx> limit (fx+ pos2 1))
    3038                       (eq (##core#inline "C_subchar" buf (fx+ pos2 1)) #\newline) )
    3039                  (k pos2 (fx+ pos2 1)) )
     3051                      (eq? (##core#inline "C_subchar" buf (fx+ pos2 1)) #\newline) )
     3052                 (k pos2 (fx+ pos2 2)) )
    30403053                (else (loop (fx+ pos2 1))) ) ) ) ) )
    30413054
     
    34003413       (##sys#error-handler (lambda args (##core#inline "C_halt" "error in error")))
    34013414       (cond ((##sys#fudge 4)
    3402               (##core#inline "C_display_string" ##sys#standard-error "Error")
     3415              (##sys#print "Error" #f ##sys#standard-error)
    34033416              (when msg
    34043417                (##sys#print ": " #f ##sys#standard-error)
    34053418                (##sys#print msg #f ##sys#standard-error) )
    34063419              (cond [(fx= 1 (length args))
    3407                      (##core#inline "C_display_string" ##sys#standard-error ": ")
     3420                     (##sys#print ": " #f ##sys#standard-error)
    34083421                     (##sys#print (##sys#slot args 0) #t ##sys#standard-error) ]
    34093422                    [else
    34103423                     (##sys#for-each
    34113424                      (lambda (x)
    3412                         (##core#inline "C_display_char" ##sys#standard-error #\newline)
     3425                        (##sys#print #\newline #f ##sys#standard-error)
    34133426                        (##sys#print x #t ##sys#standard-error) )
    34143427                      args) ] )
    3415               (##core#inline "C_display_char" ##sys#standard-error #\newline)
     3428              (##sys#print #\newline #f ##sys#standard-error)
    34163429              (print-call-chain ##sys#standard-error)
    34173430              (when (and ##sys#break-on-error (##sys#symbol-has-toplevel-binding? 'repl))
    34183431                (repl)
    3419                 (##core#inline "C_display_char" ##sys#standard-error #\newline)
     3432                (##sys#print #\newline #f ##sys#standard-error)
    34203433                (##core#inline "C_exit_runtime" _ex_software) )
    34213434              (##core#inline "C_halt" #f) )
  • chicken/branches/release/manual/Acknowledgements

    r7276 r7931  
    2222Brad Kind, Ron Kneusel, Matthias Koeppe, Krysztof Kowa&#322;czyk,
    2323Andre Kuehne, Todd R. Kueny Sr, Goran Krampe, David Krentzlin, Ben
    24 Kurtz, Micky Latowicki, John Lenz, Kirill Lisovsky, Kon Lovett, Dennis
    25 Marti, Charles Martin, Bob McIsaac, Alain Mellan, Eric Merrit, Perry
    26 Metzger, Scott G. Miller, Mikael, Bruce Mitchener, Chris Moline, Eric
    27 E. Moore, Julian Morrison, Dan Muresan, Lars Nilsson, Ian Oversby,
    28 o.t., Gene Pavlovsky, Levi Pearson, Nicolas Pelletier, Carlos Pita,
    29 Robin Lee Powell, Pupeno, Davide Puricelli, Doug Quale, Eric Raible,
    30 Ivan Raikov, Joel Reymont, Eric Rochester, Andreas Rottman, David
    31 Rush, Lars Rustemeier, Daniel Sadilek, Oskar Schirmer, Burton
    32 Samograd, Reed Sheridan, Ronald Schroeder, Spencer Schumann, Alex
    33 Shinn, Ivan Shmakov, Shmul, Tony Sidaway, Jeffrey B. Siegal, Andrey
    34 Sidorenko, Michele Simionato, Volker Stolz, Jon Strait, Dorai Sitaram,
    35 Robert Skeels, Jason Songhurst, Clifford Stein, Sunnan, Zbigniew
    36 Szadkowski, Rick Taube, Mike Thomas, Minh Thu, Christian Tismer, Andre
    37 van Tonder, John Tobey, Henrik Tramberend, Vladimir Tsichevsky, Neil
    38 van Dyke, Sander Vesik, Panagiotis Vossos, Shawn Wagner, Peter Wang,
    39 Ed Watkeys, Thomas Weidner, Goeran Weinholt, Matthew Welland, Joerg
    40 Wittenberger, Peter Wright, Mark Wutka, Richard Zidlicky and Houman
    41 Zolfaghari for bug-fixes, tips and suggestions.
     24Kurtz, Micky Latowicki, John Lenz, Kirill Lisovsky, J&uuml;rgen
     25Lorentz, Kon Lovett, Dennis Marti, Charles Martin, Bob McIsaac, Alain
     26Mellan, Eric Merrit, Perry Metzger, Scott G. Miller, Mikael, Bruce
     27Mitchener, Chris Moline, Eric E. Moore, Julian Morrison, Dan Muresan,
     28Lars Nilsson, Ian Oversby, o.t., Gene Pavlovsky, Levi Pearson, Nicolas
     29Pelletier, Carlos Pita, Robin Lee Powell, Pupeno, Davide Puricelli,
     30Doug Quale, Eric Raible, Ivan Raikov, Joel Reymont, Eric Rochester,
     31Andreas Rottman, David Rush, Lars Rustemeier, Daniel Sadilek, Oskar
     32Schirmer, Burton Samograd, Reed Sheridan, Ronald Schroeder, Spencer
     33Schumann, Alex Shinn, Ivan Shmakov, Shmul, Tony Sidaway, Jeffrey
     34B. Siegal, Andrey Sidorenko, Michele Simionato, Volker Stolz, Jon
     35Strait, Dorai Sitaram, Robert Skeels, Jason Songhurst, Clifford Stein,
     36Sunnan, Zbigniew Szadkowski, Rick Taube, Mike Thomas, Minh Thu,
     37Christian Tismer, Andre van Tonder, John Tobey, Henrik Tramberend,
     38Vladimir Tsichevsky, Neil van Dyke, Sander Vesik, Panagiotis Vossos,
     39Shawn Wagner, Peter Wang, Ed Watkeys, Brad Watson, Thomas Weidner,
     40Goeran Weinholt, Matthew Welland, Joerg Wittenberger, Peter Wright,
     41Mark Wutka, Richard Zidlicky and Houman Zolfaghari for bug-fixes, tips
     42and suggestions.
    4243
    4344CHICKEN uses the PCRE regular expression package ([[http://www.pcre.org]]),
     
    4950
    5051Also special thanks to Benedikt Rosenau for his constant encouragement.
     52
     53Thanks to Dunja Winkelmann for putting up with all of this.
    5154
    5255CHICKEN contains code from several people:
  • chicken/branches/release/manual/The User's Manual

    r7332 r7931  
    33== The User's Manual
    44
    5 ''(This document describes version 2.740)''
     5''(This document describes version 3.0.0)''
    66
    77'''CHICKEN is a compiler that translates Scheme source files into C''', which in
  • chicken/branches/release/manual/Unit posix

    r7276 r7931  
    940940
    941941Converts the local time represented in {{SECONDS}} into a string
    942 of the form {{"Tue May 21 13:46:22 1991\n"}}.
     942of the form {{"Tue May 21 13:46:22 1991"}}.
    943943
    944944==== seconds->utc-time
     
    962962Converts the broken down time represented in the 10 element vector
    963963{{VECTOR}} into a string of the form {{"Tue May 21 13:46:22
    964 1991\n"}}.
     9641991"}}.
    965965
    966966
  • chicken/branches/release/manual/Using the interpreter

    r7276 r7931  
    2828; -e  -eval EXPRESSIONS : Evaluate {{EXPRESSIONS}}. This option implies {{-batch}} and {{-quiet}}, so no startup message will be printed and the interpreter exits after processing all {{-eval}} options and/or loading files given on the command-line.
    2929
    30 ; -D  -feature SYMBOL : Registers {{SYMBOL}} to be a valid feature identifier for {{cond-expand}}.
     30; -p  -print EXPRESSIONS : Evaluate {{EXPRESSIONS}} and print the results of each expression using {{print}}. Implies {{-batch}} and {{-quiet}}.
     31
     32; -P  -pretty-print EXPRESSIONS : Evaluate {{EXPRESSIONS}} and print the results of each expression using {{pretty-print}}. Implies {{-batch}} and {{-quiet}}.
     33
     34; -D  -feature SYMBOL : Registers {{SYMBOL}} to be a valid feature identifier for {{cond-expand}} and {{feature?}}.
    3135
    3236; -h  -help : Write a summary of the available command line options to standard output and exit.
  • chicken/branches/release/manual/chicken-setup

    r7276 r7931  
    612612
    613613 % cd /opt
    614  % svn co https://galinha.ucpel.tche.br/svn/chicken-eggs
     614 % svn co https://galinha.ucpel.tche.br/svn/chicken-eggs/release/3 eggs
    615615
    616616Get your own copy of the repository file:
     
    622622
    623623 % cd ~/tmp
    624  % chicken-setup -local /opt/eggs/chicken-eggs -tree ~/my-repository-file opengl
     624 % chicken-setup -local /opt/eggs -tree ~/my-repository-file opengl
    625625
    626626
  • chicken/branches/release/misc/setversion.scm

    r7276 r7931  
    11;;;; setversion.scm - Bump version-number
    22
    3 (use utils)
     3(use srfi-1 utils)
    44
    55(define buildversion (->string (car (read-file "buildversion"))))
     
    2626       (system* "mv ~S ~S" tmp both ) ) ) ) )
    2727
     28(define (parse-version v)
     29  (string-match "(\\d+)\\.(\\d+)\\.(\\d+)(.*)" v) )
     30
    2831(define (main args)
    2932  (cond ((member "-set" args) =>
    3033         (lambda (a) (set! buildversion (cadr a))) )
    3134        ((not (member "-noinc" args))
    32          (set! buildversion (number->string (+ (string->number buildversion) 0.001))) ) )
     35         (match (parse-version buildversion)
     36           ((_ maj min pl huh)
     37            (set! buildversion (conc maj "." min "." (add1 (string->number pl)) huh)) ) ) ) )
    3338  (with-output-to-file "buildversion" (cut display buildversion))
    3439  (with-output-to-file "version.scm"
  • chicken/branches/release/posixunix.scm

    r7276 r7931  
    6161#include <dirent.h>
    6262#include <pwd.h>
     63
     64#if defined(__sun__) && defined(__svr4__)
     65# include <sys/tty.h>
     66#endif
    6367
    6468#ifdef HAVE_GRP_H
     
    363367#define C_set_groups(n)   C_fix(setgroups(C_unfix(n), C_groups))
    364368
     369#ifdef TIOCGWINSZ
    365370static int get_tty_size(int p, int *rows, int *cols)
    366371{
     
    377382 return r;
    378383}
     384#else
     385static int get_tty_size(int p, int *rows, int *cols)
     386{
     387 *rows = *cols = 0;
     388 return -1;
     389}
     390#endif
    379391
    380392EOF
     
    17391751      (let ([str (ctime secs)])
    17401752        (unless str (##sys#error 'seconds->string "cannot convert seconds to string" secs))
    1741         str) ) ) )
     1753        (##sys#substring str 0 (fx- (##sys#size str) 1))))))
    17421754
    17431755(define time->string
     
    17481760      (let ([str (asctime tm)])
    17491761        (unless str (##sys#error 'time->string "cannot convert time vector to string" tm))
    1750         str) ) ) )
     1762        (##sys#substring str 0 (fx- (##sys#size str) 1))))))
    17511763
    17521764(define (local-time->seconds tm)
  • chicken/branches/release/posixwin.scm

    r7276 r7931  
    15761576      (let ([str (ctime secs)])
    15771577        (unless str (##sys#error 'seconds->string "cannot convert seconds to string" secs))
    1578         str) ) ) )
     1578        (##sys#substring str 0 (fx- (##sys#size str) 1))))))
    15791579
    15801580(define time->string
     
    15851585      (let ([str (asctime tm)])
    15861586        (unless str (##sys#error 'time->string "cannot time vector to string" tm))
    1587         str) ) ) )
     1587        (##sys#substring str 0 (fx- (##sys#size str) 1))))))
    15881588
    15891589(define (local-time->seconds tm)
  • chicken/branches/release/rules.make

    r7332 r7931  
    762762ifdef WINDOWS
    763763        $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_SHARED_LIBRARY_OPTIONS) libchickengui$(SO) \
    764           $(DESTDIR)$(ILIBDIR)
     764          $(DESTDIR)$(IBINDIR)
    765765endif
    766766endif
     
    10351035        touch *.c
    10361036        $(MAKE) -f Makefile.$(PLATFORM) STATICBUILD=1 chicken
     1037        cp chicken chicken-boot
    10371038        touch *.scm
    1038         $(MAKE) CHICKEN=./chicken all
     1039        $(MAKE) CHICKEN=./chicken-boot all
    10391040
    10401041bootstrap.tar.gz:
  • chicken/branches/release/runtime.c

    r7332 r7931  
    398398  *heap_scan_top,
    399399  *timer_start_fromspace_top;
     400static C_TLS size_t
     401  heapspace1_size,
     402  heapspace2_size;
    400403static C_TLS C_char
    401404  buffer[ STRING_BUFFER_SIZE ],
     
    475478  callback_returned_flag;
    476479static C_TLS WEAK_TABLE_ENTRY *weak_item_table;
    477 static C_TLS C_GC_ROOT *gc_root_list;
     480static C_TLS C_GC_ROOT *gc_root_list = NULL;
    478481static C_TLS FINALIZER_NODE
    479482  *finalizer_list,
     
    10201023/* Align memory to page boundary */
    10211024
     1025#ifndef C_LOCK_TOSPACE
    10221026static void *align_to_page(void *mem)
    10231027{
     1028  return (void *)C_align((C_uword)mem);
     1029}
     1030#endif
     1031
     1032static C_byte *
     1033heap_alloc (size_t size, C_byte **page_aligned)
     1034{
     1035  C_byte *p;
    10241036#ifdef C_LOCK_TOSPACE
    1025   C_uword ptr = (C_word)mem;
    1026 
    1027   return (void *)(((ptr) + page_size - 1) & ~(page_size - 1));
     1037  p = (C_byte *)mmap (NULL, size, (PROT_READ | PROT_WRITE),
     1038                      (MAP_PRIVATE | MAP_ANONYMOUS), -1, 0);
     1039  if (p != NULL && page_aligned) *page_aligned = p;
    10281040#else
    1029   return (void *)C_align((C_uword)mem);
    1030 #endif
    1031 }
    1032 
     1041  p = (C_byte *)C_malloc (size + page_size);
     1042  if (p != NULL && page_aligned) *page_aligned = align_to_page (p);
     1043#endif
     1044
     1045  /* . */
     1046  return p;
     1047}
     1048
     1049static void
     1050heap_free (C_byte *ptr, size_t size)
     1051{
     1052#ifdef C_LOCK_TOSPACE
     1053  int r = munmap (ptr, size);
     1054  assert (r == 0);
     1055#else
     1056  C_free (ptr);
     1057#endif
     1058  /* . */
     1059}
     1060
     1061static C_byte *
     1062heap_realloc (C_byte *ptr, size_t old_size,
     1063              size_t new_size, C_byte **page_aligned)
     1064{
     1065  C_byte *p;
     1066#ifdef C_LOCK_TOSPACE
     1067  p = (C_byte *)mmap (NULL, new_size, (PROT_READ | PROT_WRITE),
     1068                      (MAP_PRIVATE | MAP_ANONYMOUS), -1, 0);
     1069  if (ptr != NULL) {
     1070    memcpy (p, ptr, old_size);
     1071    heap_free (ptr, old_size);
     1072  }
     1073  if (p != NULL && page_aligned) *page_aligned = p;
     1074#else
     1075  p = (C_byte *)C_realloc (ptr, new_size + page_size);
     1076  if (p != NULL && page_aligned) *page_aligned = align_to_page (p);
     1077#endif
     1078
     1079  /* . */
     1080  return p;
     1081}
    10331082
    10341083/* Modify heap size at runtime: */
     
    10361085void C_set_or_change_heap_size(C_word heap, int reintern)
    10371086{
    1038   C_byte *ptr1, *ptr2;
     1087  C_byte *ptr1, *ptr2, *ptr1a, *ptr2a;
    10391088  C_word size = heap / 2;
    10401089
     
    10471096  heap_size = heap;
    10481097
    1049   if((ptr1 = (C_byte *)C_realloc(fromspace_start, size + page_size)) == NULL ||
    1050      (ptr2 = (C_byte *)C_realloc(tospace_start, size + page_size)) == NULL)
     1098  if((ptr1 = heap_realloc (fromspace_start,
     1099                           C_fromspace_limit - fromspace_start,
     1100                           size, &ptr1a)) == NULL ||
     1101     (ptr2 = heap_realloc (tospace_start,
     1102                           tospace_limit - tospace_start,
     1103                           size, &ptr2a)) == NULL)
    10511104    panic(C_text("out of memory - can not allocate heap"));
    10521105
    1053   heapspace1 = ptr1;
    1054   heapspace2 = ptr2;
    1055   ptr1 = align_to_page(ptr1);
    1056   ptr2 = align_to_page(ptr2);
    1057   fromspace_start = ptr1;
     1106  heapspace1 = ptr1, heapspace1_size = size;
     1107  heapspace2 = ptr2, heapspace2_size = size;
     1108  fromspace_start = ptr1a;
    10581109  C_fromspace_top = fromspace_start;
    10591110  C_fromspace_limit = fromspace_start + size;
    1060   tospace_start = ptr2;
     1111  tospace_start = ptr2a;
    10611112  tospace_top = tospace_start;
    10621113  tospace_limit = tospace_start + size;
     
    31133164  FINALIZER_NODE *flist;
    31143165  TRACE_INFO *tinfo;
    3115   void *new_heapspace;
     3166  C_byte *new_heapspace;
     3167  size_t  new_heapspace_size;
    31163168
    31173169  lock_tospace(0);
     
    31393191  size /= 2;
    31403192
    3141   if((new_tospace_start = (C_byte *)C_malloc(size + page_size)) == NULL)
     3193  if ((new_heapspace = heap_alloc (size, &new_tospace_start)) == NULL)
    31423194    panic(C_text("out of memory - can not allocate heap segment"));
    3143 
    3144   new_heapspace = new_tospace_start;
    3145   new_tospace_start = align_to_page(new_tospace_start);
     3195  new_heapspace_size = size;
     3196
    31463197  new_tospace_top = new_tospace_start;
    31473198  new_tospace_limit = new_tospace_start + size;
     
    32303281  }
    32313282
    3232   C_free(heapspace1);
    3233   C_free(heapspace2);
     3283  heap_free (heapspace1, heapspace1_size);
     3284  heap_free (heapspace2, heapspace1_size);
    32343285 
    3235   if((tospace_start = (C_byte *)C_malloc(size + page_size)) == NULL)
     3286  if ((heapspace2 = heap_alloc (size, &tospace_start)) == NULL)
    32363287    panic(C_text("out ot memory - can not allocate heap segment"));
     3288  heapspace2_size = size;
    32373289
    32383290  heapspace1 = new_heapspace;
    3239   heapspace2 = tospace_start;
    3240   tospace_start = align_to_page(tospace_start);
     3291  heapspace1_size = new_heapspace_size;
    32413292  tospace_limit = tospace_start + size;
    32423293  tospace_top = tospace_start;
     
    41994250    return C_SCHEME_FALSE;
    42004251#endif
     4252
     4253  case C_fix(41):
     4254    return C_fix(C_MAJOR_VERSION);
    42014255
    42024256  default: return C_SCHEME_UNDEFINED;
  • chicken/branches/release/scheme-complete.el

    r7332 r7931  
    3232;;;     (eldoc-mode)))
    3333;;;
    34 ;;; There's a single custom variable, default-scheme-implementation,
     34;;; There's a single custom variable, `default-scheme-implementation',
    3535;;; which you can use to specify your preferred implementation when we
    3636;;; can't infer it from the source code.
     
    3939
    4040;;; History:
     41;;;   0.7: 2008/01/18 - handles higher-order types (for apply, map, etc.)
     42;;;                     smarter string completion (hostname, username, etc.)
     43;;;                     smarter type inference, various bugfixes
    4144;;;   0.6: 2008/01/06 - more bugfixes (merry christmas)
    4245;;;   0.5: 2008/01/03 - handling internal defines, records, smarter
     
    7174;;   (set name values ...)
    7275;;   (flags name values ...)
    73 ;;   (special function [outer-function])
     76;;   (list type)
     77;;   (string expander)
     78;;   (special type function [outer-function])
    7479
    7580(defvar *scheme-r5rs-info*
     
    260265    (vector-fill! (lambda (vec obj) undefined) "set every element in VEC to OBJ")
    261266    (procedure? (lambda (obj) bool) "returns #t iff OBJ is a procedure")
    262     (apply (lambda (proc obj |...|) obj) "procedure application")
    263     (map (lambda (proc list) list) "a new list of PROC applied to every element of LIST")
    264     (for-each (lambda (proc list)) "apply PROC to each element of LIST in order")
     267    (apply (lambda ((lambda obj a) obj |...|) a) "procedure application")
     268    (map (lambda ((lambda obj a) obj |...|) (list a)) "a new list of PROC applied to every element of LIST")
     269    (for-each (lambda ((lambda obj a) obj |...|) undefined) "apply PROC to each element of LIST in order")
    265270    (force (lambda (promise) obj) "force the delayed value of PROMISE")
    266271    (call-with-current-continuation (lambda (proc) obj) "goto on steroids")
     
    351356    (unzip5 (lambda (list) list))
    352357    (count (lambda (procedure list |...|) n))
    353     (fold (lambda (procedure object list |...|) obj))
     358    (fold (lambda ((lambda obj a) object list |...|) a))
    354359    (unfold (lambda (procedure procedure procedure object :optional procedure) obj))
    355     (pair-fold (lambda (procedure object list |...|) obj))
    356     (reduce (lambda (procedure object list |...|) obj))
    357     (fold-right (lambda (procedure object list |...|) obj))
     360    (pair-fold (lambda ((lambda obj a) object list |...|) a))
     361    (reduce (lambda ((lambda obj a) object list |...|) a))
     362    (fold-right (lambda ((lambda obj a) object list |...|) a))
    358363    (unfold-right (lambda (procedure procedure procedure object :optional object) obj))
    359     (pair-fold-right (lambda (procedure object list |...|) obj))
    360     (reduce-right (lambda (procedure object list |...|) obj))
     364    (pair-fold-right (lambda ((lambda obj a) object list |...|) a))
     365    (reduce-right (lambda ((lambda obj a) object list |...|) a))
    361366    (append-map (lambda (procedure list |...|) list))
    362367    (append-map! (lambda (procedure list |...|) list))
    363368    (map! (lambda (procedure list |...|) list))
    364     (pair-for-each (lambda (procedure list |...|)))
     369    (pair-for-each (lambda (procedure list |...|) undefined))
    365370    (filter-map (lambda (procedure list |...|) list))
    366371    (map-in-order (lambda (procedure list |...|) list))
     
    373378    (find (lambda (procedure list) obj))
    374379    (find-tail (lambda (procedure list) obj))
    375     (any (lambda (procedure list |...|) obj))
    376     (every (lambda (procedure list |...|) obj))
    377     (list-index (lambda (procedure list |...|) obj))
     380    (any (lambda ((lambda obj a) list |...|) a))
     381    (every (lambda ((lambda obj a) list |...|) a))
     382    (list-index (lambda (procedure list |...|) (or bool integer)))
    378383    (take-while (lambda (procedure list) list))
    379384    (drop-while (lambda (procedure list) list))
     
    543548   ;; SRFI 13
    544549   ("String Library"
    545     (string-map (lambda (proc s :optional start end) s))
    546     (string-map! (lambda (proc s :optional start end) undefined))
    547     (string-fold (lambda (kons knil s :optional start end) obj))
    548     (string-fold-right (lambda (kons knil s :optional start end) obj))
     550    (string-map (lambda (proc str :optional start end) str))
     551    (string-map! (lambda (proc str :optional start end) undefined))
     552    (string-fold (lambda (kons knil str :optional start end) obj))
     553    (string-fold-right (lambda (kons knil str :optional start end) obj))
    549554    (string-unfold (lambda (p f g seed :optional base make-final) str))
    550555    (string-unfold-right (lambda (p f g seed :optional base make-final) str))
    551556    (string-tabulate (lambda (proc len) str))
    552     (string-for-each (lambda (proc s :optional start end)))
    553     (string-for-each-index (lambda (proc s :optional start end)))
    554     (string-every (lambda (pred s :optional start end) obj))
    555     (string-any (lambda (pred s :optional start end) obj))
    556     (string-hash (lambda (s :optional bound start end) int))
    557     (string-hash-ci (lambda (s :optional bound start end) int))
     557    (string-for-each (lambda (proc str :optional start end) undefined))
     558    (string-for-each-index (lambda (proc str :optional start end) undefined))
     559    (string-every (lambda (pred str :optional start end) obj))
     560    (string-any (lambda (pred str :optional start end) obj))
     561    (string-hash (lambda (str :optional bound start end) int))
     562    (string-hash-ci (lambda (str :optional bound start end) int))
    558563    (string-compare (lambda (string1 string2 lt-proc eq-proc gt-proc :optional start end) obj))
    559564    (string-compare-ci (lambda (string1 string2 lt-proc eq-proc gt-proc :optional start end) obj))
     
    573578    (string-upcase (lambda (string :optional start end) str))
    574579    (string-downcase (lambda (string :optional start end) str))
    575     (string-titlecase! (lambda (string :optional start end)))
    576     (string-upcase! (lambda (string :optional start end)))
    577     (string-downcase! (lambda (string :optional start end)))
     580    (string-titlecase! (lambda (string :optional start end) undefined))
     581    (string-upcase! (lambda (string :optional start end) undefined))
     582    (string-downcase! (lambda (string :optional start end) undefined))
    578583    (string-take (lambda (string nchars) str))
    579584    (string-drop (lambda (string nchars) str))
     
    587592    (string-filter (lambda (char/char-set/pred string :optional start end) str))
    588593    (string-delete (lambda (char/char-set/pred string :optional start end) str))
    589     (string-index (lambda (string char/char-set/pred :optional start end) obj))
    590     (string-index-right (lambda (string char/char-set/pred :optional end start) obj))
    591     (string-skip (lambda (string char/char-set/pred :optional start end) str))
    592     (string-skip-right (lambda (string char/char-set/pred :optional end start) str))
     594    (string-index (lambda (string char/char-set/pred :optional start end) (or integer bool)))
     595    (string-index-right (lambda (string char/char-set/pred :optional end start) (or integer bool)))
     596    (string-skip (lambda (string char/char-set/pred :optional start end) (or integer bool)))
     597    (string-skip-right (lambda (string char/char-set/pred :optional end start) (or integer bool)))
    593598    (string-count (lambda (string char/char-set/pred :optional start end) n))
    594599    (string-prefix-length (lambda (string1 string2 :optional start1 end1 start2 end2) n))
     
    603608    (string-contains-ci (lambda (string pattern :optional s-start s-end p-start p-end) obj))
    604609    (string-fill! (lambda (string char :optional start end) undefined))
    605     (string-copy! (lambda (to tstart from :optional fstart fend)))
    606     (string-copy (lambda (s :optional start end) str))
    607     (substring/shared (lambda (s start :optional end) str))
    608     (string-reverse (lambda (s :optional start end) str))
    609     (string-reverse! (lambda (s :optional start end)))
     610    (string-copy! (lambda (to tstart from :optional fstart fend) undefined))
     611    (string-copy (lambda (str :optional start end) str))
     612    (substring/shared (lambda (str start :optional end) str))
     613    (string-reverse (lambda (str :optional start end) str))
     614    (string-reverse! (lambda (str :optional start end) undefined))
    610615    (reverse-list->string (lambda (char-list) str))
    611     (string->list (lambda (s :optional start end) list))
     616    (string->list (lambda (str :optional start end) list))
    612617    (string-concatenate (lambda (string-list) str))
    613618    (string-concatenate/shared (lambda (string-list) str))
    614     (string-append/shared (lambda (s |...|) str))
     619    (string-append/shared (lambda (str |...|) str))
    615620    (string-concatenate-reverse (lambda (string-list :optional final-string end) str))
    616621    (string-concatenate-reverse/shared (lambda (string-list :optional final-string end) str))
    617     (xsubstring (lambda (s from :optional to start end) str))
    618     (string-xcopy! (lambda (target tstart s from :optional to start end)))
    619     (string-null? (lambda (s) bool))
     622    (xsubstring (lambda (str from :optional to start end) str))
     623    (string-xcopy! (lambda (target tstart str from :optional to start end) undefined))
     624    (string-null? (lambda (str) bool))
    620625    (string-join (lambda (string-list :optional delim grammar) str))
    621626    (string-tokenize (lambda (string :optional token-chars start end) str))
    622     (string-replace (lambda (s1 s2 start1 end1 :optional start2 end2) str))
    623     (string-kmp-partial-search (lambda (pat rv s i :optional c= p-start s-start s-end) n))
    624     (make-kmp-restart-vector (lambda (s :optional c= start end) vec))
     627    (string-replace (lambda (str1 str2 start1 end1 :optional start2 end2) str))
     628    (string-kmp-partial-search (lambda (pat rv str i :optional c= p-start s-start s-end) n))
     629    (make-kmp-restart-vector (lambda (str :optional c= start end) vec))
    625630    (kmp-step (lambda (pat rv c i c= p-start) n))
    626631    )
     
    639644    (char-set-unfold (lambda (proc proc proc obj :optional obj) cset))
    640645    (char-set-unfold! (lambda (proc proc proc obj obj) cset))
    641     (char-set-for-each (lambda (proc cset)))
     646    (char-set-for-each (lambda (proc cset) undefined))
    642647    (char-set-map (lambda (proc cset) cset))
    643648    (char-set-copy (lambda (cset) cset))
     
    981986    (stream-unfoldn (lambda (generator-proc seed n)))
    982987    (stream-map (lambda (proc stream |...|)))
    983     (stream-for-each (lambda (proc stream |...|)))
     988    (stream-for-each (lambda (proc stream |...|) undefined))
    984989    (stream-filter (lambda (pred stream)))
    985990    )
     
    13021307     (butlast (lambda (list) list) "drops the last element of list")
    13031308     (call-with-input-string (lambda (string proc)))
    1304      (call-with-output-string (lambda (proc)))
     1309     (call-with-output-string (lambda (proc) str))
    13051310     (chop (lambda (list k) list))
    13061311     (complement (lambda (f) f2))
     
    15371542     (file-mkstemp (lambda (template-filename)))
    15381543     (file-modification-time (lambda (filename) real))
    1539      (file-open (lambda (filename (flags open-mode open/binary open/excl open/fsync open/noctty open/nonblock open/rdonly open/rdwr open/read open/sync open/text) :optional mode) fd))
     1544     (file-open (lambda (filename (flags open-mode open/binary open/excl open/fsync open/noctty open/nonblock open/rdonly open/rdwr open/read open/sync open/text) :optional mode) fileno))
    15401545     (file-owner (lambda (filename)))
    15411546     (file-permissions (lambda (filename) int))
     
    16571662     (time->string (lambda (vector)))
    16581663     (unmap-file-from-memory (lambda (mmap :optional len)))
    1659      (unsetenv (lambda (name)))
    1660      (user-information (lambda (user-name-or-n)))
     1664     (unsetenv (lambda (name) undefined))
     1665     (user-information (lambda ((or integer (string complete-user-name))) list))
    16611666     (utc-time->seconds (lambda (vector)))
    16621667     (with-input-from-pipe (lambda (cmdline-string thunk :optional mode)))
     
    16661671     (glob->regexp (lambda (pattern)))
    16671672     (glob? (lambda (obj)))
    1668      (grep (lambda (pattern list)))
     1673     (grep (lambda (pattern list) list))
    16691674     (regexp (lambda (pattern ignore-case? ignore-space? utf-8?)))
    1670      (regexp-escape (lambda (string)))
    1671      (regexp? (lambda (obj)))
     1675     (regexp-escape (lambda (str) str))
     1676     (regexp? (lambda (obj) bool))
    16721677     (string-match (lambda (pattern str :optional start)))
    16731678     (string-match-positions (lambda (pattern str :optional start)))
     
    16851690     (tcp-buffer-size (lambda (:optional new-size)))
    16861691     (tcp-close (lambda (listener)))
    1687      (tcp-connect (lambda (host-string :optioanl tcp-port-n)))
     1692     (tcp-connect (lambda ((string complete-host-name) :optional (string complete-port-name))))
    16881693     (tcp-listen (lambda (tcp-port-n :optional backlog-n host-string)))
    16891694     (tcp-listener-fileno (lambda (listener)))
     
    16971702     (decompose-pathname (lambda (pathname)))
    16981703     (delete-file* (lambda (filename)))
    1699      (for-each-argv-line (lambda (proc)))
    1700      (for-each-line (lambda (proc :optional input-port)))
     1704     (for-each-argv-line (lambda (proc) undefined))
     1705     (for-each-line (lambda (proc :optional input-port) undefined))
    17011706     (make-absolute-pathname (lambda (dir filename :optional ext-str)))
    17021707     (make-pathname (lambda (dir filename :optional ext-str)))
     
    17091714     (pathname-strip-directory (lambda (pathname)))
    17101715     (pathname-strip-extension (lambda (pathname)))
    1711      (port-for-each (lambda (read-fn thunk)))
     1716     (port-for-each (lambda (read-fn thunk) undefined))
    17121717     (port-map (lambda (read-fn thunk)))
    17131718     (read-all (lambda (:optional file-or-port)))
     
    17161721     (unshift! (lambda (obj pair)))
    17171722     )
    1718     ))
    1719 
    1720 ;; by default chicken has a single top-level namespace, so we want to
    1721 ;; handle recursive imports
    1722 (defvar *scheme-chicken-deps*
    1723   '((lolevel extras)
    1724     (posix regex extras utils)
    1725     (srfi-13 srfi-14)
    1726     (tcp extras)
    1727     (ajax md5 url srfi-1 spiffy)
    1728     (aquaterm srfi-4 srfi-13 lolevel regex)
    1729     (args srfi-37)
    1730     (array-lib srfi-1 srfi-4 lolevel miscmacros)
    1731     (awk regex)
    1732     (bloom-filter
    1733      srfi-1 utils lolevel
    1734      iset message-digest hash-utils lookup-table mathh-int
    1735      misc-extn-control misc-extn-numeric misc-extn-record)
    1736     (binary-tree srfi-1 misc-extn-record)
    1737     (box lolevel)
    1738     (cgi-util extras input-parse)
    1739     (charplot array-lib array-lib-hof)
    1740     (charconv regex posix)
    1741     (content-type regex format-modular)
    17421723    ))
    17431724
     
    18721853     (port-position (lambda (port) n))
    18731854     (port? (lambda (obj) bool))
    1874      (print (lambda (obj |...|)))
    1875      (print* (lambda (obj |...|)))
     1855     (print (lambda (obj |...|) undefined))
     1856     (print* (lambda (obj |...|) undefined))
    18761857     (print-backtrace (lambda (:optional n) undefined))
    18771858     (print-call-chain (lambda (:optional n) undefined))
     
    19161897     (undefine-macro! (lambda (sym) undefined))
    19171898     (unregister-feature! (lambda (sym) undefined))
    1918      (use (special chicken-available-modules)
     1899     (use (special symbol chicken-available-modules)
    19191900          "import extensions into top-level namespace")
    19201901     (vector-copy! (lambda (from-vector to-vector :optional start) undefined))
     
    22482229     (fold-right (lambda (proc init list)))
    22492230     (fold-right$ (lambda (proc :optional init)))
    2250      (for-each$ (lambda (proc) proc))
     2231     (for-each$ (lambda (proc) (lambda (ls) undefined)))
    22512232     (foreign-pointer-attribute-get (lambda (ptr attr)))
    22522233     (foreign-pointer-attribute-set (lambda (ptr attr val)))
     
    23922373     (port-fold (lambda (proc init port)))
    23932374     (port-fold-right (lambda (proc init port)))
    2394      (port-for-each (lambda (proc read-proc)))
     2375     (port-for-each (lambda (proc read-proc) undefined))
    23952376     (port-map (lambda (proc read-proc)))
    23962377     (port-name (lambda (port) name))
     
    26762657     (update-direct-method! (lambda ()))
    26772658     (update-direct-subclass! (lambda ()))
    2678      (use (special gauche-available-modules))
     2659     (use (special symbol gauche-available-modules))
    26792660     (use-version (syntax))
    26802661     (values-ref (syntax))
     
    28142795  (let ((orig (point)))
    28152796    (save-excursion
    2816       (beginning-of-defun)
     2797      (goto-char (point-min))
    28172798      (let ((parses (parse-partial-sexp (point) orig)))
    28182799        (nth 3 parses)))))
     
    32193200    ((use require-extension)
    32203201     (append-map #'scheme-module-exports (cdr sexp)))
     3202    ((autoload)
     3203     (mapcar #'(lambda (x) (cons (if (consp x) (car x) x) '((lambda obj))))
     3204             (cddr sexp)))
     3205    ((load)
     3206     (and (file-exists-p (cadr sexp))
     3207          (with-find-file (cadr sexp)
     3208            (current-scheme-globals))))
    32213209    ((library module)
    32223210     (append-map #'extract-import-module-imports
     
    32273215(defun module-symbol-p (sym)
    32283216  (memq sym '(use require require-extension begin cond-expand
    3229               module library define-module)))
     3217              module library define-module autoload load)))
    32303218
    32313219(defun skip-shebang ()
     
    33783366        ((chicken)
    33793367         (let ((predefined (assq mod *scheme-chicken-modules*)))
    3380           (if predefined
    3381               (cdr predefined)
    3382             (let ((path (concat "/usr/local/lib/chicken/1/"
    3383                                 (symbol-name mod)
    3384                                 ".exports")))
    3385               (if (not (file-exists-p path))
    3386                   '()
    3387                 (with-find-file path
    3388                   (let ((vars '()))
    3389                     (condition-case nil
    3390                         (while (not (eobp))
    3391                           (forward-sexp)
    3392                           (let ((sym (nth-sexp-at-point 0)))
    3393                             (if sym (push (list sym) vars))))
    3394                       (error (goto-char (point-max))))
    3395                     vars)))))))
     3368           (if predefined
     3369               (cdr predefined)
     3370             (mapcar
     3371              #'(lambda (x) (cons x '((lambda obj))))
     3372              (or (mapcar #'intern
     3373                          (file->lines (concat "/usr/local/lib/chicken/3/"
     3374                                               (symbol-name mod)
     3375                                               ".exports")))
     3376                  (let ((setup-info (concat "/usr/local/lib/chicken/3/"
     3377                                            (symbol-name mod)
     3378                                            ".setup-info")))
     3379                    (and (file-exists-p setup-info)
     3380                         (with-find-file setup-info
     3381                           (let* ((alist (nth-sexp-at-point 0))
     3382                                  (cell (assq 'exports alist)))
     3383                             (cdr cell))))))))))
    33963384        ((gauche)
    33973385         (let ((path (find-file-in-path
     
    34873475  (let ((i 1)
    34883476        (type nil))
    3489     (while (and (consp spec) (< i pos))
     3477    (while (and (consp spec) (<= i pos))
    34903478      (cond
    3491         ((eq :optional (car spec))
    3492          (if (and (= i (- pos 1)) (consp (cdr spec)))
    3493              (setq type (cadr spec)))
    3494          (setq i pos))
    3495         ((and (consp (cdr spec)) (eq '|...| (cadr spec)))
    3496          (setq type (car spec))
    3497          (setq spec nil)))
     3479       ((eq :optional (car spec))
     3480        (if (and (= i pos) (consp (cdr spec)))
     3481            (setq type (cadr spec)))
     3482        (setq i (+ pos 1)))
     3483       ((= i pos)
     3484        (setq type (car spec))
     3485        (setq spec nil))
     3486       ((and (consp (cdr spec)) (eq '|...| (cadr spec)))
     3487        (setq type (car spec))
     3488        (setq spec nil)))
    34983489      (setq spec (cdr spec))
    34993490      (incf i))
    3500     (if (and (not type) (= i pos))
    3501         (setq type (if (consp spec) (car spec) spec)))
    35023491    (if type
    35033492        (setq type (scheme-translate-type type)))
     
    35503539        (with-output-to-temp-buffer "*Completions*"
    35513540          (display-completion-list
    3552            (sort (all-completions str (append strs coll) pred) 'string-lessp)))
     3541           (sort
     3542            (all-completions str (append strs coll) pred)
     3543            'string-lessp)))
    35533544        (while (not done)
    35543545          (let ((event
     
    36043595                         env))))
    36053596
    3606 ;; checking return values
     3597;; checking return values:
     3598;;   a should be capable of returning instances of b
    36073599(defun scheme-type-match-p (a b)
    36083600  (let ((a1 (scheme-translate-type a))
    36093601        (b1 (scheme-translate-type b)))
    3610     (and (not (eq a1 'undefined))
    3611          (or (eq a1 b1)
    3612              (eq a1 'object)
    3613              (case b1
    3614                ((object) t)
    3615                ((number) (memq a1 '(complex real rational integer)))
    3616                ((complex) (memq a1 '(real rational integer)))
    3617                ((real) (memq a1 '(rational integer)))
    3618                ((rational) (memq a1 '(integer)))
    3619                ((port) (memq a1 '(input-port output-port)))
    3620                ((string) (memq a1 '(filename directory)))
    3621                (t nil))))))
     3602    (and (not (eq a1 'undefined))   ; check a *does* return something
     3603         (or (eq a1 b1)             ; and they're the same
     3604             (eq a1 'object)        ; ... or a can return anything
     3605             (eq b1 'object)        ; ... or b can receive anything
     3606             (if (symbolp a1)
     3607                 (if (symbolp b1)
     3608                     (case a1           ; ... or the types overlap
     3609                       ((number complex real rational integer)
     3610                        (memq b1 '(number complex real rational integer)))
     3611                       ((port input-port output-port)
     3612                        (memq b1 '(port input-port output-port)))
     3613                       ((pair list)
     3614                        (memq b1 '(pair list)))
     3615                       ((non-procedure)
     3616                        (not (eq 'procedure b1))))
     3617                   (and
     3618                    (consp b1)
     3619                    (if (eq 'or (car b1))
     3620                        ;; type unions
     3621                        (find-if
     3622                         #'(lambda (x)
     3623                             (scheme-type-match-p
     3624                              a1 (scheme-translate-type x)))
     3625                         (cdr b1))
     3626                      (let ((b2 (scheme-translate-special-type b1)))
     3627                        (and (not (equal b1 b2))
     3628                             (scheme-type-match-p a1 b2))))))
     3629               (and (consp a1)
     3630                    ;; type unions
     3631                    (if (eq 'or (car a1))
     3632                        (find-if
     3633                         #'(lambda (x)
     3634                             (scheme-type-match-p (scheme-translate-type x) b1))
     3635                         (cdr a1))
     3636                      ;; other special types
     3637                      (let ((a2 (scheme-translate-special-type a1))
     3638                            (b2 (scheme-translate-special-type b1)))
     3639                        (and (or (not (equal a1 a2)) (not (equal b1 b2)))
     3640                             (scheme-type-match-p a2 b2))))
     3641                    ))))))
     3642
     3643(defun scheme-translate-special-type (x)
     3644  (if (not (consp x))
     3645      x
     3646    (case (car x)
     3647      ((list string) (car x))
     3648      ((set special) (cadr x))
     3649      ((flags) 'integer)
     3650      (t x))))
    36223651
    36233652(defun nth* (n ls)
     
    36263655          ls (cdr ls)))
    36273656  (and (consp ls) (car ls)))
     3657
     3658(defun file->lines (file)
     3659  (and (file-readable-p file)
     3660       (with-find-file file
     3661         (goto-char (point-min))
     3662         (let ((res '()))
     3663           (while (not (eobp))
     3664             (let ((start (point)))
     3665               (forward-line)
     3666               (push (buffer-substring-no-properties start (- (point) 1))
     3667                     res)))
     3668           (reverse res)))))
     3669
     3670(defun passwd-file-names (file &optional pat)
     3671  (delete
     3672   nil
     3673   (mapcar
     3674    #'(lambda (line)
     3675        (and (not (string-match "^[     ]*#" line))
     3676             (or (not pat) (string-match pat line))
     3677             (string-match "^\\([^:]*\\):" line)
     3678             (match-string 1 line)))
     3679    (file->lines file))))
     3680
     3681(defun host-file-names (file)
     3682  (append-map
     3683   #'(lambda (line)
     3684       (let ((i (string-match "#" line)))
     3685         (if i (setq line (substring line 0 i))))
     3686       (cdr (split-string line)))
     3687   (file->lines file)))
     3688
     3689(defun ssh-known-hosts-file-names (file)
     3690  (append-map
     3691   #'(lambda (line)
     3692       (split-string (car (split-string line)) ","))
     3693   (file->lines file)))
     3694
     3695(defun ssh-config-file-names (file)
     3696  (append-map
     3697   #'(lambda (line)
     3698       (and (string-match "^ *Host" line)
     3699            (cdr (split-string line))))
     3700   (file->lines file)))
     3701
     3702(defun complete-user-name (sym)
     3703  (if (string-match "apple" (emacs-version))
     3704      (append (passwd-file-names "/etc/passwd" "^[^_].*")
     3705              (delete "Shared" (directory-files "/Users" nil "^[^.].*")))
     3706    (passwd-file-names "/etc/passwd")))
     3707
     3708(defun complete-host-name (sym)
     3709  (append (host-file-names "/etc/hosts")
     3710          (ssh-known-hosts-file-names "~/.ssh/known_hosts")
     3711          (ssh-config-file-names "~/.ssh/config")))
     3712
     3713;; my /etc/services is 14k lines, so we try to optimize this
     3714(defun complete-port-name (sym)
     3715  (and (file-readable-p "/etc/services")
     3716       (with-find-file "/etc/services"
     3717         (goto-char (point-min))
     3718         (let ((rx (concat "^\\(" (regexp-quote (if (symbolp sym)
     3719                                                    (symbol-name sym)
     3720                                                  sym))
     3721                           "[^  ]*\\)"))
     3722               (res '()))
     3723           (while (not (eobp))
     3724             (if (not (re-search-forward rx nil t))
     3725                 (goto-char (point-max))
     3726               (let ((str (match-string-no-properties 1)))
     3727                 (if (not (equal str (car res)))
     3728                     (push str res)))
     3729               (forward-char 1)))
     3730           res))))
     3731
     3732(defun complete-file-name (sym)
     3733  (let ((file (file-name-nondirectory sym))
     3734        (dir (or (file-name-directory sym) ".")))
     3735    (file-name-all-completions file dir)))
     3736
     3737(defun complete-directory-name (sym)
     3738  (let ((file (file-name-nondirectory sym))
     3739        (dir (or (file-name-directory sym) ".")))
     3740    (remove-if-not
     3741     #'(lambda (x) (file-directory-p (concat dir "/" x)))
     3742     (file-name-all-completions file dir))))
     3743
     3744(defun scheme-string-completer (type)
     3745  (case type
     3746    ((filename)
     3747     '(complete-file-name file-name-nondirectory))
     3748    ((directory)
     3749     '(complete-directory-name file-name-nondirectory))
     3750    (t
     3751     (cond
     3752      ((and (consp type) (eq 'string (car type)))
     3753       (cadr type))
     3754      ((and (consp type) (eq 'or (car type)))
     3755       (car (delete nil (mapcar #'scheme-string-completer (cdr type)))))))))
     3756
     3757;; (defun remove-duplicate-strings/tail (ls)
     3758;;   (while (consp ls)
     3759;;     (delete (car ls) (cdr ls))
     3760;;     (setq ls (cdr ls))))
     3761
     3762;; (defun remove-duplicate-strings (ls)
     3763;;   (remove-duplicate-strings/tail ls)
     3764;;   ls)
     3765
     3766(defun scheme-apply-string-completer (cmpl sym)
     3767  (let ((func (if (consp cmpl) (car cmpl) cmpl))
     3768        (trans (and (consp cmpl) (cadr cmpl))))
     3769    (funcall func (if trans (funcall trans sym) sym))))
    36283770
    36293771(defun scheme-smart-complete (&optional arg)
     
    36533795     ;; for now just do file-name completion in strings
    36543796     (in-str-p
    3655       (let ((file (file-name-nondirectory sym))
    3656             (dir (or (file-name-directory sym) ".")))
    3657         (do-completion file (file-name-all-completions file dir))))
     3797      (let* ((param-type
     3798              (and (consp inner-type)
     3799                   (eq 'lambda (car inner-type))
     3800                   (scheme-lookup-type (cadr inner-type) inner-pos)))
     3801             (completer (or (scheme-string-completer param-type)
     3802                            '(complete-file-name file-name-nondirectory))))
     3803        (do-completion
     3804         (if (consp completer) (funcall (cadr completer) sym) sym)
     3805         (scheme-apply-string-completer completer sym))))
    36583806     ;; outer special
    36593807     ((and (consp outer-type)
    36603808           (eq 'special (car outer-type))
    3661            (caddr outer-type))
    3662       (do-completion sym (funcall (caddr outer-type) sym)))
     3809           (cadddr outer-type))
     3810      (do-completion sym (funcall (cadddr outer-type) sym)))
    36633811     ;; inner special
    36643812     ((and (consp inner-type)
    36653813           (eq 'special (car inner-type))
    3666            (cadr inner-type))
    3667       (do-completion sym (funcall (cadr inner-type) sym)))
     3814           (caddr inner-type))
     3815      (do-completion sym (funcall (caddr inner-type) sym)))
    36683816     ;; completing inner procedure, complete procedures with a
    36693817     ;; matching return type
     
    36723820           (not (zerop outer-pos))
    36733821           (nth* outer-pos (cadr outer-type))
    3674            (zerop inner-pos))
    3675       (let ((ret-type (scheme-lookup-type (cadr outer-type) outer-pos)))
     3822           (or (zerop inner-pos)
     3823               (and (>= 1 inner-pos)
     3824                    (consp inner-type)
     3825                    (eq 'lambda (car inner-type))
     3826                    (let ((param-type
     3827                           (scheme-lookup-type (cadr inner-type) inner-pos)))
     3828                      (and (consp param-type)
     3829                           (eq 'lambda (car param-type))
     3830                           (eq (caddr inner-type) (caddr param-type)))))))
     3831      (let ((want-type (scheme-lookup-type (cadr outer-type) outer-pos)))
    36763832        (do-completion
    36773833         sym
     
    36853841                             (and (eq 'lambda (car type))
    36863842                                  (scheme-type-match-p (caddr type)
    3687                                                        ret-type)))))))
     3843                                                       want-type)))))))
    36883844          env))))
    36893845     ;; completing a normal parameter
     
    36933849           (eq 'lambda (car inner-type)))
    36943850      (let* ((param-type (scheme-lookup-type (cadr inner-type) inner-pos))
    3695              (set-or-flags-p (and (consp param-type)
    3696                                   (memq (car param-type) '(set flags))))
    3697              (base-type (if set-or-flags-p
    3698                             (scheme-translate-type (cadr param-type))
     3851             (set-or-flags
     3852              (or (and (consp param-type)
     3853                       (case (car param-type)
     3854                         ((set) (cddr param-type))
     3855                         ((flags) (cdr param-type))))
     3856                  ;; handle nested arithmetic functions inside a flags
     3857                  ;; parameter
     3858                  (and (not (zerop outer-pos))
     3859                       (consp outer-type)
     3860                       (eq 'lambda (car outer-type))
     3861                       (let ((outer-param-type
     3862                              (scheme-lookup-type (cadr outer-type)
     3863                                                  outer-pos)))
     3864                         (and (consp outer-param-type)
     3865                              (eq 'flags (car outer-param-type))
     3866                              (memq (scheme-translate-type param-type)
     3867                                    '(number complex real rational integer))
     3868                              (memq (scheme-translate-type (caddr inner-type))
     3869                                    '(number complex real rational integer))
     3870                              (cdr outer-param-type))))))
     3871             (base-type (if set-or-flags
     3872                            (if (and (consp param-type)
     3873                                     (eq 'set (car param-type)))
     3874                                (scheme-translate-type (cadr param-type))
     3875                              'integer)
    36993876                            param-type))
    37003877             (base-completions
    37013878              (scheme-env-filter
    37023879               #'(lambda (x)
    3703                    (scheme-type-match-p base-type (cadr x)))
     3880                   (scheme-type-match-p (cadr x) base-type))
    37043881               env))
    37053882             (str-completions
    3706               (case base-type
    3707                 ((filename directory)
    3708                  (let* ((file (file-name-nondirectory sym))
    3709                         (dir (or (file-name-directory sym) "."))
    3710                         (ls (file-name-all-completions file dir)))
    3711                    (if (eq base-type 'directory)
    3712                        (remove-if-not
    3713                         #'(lambda (x)
    3714                             (file-directory-p (concat dir "/" x)))
    3715                         ls)
    3716                      ls)))
    3717                 (t '()))))
     3883              (let ((completer (scheme-string-completer base-type)))
     3884                (and
     3885                 completer
     3886                 (scheme-apply-string-completer completer sym)))))
    37183887        (do-completion
    37193888         sym
    3720          (append
    3721           (if set-or-flags-p
    3722               (cddr param-type)
    3723             '())
    3724           base-completions)
     3889         (append set-or-flags base-completions)
    37253890         str-completions)))
    37263891     ;; completing a function
     
    37673932      x
    37683933    (case (car x)
    3769       ((flags set) (or (cadr x) (car x)))
     3934      ((string list) (car x))
     3935      ((set) (or (cadr x) (car x)))
     3936      ((flags) 'integer)
    37703937      ((lambda) 'procedure)
    37713938      ((syntax) 'syntax)
     
    38133980
    38143981(provide 'scheme-complete)
     3982
  • chicken/branches/release/tests/r4rstest.out

    r7276 r7931  
    22SECTION(3 4)
    33 #<procedure (boolean? x75)>
    4     #<procedure (char? x648)>
     4    #<procedure (char? x653)>
    55       #<procedure (null? x119)>
    66          #<procedure (##sys#number? x409)>
    77             #<procedure (pair? x82)>
    8                 #<procedure (procedure? x727)>
     8                #<procedure (procedure? x732)>
    99                   #<procedure (string? x158)>
    1010                      #<procedure (symbol? x504)>
    11                          #<procedure (vector? x577)>
     11                         #<procedure (vector? x582)>
    1212(#t #f #f #f #f #f #f #f #f)#t
    1313(#t #f #f #f #f #f #f #f #f)#f
     
    130130(#<procedure (eq? x76 y77)> (a) (a))  ==> #f
    131131(#<procedure (eq? x76 y77)> () ())  ==> #t
    132 (#<procedure (eq? x76 y77)> #<procedure (f_3795 x85)> #<procedure (f_3795 x85)>)  ==> #t
     132(#<procedure (eq? x76 y77)> #<procedure (f_3801 x85)> #<procedure (f_3801 x85)>)  ==> #t
    133133(#<procedure (eq? x76 y77)> (a) (a))  ==> #t
    134134(#<procedure (eq? x76 y77)> #() #())  ==> #t
     
    153153(#<procedure (cons x83 y84)> a 3)  ==> (a . 3)
    154154(#<procedure (cons x83 y84)> (a b) c)  ==> ((a b) . c)
    155 (#<procedure (f_3795 x85)> (a b c))  ==> a
    156 (#<procedure (f_3795 x85)> ((a) b c d))  ==> (a)
    157 (#<procedure (f_3795 x85)> (1 . 2))  ==> 1
    158 (#<procedure (f_3798 x86)> ((a) b c d))  ==> (b c d)
    159 (#<procedure (f_3798 x86)> (1 . 2))  ==> 2
     155(#<procedure (f_3801 x85)> (a b c))  ==> a
     156(#<procedure (f_3801 x85)> ((a) b c d))  ==> (a)
     157(#<procedure (f_3801 x85)> (1 . 2))  ==> 1
     158(#<procedure (f_3804 x86)> ((a) b c d))  ==> (b c d)
     159(#<procedure (f_3804 x86)> (1 . 2))  ==> 2
    160160(#<procedure (list . lst120)> a 7 c)  ==> (a 7 c)
    161161(#<procedure (list . lst120)>)  ==> ()
     
    315315(string->number #t)  ==> #t
    316316SECTION(6 6)
    317 (#<procedure (char? x648)> #\a)  ==> #t
    318 (#<procedure (char? x648)> #\()  ==> #t
    319 (#<procedure (char? x648)> #\space)  ==> #t
    320 (#<procedure (char? x648)> #\newline)  ==> #t
    321 (#<procedure (char=? c1653 c2654)> #\A #\B)  ==> #f
    322 (#<procedure (char=? c1653 c2654)> #\a #\b)  ==> #f
    323 (#<procedure (char=? c1653 c2654)> #\9 #\0)  ==> #f
    324 (#<procedure (char=? c1653 c2654)> #\A #\A)  ==> #t
    325 (#<procedure (char<? c1661 c2662)> #\A #\B)  ==> #t
    326 (#<procedure (char<? c1661 c2662)> #\a #\b)  ==> #t
    327 (#<procedure (char<? c1661 c2662)> #\9 #\0)  ==> #f
    328 (#<procedure (char<? c1661 c2662)> #\A #\A)  ==> #f
    329 (#<procedure (char>? c1657 c2658)> #\A #\B)  ==> #f
    330 (#<procedure (char>? c1657 c2658)> #\a #\b)  ==> #f
    331 (#<procedure (char>? c1657 c2658)> #\9 #\0)  ==> #t
    332 (#<procedure (char>? c1657 c2658)> #\A #\A)  ==> #f
    333 (#<procedure (char<=? c1669 c2670)> #\A #\B)  ==> #t
    334 (#<procedure (char<=? c1669 c2670)> #\a #\b)  ==> #t
    335 (#<procedure (char<=? c1669 c2670)> #\9 #\0)  ==> #f
    336 (#<procedure (char<=? c1669 c2670)> #\A #\A)  ==> #t
    337 (#<procedure (char>=? c1665 c2666)> #\A #\B)  ==> #f
    338 (#<procedure (char>=? c1665 c2666)> #\a #\b)  ==> #f
    339 (#<procedure (char>=? c1665 c2666)> #\9 #\0)  ==> #t
    340 (#<procedure (char>=? c1665 c2666)> #\A #\A)  ==> #t
    341 (#<procedure (char-ci=? x678 y679)> #\A #\B)  ==> #f
    342 (#<procedure (char-ci=? x678 y679)> #\a #\B)  ==> #f
    343 (#<procedure (char-ci=? x678 y679)> #\A #\b)  ==> #f
    344 (#<procedure (char-ci=? x678 y679)> #\a #\b)  ==> #f
    345 (#<procedure (char-ci=? x678 y679)> #\9 #\0)  ==> #f
    346 (#<procedure (char-ci=? x678 y679)> #\A #\A)  ==> #t
    347 (#<procedure (char-ci=? x678 y679)> #\A #\a)  ==> #t
    348 (#<procedure (char-ci<? x682 y683)> #\A #\B)  ==> #t
    349 (#<procedure (char-ci<? x682 y683)> #\a #\B)  ==> #t
    350 (#<procedure (char-ci<? x682 y683)> #\A #\b)  ==> #t
    351 (#<procedure (char-ci<? x682 y683)> #\a #\b)  ==> #t
    352 (#<procedure (char-ci<? x682 y683)> #\9 #\0)  ==> #f
    353 (#<procedure (char-ci<? x682 y683)> #\A #\A)  ==> #f
    354 (#<procedure (char-ci<? x682 y683)> #\A #\a)  ==> #f
    355 (#<procedure (char-ci>? x680 y681)> #\A #\B)  ==> #f
    356 (#<procedure (char-ci>? x680 y681)> #\a #\B)  ==> #f
    357 (#<procedure (char-ci>? x680 y681)> #\A #\b)  ==> #f
    358 (#<procedure (char-ci>? x680 y681)> #\a #\b)  ==> #f
    359 (#<procedure (char-ci>? x680 y681)> #\9 #\0)  ==> #t
    360 (#<procedure (char-ci>? x680 y681)> #\A #\A)  ==> #f
    361 (#<procedure (char-ci>? x680 y681)> #\A #\a)  ==> #f
    362 (#<procedure (char-ci<=? x686 y687)> #\A #\B)  ==> #t
    363 (#<procedure (char-ci<=? x686 y687)> #\a #\B)  ==> #t
    364 (#<procedure (char-ci<=? x686 y687)> #\A #\b)  ==> #t
    365 (#<procedure (char-ci<=? x686 y687)> #\a #\b)  ==> #t
    366 (#<procedure (char-ci<=? x686 y687)> #\9 #\0)  ==> #f
    367 (#<procedure (char-ci<=? x686 y687)> #\A #\A)  ==> #t
    368 (#<procedure (char-ci<=? x686 y687)> #\A #\a)  ==> #t
    369 (#<procedure (char-ci>=? x684 y685)> #\A #\B)  ==> #f
    370 (#<procedure (char-ci>=? x684 y685)> #\a #\B)  ==> #f
    371 (#<procedure (char-ci>=? x684 y685)> #\A #\b)  ==> #f
    372 (#<procedure (char-ci>=? x684 y685)> #\a #\b)  ==> #f
    373 (#<procedure (char-ci>=? x684 y685)> #\9 #\0)  ==> #t
    374 (#<procedure (char-ci>=? x684 y685)> #\A #\A)  ==> #t
    375 (#<procedure (char-ci>=? x684 y685)> #\A #\a)  ==> #t
    376 (#<procedure (char-alphabetic? c700)> #\a)  ==> #t
    377 (#<procedure (char-alphabetic? c700)> #\A)  ==> #t
    378 (#<procedure (char-alphabetic? c700)> #\z)  ==> #t
    379 (#<procedure (char-alphabetic? c700)> #\Z)  ==> #t
    380 (#<procedure (char-alphabetic? c700)> #\0)  ==> #f
    381 (#<procedure (char-alphabetic? c700)> #\9)  ==> #f
    382 (#<procedure (char-alphabetic? c700)> #\space)  ==> #f
    383 (#<procedure (char-alphabetic? c700)> #\;)  ==> #f
    384 (#<procedure (char-numeric? c696)> #\a)  ==> #f
    385 (#<procedure (char-numeric? c696)> #\A)  ==> #f
    386 (#<procedure (char-numeric? c696)> #\z)  ==> #f
    387 (#<procedure (char-numeric? c696)> #\Z)  ==> #f
    388 (#<procedure (char-numeric? c696)> #\0)  ==> #t
    389 (#<procedure (char-numeric? c696)> #\9)  ==> #t
    390 (#<procedure (char-numeric? c696)> #\space)  ==> #f
    391 (#<procedure (char-numeric? c696)> #\;)  ==> #f
    392 (#<procedure (char-whitespace? c698)> #\a)  ==> #f
    393 (#<procedure (char-whitespace? c698)> #\A)  ==> #f
    394 (#<procedure (char-whitespace? c698)> #\z)  ==> #f
    395 (#<procedure (char-whitespace? c698)> #\Z)  ==> #f
    396 (#<procedure (char-whitespace? c698)> #\0)  ==> #f
    397 (#<procedure (char-whitespace? c698)> #\9)  ==> #f
    398 (#<procedure (char-whitespace? c698)> #\space)  ==> #t
    399 (#<procedure (char-whitespace? c698)> #\;)  ==> #f
    400 (#<procedure (char-upper-case? c692)> #\0)  ==> #f
    401 (#<procedure (char-upper-case? c692)> #\9)  ==> #f
    402 (#<procedure (char-upper-case? c692)> #\space)  ==> #f
    403 (#<procedure (char-upper-case? c692)> #\;)  ==> #f
    404 (#<procedure (char-lower-case? c694)> #\0)  ==> #f
    405 (#<procedure (char-lower-case? c694)> #\9)  ==> #f
    406 (#<procedure (char-lower-case? c694)> #\space)  ==> #f
    407 (#<procedure (char-lower-case? c694)> #\;)  ==> #f
    408 (#<procedure (integer->char n651)> 46)  ==> #\.
    409 (#<procedure (integer->char n651)> 65)  ==> #\A
    410 (#<procedure (integer->char n651)> 97)  ==> #\a
    411 (#<procedure (char-upcase c673)> #\A)  ==> #\A
    412 (#<procedure (char-upcase c673)> #\a)  ==> #\A
    413 (#<procedure (char-downcase c675)> #\A)  ==> #\a
    414 (#<procedure (char-downcase c675)> #\a)  ==> #\a
     317(#<procedure (char? x653)> #\a)  ==> #t
     318(#<procedure (char? x653)> #\()  ==> #t
     319(#<procedure (char? x653)> #\space)  ==> #t
     320(#<procedure (char? x653)> #\newline)  ==> #t
     321(#<procedure (char=? c1658 c2659)> #\A #\B)  ==> #f
     322(#<procedure (char=? c1658 c2659)> #\a #\b)  ==> #f
     323(#<procedure (char=? c1658 c2659)> #\9 #\0)  ==> #f
     324(#<procedure (char=? c1658 c2659)> #\A #\A)  ==> #t
     325(#<procedure (char<? c1666 c2667)> #\A #\B)  ==> #t
     326(#<procedure (char<? c1666 c2667)> #\a #\b)  ==> #t
     327(#<procedure (char<? c1666 c2667)> #\9 #\0)  ==> #f
     328(#<procedure (char<? c1666 c2667)> #\A #\A)  ==> #f
     329(#<procedure (char>? c1662 c2663)> #\A #\B)  ==> #f
     330(#<procedure (char>? c1662 c2663)> #\a #\b)  ==> #f
     331(#<procedure (char>? c1662 c2663)> #\9 #\0)  ==> #t
     332(#<procedure (char>? c1662 c2663)> #\A #\A)  ==> #f
     333(#<procedure (char<=? c1674 c2675)> #\A #\B)  ==> #t
     334(#<procedure (char<=? c1674 c2675)> #\a #\b)  ==> #t
     335(#<procedure (char<=? c1674 c2675)> #\9 #\0)  ==> #f
     336(#<procedure (char<=? c1674 c2675)> #\A #\A)  ==> #t
     337(#<procedure (char>=? c1670 c2671)> #\A #\B)  ==> #f
     338(#<procedure (char>=? c1670 c2671)> #\a #\b)  ==> #f
     339(#<procedure (char>=? c1670 c2671)> #\9 #\0)  ==> #t
     340(#<procedure (char>=? c1670 c2671)> #\A #\A)  ==> #t
     341(#<procedure (char-ci=? x683 y684)> #\A #\B)  ==> #f
     342(#<procedure (char-ci=? x683 y684)> #\a #\B)  ==> #f
     343(#<procedure (char-ci=? x683 y684)> #\A #\b)  ==> #f
     344(#<procedure (char-ci=? x683 y684)> #\a #\b)  ==> #f
     345(#<procedure (char-ci=? x683 y684)> #\9 #\0)  ==> #f
     346(#<procedure (char-ci=? x683 y684)> #\A #\A)  ==> #t
     347(#<procedure (char-ci=? x683 y684)> #\A #\a)  ==> #t
     348(#<procedure (char-ci<? x687 y688)> #\A #\B)  ==> #t
     349(#<procedure (char-ci<? x687 y688)> #\a #\B)  ==> #t
     350(#<procedure (char-ci<? x687 y688)> #\A #\b)  ==> #t
     351(#<procedure (char-ci<? x687 y688)> #\a #\b)  ==> #t
     352(#<procedure (char-ci<? x687 y688)> #\9 #\0)  ==> #f
     353(#<procedure (char-ci<? x687 y688)> #\A #\A)  ==> #f
     354(#<procedure (char-ci<? x687 y688)> #\A #\a)  ==> #f
     355(#<procedure (char-ci>? x685 y686)> #\A #\B)  ==> #f
     356(#<procedure (char-ci>? x685 y686)> #\a #\B)  ==> #f
     357(#<procedure (char-ci>? x685 y686)> #\A #\b)  ==> #f
     358(#<procedure (char-ci>? x685 y686)> #\a #\b)  ==> #f
     359(#<procedure (char-ci>? x685 y686)> #\9 #\0)  ==> #t
     360(#<procedure (char-ci>? x685 y686)> #\A #\A)  ==> #f
     361(#<procedure (char-ci>? x685 y686)> #\A #\a)  ==> #f
     362(#<procedure (char-ci<=? x691 y692)> #\A #\B)  ==> #t
     363(#<procedure (char-ci<=? x691 y692)> #\a #\B)  ==> #t
     364(#<procedure (char-ci<=? x691 y692)> #\A #\b)  ==> #t
     365(#<procedure (char-ci<=? x691 y692)> #\a #\b)  ==> #t
     366(#<procedure (char-ci<=? x691 y692)> #\9 #\0)  ==> #f
     367(#<procedure (char-ci<=? x691 y692)> #\A #\A)  ==> #t
     368(#<procedure (char-ci<=? x691 y692)> #\A #\a)  ==> #t
     369(#<procedure (char-ci>=? x689 y690)> #\A #\B)  ==> #f
     370(#<procedure (char-ci>=? x689 y690)> #\a #\B)  ==> #f
     371(#<procedure (char-ci>=? x689 y690)> #\A #\b)  ==> #f
     372(#<procedure (char-ci>=? x689 y690)> #\a #\b)  ==> #f
     373(#<procedure (char-ci>=? x689 y690)> #\9 #\0)  ==> #t
     374(#<procedure (char-ci>=? x689 y690)> #\A #\A)  ==> #t
     375(#<procedure (char-ci>=? x689 y690)> #\A #\a)  ==> #t
     376(#<procedure (char-alphabetic? c705)> #\a)  ==> #t
     377(#<procedure (char-alphabetic? c705)> #\A)  ==> #t
     378(#<procedure (char-alphabetic? c705)> #\z)  ==> #t
     379(#<procedure (char-alphabetic? c705)> #\Z)  ==> #t
     380(#<procedure (char-alphabetic? c705)> #\0)  ==> #f
     381(#<procedure (char-alphabetic? c705)> #\9)  ==> #f
     382(#<procedure (char-alphabetic? c705)> #\space)  ==> #f
     383(#<procedure (char-alphabetic? c705)> #\;)  ==> #f
     384(#<procedure (char-numeric? c701)> #\a)  ==> #f
     385(#<procedure (char-numeric? c701)> #\A)  ==> #f
     386(#<procedure (char-numeric? c701)> #\z)  ==> #f
     387(#<procedure (char-numeric? c701)> #\Z)  ==> #f
     388(#<procedure (char-numeric? c701)> #\0)  ==> #t
     389(#<procedure (char-numeric? c701)> #\9)  ==> #t
     390(#<procedure (char-numeric? c701)> #\space)  ==> #f
     391(#<procedure (char-numeric? c701)> #\;)  ==> #f
     392(#<procedure (char-whitespace? c703)> #\a)  ==> #f
     393(#<procedure (char-whitespace? c703)> #\A)  ==> #f
     394(#<procedure (char-whitespace? c703)> #\z)  ==> #f
     395(#<procedure (char-whitespace? c703)> #\Z)  ==> #f
     396(#<procedure (char-whitespace? c703)> #\0)  ==> #f
     397(#<procedure (char-whitespace? c703)> #\9)  ==> #f
     398(#<procedure (char-whitespace? c703)> #\space)  ==> #t
     399(#<procedure (char-whitespace? c703)> #\;)  ==> #f
     400(#<procedure (char-upper-case? c697)> #\0)  ==> #f
     401(#<procedure (char-upper-case? c697)> #\9)  ==> #f
     402(#<procedure (char-upper-case? c697)> #\space)  ==> #f
     403(#<procedure (char-upper-case? c697)> #\;)  ==> #f
     404(#<procedure (char-lower-case? c699)> #\0)  ==> #f
     405(#<procedure (char-lower-case? c699)> #\9)  ==> #f
     406(#<procedure (char-lower-case? c699)> #\space)  ==> #f
     407(#<procedure (char-lower-case? c699)> #\;)  ==> #f
     408(#<procedure (integer->char n656)> 46)  ==> #\.
     409(#<procedure (integer->char n656)> 65)  ==> #\A
     410(#<procedure (integer->char n656)> 97)  ==> #\a
     411(#<procedure (char-upcase c678)> #\A)  ==> #\A
     412(#<procedure (char-upcase c678)> #\a)  ==> #\A
     413(#<procedure (char-downcase c680)> #\A)  ==> #\a
     414(#<procedure (char-downcase c680)> #\a)  ==> #\a
    415415SECTION(6 7)
    416416(#<procedure (string? x158)> "The word \"recursion\\\" has many meanings.")  ==> #t
     
    419419(#<procedure (string . chars333)>)  ==> ""
    420420(#<procedure (string-length s159)> "abc")  ==> 3
    421 (#<procedure (f_4303 s160 i161)> "abc" 0)  ==> #\a
    422 (#<procedure (f_4303 s160 i161)> "abc" 2)  ==> #\c
     421(#<procedure (f_4309 s160 i161)> "abc" 0)  ==> #\a
     422(#<procedure (f_4309 s160 i161)> "abc" 2)  ==> #\c
    423423(#<procedure (string-length s159)> "")  ==> 0
    424424(#<procedure (substring s222 start223 . end224)> "ab" 0 0)  ==> ""
     
    500500(#<procedure (string-ci>=? s1305 s2306)> "A" "a")  ==> #t
    501501SECTION(6 8)
    502 (#<procedure (vector? x577)> #(0 (2 2 2 2) "Anna"))  ==> #t
    503 (#<procedure (vector . xs602)> a b c)  ==> #(a b c)
    504 (#<procedure (vector . xs602)>)  ==> #()
    505 (#<procedure (vector-length v578)> #(0 (2 2 2 2) "Anna"))  ==> 3
    506 (#<procedure (vector-length v578)> #())  ==> 0
    507 (#<procedure (f_6057 v579 i580)> #(1 1 2 3 5 8 13 21) 5)  ==> 8
     502(#<procedure (vector? x582)> #(0 (2 2 2 2) "Anna"))  ==> #t
     503(#<procedure (vector . xs607)> a b c)  ==> #(a b c)
     504(#<procedure (vector . xs607)>)  ==> #()
     505(#<procedure (vector-length v583)> #(0 (2 2 2 2) "Anna"))  ==> 3
     506(#<procedure (vector-length v583)> #())  ==> 0
     507(#<procedure (f_6088 v584 i585)> #(1 1 2 3 5 8 13 21) 5)  ==> 8
    508508(vector-set #(0 ("Sue" "Sue") "Anna"))  ==> #(0 ("Sue" "Sue") "Anna")
    509 (#<procedure (##sys#make-vector size584 . fill585)> 2 hi)  ==> #(hi hi)
    510 (#<procedure (##sys#make-vector size584 . fill585)> 0)  ==> #()
    511 (#<procedure (##sys#make-vector size584 . fill585)> 0 a)  ==> #()
     509(#<procedure (##sys#make-vector size589 . fill590)> 2 hi)  ==> #(hi hi)
     510(#<procedure (##sys#make-vector size589 . fill590)> 0)  ==> #()
     511(#<procedure (##sys#make-vector size589 . fill590)> 0 a)  ==> #()
    512512SECTION(6 9)
    513 (#<procedure (procedure? x727)> #<procedure (f_3795 x85)>)  ==> #t
    514 (#<procedure (procedure? x727)> #<procedure (? x)>)  ==> #t
    515 (#<procedure (procedure? x727)> (lambda (x) (* x x)))  ==> #f
    516 (#<procedure (call-with-current-continuation proc786)> #<procedure (procedure? x727)>)  ==> #t
     513(#<procedure (procedure? x732)> #<procedure (f_3801 x85)>)  ==> #t
     514(#<procedure (procedure? x732)> #<procedure (? x)>)  ==> #t
     515(#<procedure (procedure? x732)> (lambda (x) (* x x)))  ==> #f
     516(#<procedure (call-with-current-continuation proc791)> #<procedure (procedure? x732)>)  ==> #t
    517517(#<procedure C_apply> #<procedure C_plus> (3 4))  ==> 7
    518518(#<procedure C_apply> #<procedure (? a b)> (3 4))  ==> 7
     
    520520(#<procedure C_apply> #<procedure (list . lst120)> ())  ==> ()
    521521(#<procedure (? . args)> 12 75)  ==> 30
    522 (#<procedure (map fn767 lst1768 . lsts769)> #<procedure (f_3807 x91)> ((a b) (d e) (g h)))  ==> (b e h)
    523 (#<procedure (map fn767 lst1768 . lsts769)> #<procedure C_plus> (1 2 3) (4 5 6))  ==> (5 7 9)
    524 (#<procedure (map fn767 lst1768 . lsts769)> #<procedure C_plus> (1 2 3))  ==> (1 2 3)
    525 (#<procedure (map fn767 lst1768 . lsts769)> #<procedure C_times> (1 2 3))  ==> (1 2 3)
    526 (#<procedure (map fn767 lst1768 . lsts769)> #<procedure C_minus> (1 2 3))  ==> (-1 -2 -3)
     522(#<procedure (map fn772 lst1773 . lsts774)> #<procedure (f_3813 x91)> ((a b) (d e) (g h)))  ==> (b e h)
     523(#<procedure (map fn772 lst1773 . lsts774)> #<procedure C_plus> (1 2 3) (4 5 6))  ==> (5 7 9)
     524(#<procedure (map fn772 lst1773 . lsts774)> #<procedure C_plus> (1 2 3))  ==> (1 2 3)
     525(#<procedure (map fn772 lst1773 . lsts774)> #<procedure C_times> (1 2 3))  ==> (1 2 3)
     526(#<procedure (map fn772 lst1773 . lsts774)> #<procedure C_minus> (1 2 3))  ==> (-1 -2 -3)
    527527(for-each #(0 1 4 9 16))  ==> #(0 1 4 9 16)
    528 (#<procedure (call-with-current-continuation proc786)> #<procedure (? exit)>)  ==> -3
     528(#<procedure (call-with-current-continuation proc791)> #<procedure (? exit)>)  ==> -3
    529529(#<procedure (list-length obj)> (1 2 3 4))  ==> 4
    530530(#<procedure (list-length obj)> (a b . c))  ==> #f
    531 (#<procedure (map fn767 lst1768 . lsts769)> #<procedure (f_3807 x91)> ())  ==> ()
     531(#<procedure (map fn772 lst1773 . lsts774)> #<procedure (f_3813 x91)> ())  ==> ()
    532532SECTION(6 10 1)
    533 (#<procedure (input-port? x814)> #<input port "(stdin)">)  ==> #t
    534 (#<procedure (output-port? x815)> #<output port "(stdout)">)  ==> #t
    535 (#<procedure (call-with-input-file name938 p939 . mode940)> "r4rstest.scm" #<procedure (input-port? x814)>)  ==> #t
    536 (#<procedure (input-port? x814)> #<input port "r4rstest.scm">)  ==> #t
     533(#<procedure (input-port? x819)> #<input port "(stdin)">)  ==> #t
     534(#<procedure (output-port? x820)> #<output port "(stdout)">)  ==> #t
     535(#<procedure (call-with-input-file name943 p944 . mode945)> "r4rstest.scm" #<procedure (input-port? x819)>)  ==> #t
     536(#<procedure (input-port? x819)> #<input port "r4rstest.scm">)  ==> #t
    537537SECTION(6 10 2)
    538 (#<procedure (peek-char . g10501051)> #<input port "r4rstest.scm">)  ==> #\;
    539 (#<procedure (read-char . g10371038)> #<input port "r4rstest.scm">)  ==> #\;
    540 (#<procedure (read . g10601061)> #<input port "r4rstest.scm">)  ==> (define cur-section (quote ()))
    541 (#<procedure (peek-char . g10501051)> #<input port "r4rstest.scm">)  ==> #\(
    542 (#<procedure (read . g10601061)> #<input port "r4rstest.scm">)  ==> (define errs (quote ()))
     538(#<procedure (peek-char . g10551056)> #<input port "r4rstest.scm">)  ==> #\;
     539(#<procedure (read-char . g10421043)> #<input port "r4rstest.scm">)  ==> #\;
     540(#<procedure (read . g10651066)> #<input port "r4rstest.scm">)  ==> (define cur-section (quote ()))
     541(#<procedure (peek-char . g10551056)> #<input port "r4rstest.scm">)  ==> #\(
     542(#<procedure (read . g10651066)> #<input port "r4rstest.scm">)  ==> (define errs (quote ()))
    543543SECTION(6 10 3)
    544 (#<procedure (call-with-output-file name946 p947 . mode948)> "tmp1" #<procedure (? test-file)>)  ==> #t
    545 (#<procedure (read . g10601061)> #<input port "tmp1">)  ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
    546 (#<procedure (eof-object? x1029)> #!eof)  ==> #t
    547 (#<procedure (eof-object? x1029)> #!eof)  ==> #t
     544(#<procedure (call-with-output-file name951 p952 . mode953)> "tmp1" #<procedure (? test-file)>)  ==> #t
     545(#<procedure (read . g10651066)> #<input port "tmp1">)  ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
     546(#<procedure (eof-object? x1034)> #!eof)  ==> #t
     547(#<procedure (eof-object? x1034)> #!eof)  ==> #t
    548548(input-port? #t)  ==> #t
    549 (#<procedure (read-char . g10371038)> #<input port "tmp1">)  ==> #\;
    550 (#<procedure (read-char . g10371038)> #<input port "tmp1">)  ==> #\;
    551 (#<procedure (read-char . g10371038)> #<input port "tmp1">)  ==> #\;
    552 (#<procedure (read . g10601061)> #<input port "tmp1">)  ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
    553 (#<procedure (read . g10601061)> #<input port "tmp1">)  ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
    554 (#<procedure (output-port? x815)> #<output port "tmp2">)  ==> #t
    555 (#<procedure (read . g10601061)> #<input port "tmp2">)  ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
    556 (#<procedure (eof-object? x1029)> #!eof)  ==> #t
    557 (#<procedure (eof-object? x1029)> #!eof)  ==> #t
     549(#<procedure (read-char . g10421043)> #<input port "tmp1">)  ==> #\;
     550(#<procedure (read-char . g10421043)> #<input port "tmp1">)  ==> #\;
     551(#<procedure (read-char . g10421043)> #<input port "tmp1">)  ==> #\;
     552(#<procedure (read . g10651066)> #<input port "tmp1">)  ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
     553(#<procedure (read . g10651066)> #<input port "tmp1">)  ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
     554(#<procedure (output-port? x820)> #<output port "tmp2">)  ==> #t
     555(#<procedure (read . g10651066)> #<input port "tmp2">)  ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
     556(#<procedure (eof-object? x1034)> #!eof)  ==> #t
     557(#<procedure (eof-object? x1034)> #!eof)  ==> #t
    558558(input-port? #t)  ==> #t
    559 (#<procedure (read-char . g10371038)> #<input port "tmp2">)  ==> #\;
    560 (#<procedure (read-char . g10371038)> #<input port "tmp2">)  ==> #\;
    561 (#<procedure (read-char . g10371038)> #<input port "tmp2">)  ==> #\;
    562 (#<procedure (read . g10601061)> #<input port "tmp2">)  ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
    563 (#<procedure (read . g10601061)> #<input port "tmp2">)  ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
     559(#<procedure (read-char . g10421043)> #<input port "tmp2">)  ==> #\;
     560(#<procedure (read-char . g10421043)> #<input port "tmp2">)  ==> #\;
     561(#<procedure (read-char . g10421043)> #<input port "tmp2">)  ==> #\;
     562(#<procedure (read . g10651066)> #<input port "tmp2">)  ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
     563(#<procedure (read . g10651066)> #<input port "tmp2">)  ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
    564564
    565565Passed all tests
     
    588588(#<procedure C_expt> 0 1)  ==> 0
    589589(#<procedure (atan n1472 . n2473)> 1 1)  ==> 0.785398163397448
    590 (#<procedure (call-with-output-file name946 p947 . mode948)> "tmp3" #<procedure (? test-file)>)  ==> #t
    591 (#<procedure (read . g10601061)> #<input port "tmp3">)  ==> (define foo (quote (0.25 -3.25)))
    592 (#<procedure (eof-object? x1029)> #!eof)  ==> #t
    593 (#<procedure (eof-object? x1029)> #!eof)  ==> #t
     590(#<procedure (call-with-output-file name951 p952 . mode953)> "tmp3" #<procedure (? test-file)>)  ==> #t
     591(#<procedure (read . g10651066)> #<input port "tmp3">)  ==> (define foo (quote (0.25 -3.25)))
     592(#<procedure (eof-object? x1034)> #!eof)  ==> #t
     593(#<procedure (eof-object? x1034)> #!eof)  ==> #t
    594594(input-port? #t)  ==> #t
    595 (#<procedure (read-char . g10371038)> #<input port "tmp3">)  ==> #\;
    596 (#<procedure (read-char . g10371038)> #<input port "tmp3">)  ==> #\;
    597 (#<procedure (read-char . g10371038)> #<input port "tmp3">)  ==> #\;
    598 (#<procedure (read . g10601061)> #<input port "tmp3">)  ==> (0.25 -3.25)
    599 (#<procedure (read . g10601061)> #<input port "tmp3">)  ==> (define foo (quote (0.25 -3.25)))
     595(#<procedure (read-char . g10421043)> #<input port "tmp3">)  ==> #\;
     596(#<procedure (read-char . g10421043)> #<input port "tmp3">)  ==> #\;
     597(#<procedure (read-char . g10421043)> #<input port "tmp3">)  ==> #\;
     598(#<procedure (read . g10651066)> #<input port "tmp3">)  ==> (0.25 -3.25)
     599(#<procedure (read . g10651066)> #<input port "tmp3">)  ==> (define foo (quote (0.25 -3.25)))
    600600(pentium-fdiv-bug #t)  ==> #t
    601601
     
    758758(#<procedure (##sys#list->string lst0190)> ())  ==> ""
    759759SECTION(6 8)
    760 (#<procedure (vector->list v596)> #(dah dah didah))  ==> (dah dah didah)
    761 (#<procedure (vector->list v596)> #())  ==> ()
    762 (#<procedure (list->vector lst0588)> (dididit dah))  ==> #(dididit dah)
    763 (#<procedure (list->vector lst0588)> ())  ==> #()
     760(#<procedure (vector->list v601)> #(dah dah didah))  ==> (dah dah didah)
     761(#<procedure (vector->list v601)> #())  ==> ()
     762(#<procedure (list->vector lst0593)> (dididit dah))  ==> #(dididit dah)
     763(#<procedure (list->vector lst0593)> ())  ==> #()
    764764SECTION(6 10 4)
    765765(load (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))  ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
  • chicken/branches/release/tests/runtests.sh

    r7276 r7931  
    1515../csi -w -s library-tests.scm
    1616
     17echo "======================================== port tests ..."
     18../csi -w -s port-tests.scm
     19
    1720echo "======================================== fixnum tests ..."
    1821$compile fixnum-tests.scm && ./a.out
     
    2629echo "======================================== r4rstest ..."
    2730../csi -i -s r4rstest.scm >r4rstest.log
    28 diff r4rstest.out r4rstest.log
     31diff -u r4rstest.out r4rstest.log
    2932
    3033echo "======================================== locative stress test ..."
  • chicken/branches/release/version.scm

    r7332 r7931  
    1 (define-constant +build-version+ "2.740")
     1(define-constant +build-version+ "3.0.0")
Note: See TracChangeset for help on using the changeset viewer.