Changeset 2616 in project


Ignore:
Timestamp:
12/10/06 22:44:37 (14 years ago)
Author:
felix winkelmann
Message:

added Ivan's debian dir

Location:
chicken
Files:
19 added
13 edited

Legend:

Unmodified
Added
Removed
  • chicken/ANNOUNCE

    r2615 r2616  
    9999  japi javahack job-worker jni json kanren lalr lazy-ffi levenshtein
    100100  lightning lirc-client locale logging lookup-table loop loopy-loop
    101   macosx magic mailbox make man mapm match-action matcher mathh md5
    102   meroon message-digest mime metakit metaphone misc-extn miscmacros
    103   mistie modds modules mole mpd-client mysql nbstdin ncurses numbers
    104   octave objc object-apply oblist openal opengl openssl orders
    105   packedobjects packrat pcap perfect-hash phoghorn pipeline pmatch
    106   pop3 postgresql ppi procedure-surface prometheus proplist protobj
    107   pty q-lang qt r6rs-libraries readline regex-case remote-launch
    108   remote-mailbox rfc3339 rfc822 rgraph ripemd rlimit rpc rss s11n
    109   sandbox sassy schelog scheme-dissect sdl sedna sfio sha1 sha2 silex
    110   simple-macros slib smtp softscheme spiffy spiffy-utils spread sql
    111   sqlite sqlite3 sqlite3-tinyclos srfi-4-comprehensions srfi-19
    112   srfi-25 srfi-27 srfi-29 srfi-37 srfi-38 srfi-40 srfi-42 srfi-45
    113   srfi-47 srfi-57 srfi-60 srfi-66 srfi-78 srfi-85 srfi-95 ssax stack
    114   stream-base64 stream-cgi stream-ext stream-flash
     101  macosx magic mailbox make man mapm match-action matchable matcher
     102  mathh md5 meroon message-digest mime metakit metaphone misc-extn
     103  miscmacros mistie modds modules mole mpd-client mysql nbstdin
     104  ncurses numbers octave objc object-apply oblist openal opengl
     105  openssl orders packedobjects packrat pcap perfect-hash phoghorn
     106  pipeline pmatch pop3 postgresql ppi procedure-surface prometheus
     107  proplist protobj pty q-lang qt r6rs-libraries readline regex-case
     108  remote-launch remote-mailbox rfc3339 rfc822 rgraph ripemd rlimit rpc
     109  rss s11n sandbox sassy schelog scheme-dissect sdl sedna sfio sha1
     110  sha2 silex simple-macros slib smtp softscheme spiffy spiffy-utils
     111  spread sql sqlite sqlite3 sqlite3-tinyclos srfi-4-comprehensions
     112  srfi-19 srfi-25 srfi-27 srfi-29 srfi-37 srfi-38 srfi-40 srfi-42
     113  srfi-45 srfi-47 srfi-57 srfi-60 srfi-66 srfi-78 srfi-85 srfi-95 ssax
     114  stack stream-base64 stream-cgi stream-ext stream-flash
    115115  stream-flash-tree-map stream-htpasswd stream-httplog stream-ldif
    116116  stream-parser stream-sections stream-wiki structures suspension
    117117  svn-client svn-post-commit-hooks sx sxml-match sxml-tools
    118   sxml-transforms sxpath synch syntax-case tar tabexpand tagged-begin
    119   test-infrastructure tcc tcp-server tcp6 testeez tiger-hash tinyclos
    120   tk udp unix-sockets uri url utf8 uuid-lib uuid-ossp vector-lib
    121   web-scheme wt-tree xlib xmi xml-rpc xosd xxexpr z3
     118  sxml-transforms sxpath synch syntactic-closures syntax-case tar
     119  tabexpand tagged-begin test-infrastructure tcc tcp-server tcp6
     120  testeez tiger-hash tinyclos tk udp unix-sockets uri url utf8
     121  uuid-lib uuid-ossp vector-lib web-scheme wt-tree xlib xmi xml-rpc
     122  xosd xxexpr z3
    122123
    123124
  • chicken/CMakeLists.txt

    r2615 r2616  
    4242#   CMake Useful Variables
    4343#   http://www.cmake.org/Wiki/CMake_Useful_Variables
    44 #   This is really important because the CMake 2.4.4 documentation
     44#   This is really important because the CMake 2.4.5 documentation
    4545#   does not document the variables that CMake uses, and there are
    4646#   quite a few of them.
     
    9595# capabilities somewhere, and backwards compatibility is not assured.
    9696
    97 CMAKE_MINIMUM_REQUIRED(VERSION 2.4.4 FATAL_ERROR)
     97CMAKE_MINIMUM_REQUIRED(VERSION 2.4.5 FATAL_ERROR)
    9898
    9999# Bugs typically show up in the current version of CMake you're using.
     
    105105#
    106106# To handle this, we need to know what version of CMake we're using.
    107 # We already issue a fatal error for any CMake less than 2.4.4.
     107# We already issue a fatal error for any CMake less than 2.4.5.
    108108# So this is sufficient for distinguishing whether we've got
    109 # CMake 2.4.4, or something greater.  We would ideally like to
     109# CMake 2.4.5, or something greater.  We would ideally like to
    110110# make lexical comparisons on CMake version numbers, and be able
    111111# to say things like "if it's greater than version 2.x.y, do this."
    112112# But that's work to implement, and this is easy and sufficient for now.
    113113
    114 SET(IS_CMAKE_244 false)
     114SET(IS_CMAKE_245 false)
    115115IF(CMAKE_MAJOR_VERSION EQUAL 2)
    116116  IF(CMAKE_MINOR_VERSION EQUAL 4)
    117117    IF(CMAKE_PATCH_VERSION EQUAL 4)
    118       SET(IS_CMAKE_244 true)
     118      SET(IS_CMAKE_245 true)
    119119    ENDIF(CMAKE_PATCH_VERSION EQUAL 4)
    120120  ENDIF(CMAKE_MINOR_VERSION EQUAL 4)
     
    358358ENDMACRO(WINDOWS_PATH)
    359359
    360 # In CMake 2.4.4 under the MSYS generator, FILE(TO_NATIVE_PATH ...)
     360# In CMake 2.4.5 under the MSYS generator, FILE(TO_NATIVE_PATH ...)
    361361# generates Unix style pathnames.  Although this may be correct behavior
    362362# under the MSYS shell itself, Chicken probably won't be used under the
     
    15621562####################################################################
    15631563
    1564 # CMake 2.4.4, by default, only allows a shared or a static library
     1564# CMake 2.4.5, by default, only allows a shared or a static library
    15651565# of the same OUTPUT_NAME to be built in the same directory.  This is
    15661566# enforced by clobbering all the .o files before building; I think
     
    16001600# In principle, if we need to use a Darcs command, we should test
    16011601# whether Darcs is available and actually works.  In practice, writing
    1602 # reliable tool tests in CMake 2.4.4 is painful.
     1602# reliable tool tests in CMake 2.4.5 is painful.
    16031603#
    16041604# You cannot use EXECUTE_PROCESS to write a tool test.  It executes in
     
    16611661      #   COMMAND command1 [args...]
    16621662      #
    1663       # command1 has to be a CMake path.  This is not documented in CMake 2.4.4.
     1663      # command1 has to be a CMake path.  This is not documented in CMake 2.4.5.
    16641664      # Think of command1 as receiving "special interpretation" and not really
    16651665      # being a "custom" command, i.e. you're not free to do what you like.
     
    20252025#
    20262026# The ADD_CUSTOM_TARGET bulletproofing is supposed to work, but doesn't!
    2027 # In CMake 2.4.4, when file
     2027# In CMake 2.4.5, when file
    20282028# dependencies of ADD_CUSTOM_TARGET are not built, the target nevertheless
    20292029# reports success.  So you can use these targets, but don't trust 'em when
  • chicken/INSTALL-CMake.txt

    r2615 r2616  
    111111-------------
    112112
    113 CMake 2.4.4 or later is required.  Goto http://www.cmake.org download section, grab CMake for your platform, and install it.  Alternately, if your OS has a packaging and distribution system (i.e. RedHat, Debian, Cygwin, etc.) you can probably obtain it that way.
     113Goto http://www.cmake.org download section, grab CMake for your platform, and install it.  Alternately, if your OS has a packaging and distribution system (i.e. RedHat, Debian, Cygwin, etc.) you can probably obtain it that way.  Note that sometimes the packaged distributions aren't as current as what's available on the CMake website.  If your CMake isn't recent enough, the build will complain and notify you.
    114114
    115115
  • chicken/README

    r2615 r2616  
    33  (c)2000-2003 Felix L. Winkelmann
    44
    5   Version 2.508
     5  Version 2.509
    66
    77
  • chicken/build.scm

    r2615 r2616  
    1 (define-constant +build-version+ "2.508")
     1(define-constant +build-version+ "2.509")
  • chicken/chicken-setup.1

    r2488 r2616  
    155155
    156156.TP
     157.BI \-revision\ revision
     158Specifies the subversion revision that you want to check out (only useful in
     159combination with the
     160.B \-svn
     161option).
     162
     163.TP
    157164.BI \-run\ filename
    158165Load and execute given file.
  • chicken/chicken-setup.scm

    r2488 r2616  
    4040          setup-verbose-flag setup-install-flag installation-prefix find-library find-header
    4141          program-path remove-file* patch yes-or-no? setup-build-directory setup-root-directory create-directory
    42           test-compile try-compile copy-file run-verbose) )
     42          test-compile try-compile copy-file run-verbose required-chicken-version) )
    4343
    4444#>
     
    9797  '("-help" "-uninstall" "-list" "-run" "-repository" "-program-path" "-version" "-script" "-check"
    9898    "-fetch" "-host" "-proxy" "-keep" "-verbose" "-csc-option" "-dont-ask" "-no-install" "-docindex" "-eval"
    99     "-debug" "-ls" "-release" "-test" "-fetch-tree" "-tree" "-svn" "-local" "-destdir") )
     99    "-debug" "-ls" "-release" "-test" "-fetch-tree" "-tree" "-svn" "-local" "-destdir" "-revision") )
    100100
    101101(define-constant short-options
    102   '(#\h #\u #\l #\r #\R #\P #\V #\s #\C #\f #\H #\p #\k #\v #\c #\d #\n #\i #\e #\D #f #f #\t #f #f #f #f #f) )
     102  '(#\h #\u #\l #\r #\R #\P #\V #\s #\C #\f #\H #\p #\k #\v #\c #\d #\n #\i #\e #\D #f #f #\t #f #f #f #f #f #f) )
    103103
    104104
     
    170170(define *destdir* #f)
    171171(define *repository-hosts* '(("www.call-with-current-continuation.org" "eggs" 80)))
     172(define *revision* #f)
    172173
    173174
     
    417418      -local PATH                fetch extension from local filesystem
    418419      -destdir PATH              specify alternative installation prefix
     420      -revision REV              specify SVN revision for checkout
    419421  --                             ignore all following arguments
    420422
     
    692694    (zero? r) ) )
    693695
     696(define (required-chicken-version v)
     697  (when (string-ci<? (chicken-version) (->string v))
     698    (error (sprintf "CHICKEN version ~a or higher is required" v)) ) )
     699
    694700(define test-compile try-compile)
    695701
     
    790796         (when (setup-verbose-flag) (printf "fetching from svn repository ~a ...~%" *svn-repository*))
    791797         (let ((p (->string item)))
    792            (run (svn co ,(make-pathname *svn-repository* p) ,(make-pathname #f p "egg-dir"))) ) )
     798           (run (svn co ,(if *revision* (conc "--revision " *revision*) "")
     799                     ,(make-pathname *svn-repository* p) ,(make-pathname #f p "egg-dir"))) ) )
    793800        (else
    794801         (match hostdata
     
    10181025         (loop more) )
    10191026        (("-version" . _)
    1020          (printf "chicken-setup - Version ~A~%" (chicken-version))
     1027         (printf "chicken-setup - Version ~A~%" (chicken-version #t))
    10211028         (exit) )
    10221029        (("-release" . _)
     
    10741081        (("-debug" . more)
    10751082         (set! *debug* #t)
     1083         (loop more) )
     1084        (("-revision" rev . more)
     1085         (set! *revision* rev)
    10761086         (loop more) )
    10771087        (("-check" . more)
  • chicken/eval.scm

    r2615 r2616  
    15261526
    15271527(define ##sys#copy-env-table
    1528   (lambda (e mff mf)
    1529     (let* ([s (##sys#size e)]
    1530            [e2 (##sys#make-vector s '())] )
    1531       (do ([i 0 (fx+ i 1)])
    1532           ((fx>= i s) e2)
    1533         (##sys#setslot
    1534          e2 i
    1535          (let copy ([b (##sys#slot e i)])
    1536            (if (null? b)
    1537                '()
    1538                (let ([bi (##sys#slot b 0)])
    1539                  (cons (vector
    1540                         (##sys#slot bi 0)
    1541                         (##sys#slot bi 1)
    1542                         (if mff mf (##sys#slot bi 2)) )
    1543                        (copy (##sys#slot b 1)) ) ) ) ) ) ) ) ) )
     1528  (lambda (e mff mf . args)
     1529    (let ([syms (and (pair? args) (car args))])
     1530      (let* ([s (##sys#size e)]
     1531             [e2 (##sys#make-vector s '())] )
     1532       (do ([i 0 (fx+ i 1)])
     1533           ((fx>= i s) e2)
     1534         (##sys#setslot
     1535          e2 i
     1536          (let copy ([b (##sys#slot e i)])
     1537            (if (null? b)
     1538                '()
     1539                (let ([bi (##sys#slot b 0)])
     1540                  (let ([sym (##sys#slot bi 0)])
     1541                    (if (or (not syms) (memq sym syms))
     1542                      (cons (vector
     1543                              sym
     1544                              (##sys#slot bi 1)
     1545                              (if mff mf (##sys#slot bi 2)))
     1546                            (copy (##sys#slot b 1)))
     1547                      (copy (##sys#slot b 1)) ) ) ) ) ) ) ) ) ) ) )
     1548
     1549(define ##sys#environment-symbols
     1550  (lambda (env . args)
     1551    (##sys#check-structure env 'environment)
     1552    (let ([pred (and (pair? args) (car args))])
     1553      (let ([envtbl (##sys#slot env 1)])
     1554        (if envtbl
     1555            ;then "real" environment
     1556          (let ([envtblsiz (vector-length envtbl)])
     1557            (do ([i 0 (fx+ i 1)]
     1558                 [syms
     1559                   '()
     1560                   (let loop ([bucket (vector-ref envtbl i)] [syms syms])
     1561                     (if (null? bucket)
     1562                       syms
     1563                       (let ([sym (vector-ref (car bucket) 0)])
     1564                         (if (or (not pred) (pred sym))
     1565                           (loop (cdr bucket) (cons sym syms))
     1566                           (loop (cdr bucket) syms) ) ) ) )])
     1567                ((fx>= i envtblsiz) syms) ) )
     1568            ;else interaction-environment
     1569          (let ([syms '()])
     1570            (##sys#walk-namespace
     1571              (lambda (sym)
     1572                (when (or (not pred) (pred sym))
     1573                  (set! syms (cons sym syms)) ) ) )
     1574            syms ) ) ) ) ) )
    15441575
    15451576(define (interaction-environment) ##sys#interaction-environment)
     
    15691600    (lambda (b)
    15701601      (let ([loc (##sys#hash-table-location ht b #t)])
    1571         (##sys#setslot loc 1 (##sys#slot b 0)) ) ) )
     1602        (##sys#setslot loc 1 (##sys#slot b 0)) ) ) )
    15721603  (for-each
    15731604   (initb ##sys#r4rs-environment)
  • chicken/library.scm

    r2615 r2616  
    33463346                              [loc (and loca (cadr loca))] )
    33473347                          (if (and loc (symbol? loc))
    3348                               (string-append "(" (##sys#symbol->qualified-string loc) ") " msg)
     3348                              (string-append
     3349                               "(" (##sys#symbol->qualified-string loc) ") "
     3350                               (cond ((symbol? msg) (##sys#slot msg 1))
     3351                                     ((string? msg) msg)
     3352                                     (else "") ) ) ; Hm...
    33493353                              msg) )
    33503354                        "<exn: has no `message' property>")
     
    40954099                    (cond [(symbol? prefix) (##sys#slot prefix 1)]
    40964100                          [(string? prefix) prefix]
    4097                           [else (##sys#signal-hook #:type-error 'import "bad argument type - invalid prefix" prefix)] ) ) ] )
    4098           (##sys#check-symbol ns 'import)
    4099           (##sys#check-list syms 'import)
     4101                          [else (##sys#signal-hook #:type-error "bad argument type - invalid prefix" prefix)] ) ) ] )
    41004102          (let ([nsp (##sys#find-symbol-table (##sys#make-c-string (##sys#slot ns 1)))])
    41014103            (define (copy s str)
     
    41054107                             str) ) ] )
    41064108                (##sys#setslot s2 0 (##sys#slot s 0)) ) )
    4107             (unless nsp (##sys#error 'import "undefined namespace" ns))
     4109            (unless nsp (##sys#error "undefined namespace" ns))
    41084110            (if (null? syms)
    41094111                (let ([it (cons -1 '())])
     
    41204122                         (begin
    41214123                           (set! old (##sys#slot ss 0))
    4122                            (set! new (##sys#slot (##sys#slot ss 1) 0))
    4123                            (##sys#check-symbol new 'import) )
     4124                           (set! new (##sys#slot (##sys#slot ss 1) 0)) )
    41244125                         (begin
    41254126                           (set! old ss)
    41264127                           (set! new ss) ) )
    4127                      (##sys#check-symbol old 'import)
    41284128                     (let* ([str (##sys#slot old 1)]
    41294129                            [s (##sys#find-symbol str nsp)] )
    41304130                       (unless s
    4131                          (##sys#error 'import "symbol not exported from namespace" ss ns) )
     4131                         (##sys#error "symbol not exported from namespace" ss ns) )
    41324132                       (copy s (##sys#slot new 1)) ) ) )
    41334133                 syms) ) ) ) ) ) ) )
    41344134
    41354135(define (##sys#namespace-ref ns sym . default)
    4136   (##sys#check-symbol ns 'namespace-ref)
    41374136  (let ([s (##sys#find-symbol
    41384137            (cond [(symbol? sym) (##sys#slot sym 1)]
    41394138                  [(string? sym) sym]
    4140                   [else (##sys#signal-hook #:type-error 'namespace-ref "bad argument type - not a valid import name" sym)] )
     4139                  [else (##sys#signal-hook #:type-error "bad argument type - not a valid import name" sym)] )
    41414140            (##sys#find-symbol-table (##sys#make-c-string (##sys#slot ns 1))) ) ] )
    41424141    (cond [s (##core#inline "C_retrieve" s)]
    41434142          [(pair? default) (car default)]
    4144           [else (##sys#error 'namespace-ref "symbol not exported from namespace" sym ns)] ) ) )
    4145 
     4143          [else (##sys#error "symbol not exported from namespace" sym ns)] ) ) )
     4144
     4145(define (##sys#walk-namespace proc . args)
     4146  (let ([ns (if (pair? args) (car args) ".")])
     4147    (let ([nsp (##sys#find-symbol-table ns)]
     4148          [enum-syms! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object)]
     4149          [pos (cons -1 '())])
     4150      (unless nsp (##sys#error "undefined namespace" ns))
     4151      (let loop ()
     4152        (let ([sym (enum-syms! nsp pos)])
     4153          (when sym
     4154            (proc sym)
     4155            (loop) ) ) ) ) ) )
    41464156
    41474157;;; More memory info
  • chicken/posixunix.scm

    r2443 r2616  
    293293#define C_sigemptyset(d)    (sigemptyset(&C_sigset), C_SCHEME_UNDEFINED)
    294294#define C_sigaddset(s)      (sigaddset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)
    295 #define C_sigprocmask(d)    C_fix(sigprocmask(SIG_SETMASK, &C_sigset, NULL))
     295#define C_sigdelset(s)      (sigdelset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)
     296#define C_sigismember(s)    C_mk_bool(sigismember(&C_sigset, C_unfix(s)))
     297#define C_sigprocmask_set(d)        C_fix(sigprocmask(SIG_SETMASK, &C_sigset, NULL))
     298#define C_sigprocmask_block(d)      C_fix(sigprocmask(SIG_BLOCK, &C_sigset, NULL))
     299#define C_sigprocmask_unblock(d)    C_fix(sigprocmask(SIG_UNBLOCK, &C_sigset, NULL))
    296300
    297301#define C_open(fn, fl, m)   C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))
     
    304308#define C_lseek(fd, o, w)     C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
    305309
    306 #define C_zero_fd_set(i)    FD_ZERO(&C_fd_sets[ i ])
    307 #define C_set_fd_set(i, fd) FD_SET(fd, &C_fd_sets[ i ])
    308 #define C_test_fd_set(i, fd) FD_ISSET(fd, &C_fd_sets[ i ])
     310#define C_zero_fd_set(i)      FD_ZERO(&C_fd_sets[ i ])
     311#define C_set_fd_set(i, fd)   FD_SET(fd, &C_fd_sets[ i ])
     312#define C_test_fd_set(i, fd)  FD_ISSET(fd, &C_fd_sets[ i ])
    309313#define C_C_select(m)         C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, NULL))
    310314#define C_C_select_t(m, t)    (C_timeval.tv_sec = C_unfix(t), C_timeval.tv_usec = 0, C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, &C_timeval)))
     
    918922(let ([oldhook ##sys#interrupt-hook]
    919923      [sigvector (make-vector 256 #f)] )
     924  (set! signal-handler
     925    (lambda (sig)
     926      (##sys#check-exact sig 'signal-handler)
     927      (##sys#slot sigvector sig) ) )
    920928  (set! set-signal-handler!
    921929    (lambda (sig proc)
     
    941949       (##core#inline "C_sigaddset" s) )
    942950     sigs)
    943     (when (fx< (##core#inline "C_sigprocmask" 0) 0)
     951    (when (fx< (##core#inline "C_sigprocmask_set" 0) 0)
    944952      (posix-error #:process-error 'set-signal-mask! "can not set signal mask") ) ) )
    945953
     954(define signal-mask
     955  (let ([allsigs
     956          (list
     957            signal/term signal/kill signal/int signal/hup signal/fpe signal/ill
     958            signal/segv signal/abrt signal/trap signal/quit signal/alrm signal/vtalrm
     959            signal/prof signal/io signal/urg signal/chld signal/cont signal/stop
     960            signal/tstp signal/pipe signal/xcpu signal/xfsz signal/usr1 signal/usr2
     961            signal/winch)] )
     962    (lambda ()
     963      (let loop ([sigs allsigs]
     964                 [mask '()])
     965        (if (null? sigs)
     966          mask
     967          (let ([sig (car sigs)])
     968            (loop (cdr sigs)
     969                  (if (##core#inline "C_sigismember" sig) (cons sig mask) mask)) ) ) ) ) ) )
     970
     971(define (signal-masked? sig)
     972  (##sys#check-exact sig 'signal-masked?)
     973  (##core#inline "C_sigismember" sig) )
     974
     975(define (signal-mask! sig)
     976  (##sys#check-exact sig 'signal-mask!)
     977  (##core#inline "C_sigaddset" sig)
     978  (when (fx< (##core#inline "C_sigprocmask_block" 0) 0)
     979      (posix-error #:process-error 'signal-mask! "cannot block signal") )  )
     980
     981(define (signal-unmask! sig)
     982  (##sys#check-exact sig 'signal-unmask!)
     983  (##core#inline "C_sigdelset" sig)
     984  (when (fx< (##core#inline "C_sigprocmask_unblock" 0) 0)
     985      (posix-error #:process-error 'signal-unmask! "cannot unblock signal") )  )
    946986
    947987;;; Set SIGINT handler:
  • chicken/posixwin.scm

    r2248 r2616  
    4343; symbolic-link?
    4444; signal/...
    45 ; set-signal-handler!  set-signal-mask!
     45; set-signal-handler!  signal-handler
     46; set-signal-mask!  signal-mask  signal-masked?  signal-mask!  signal-unmask!
    4647; user-information  group-information  get-groups  set-groups!  initialize-groups
    4748; errno/wouldblock
  • chicken/tests/library-tests.scm

    r1016 r2616  
    11(assert (= -4.0 (round -4.3)))
    22(assert (= 4.0 (round 3.5)))
    3 (assert (= 4 (round 7/2)))
     3(assert (= 4 (round (string->number "7/2"))))
    44(assert (= 7 (round 7)))
    55(assert (zero? (round -0.5)))           ; is actually -0.0
  • chicken/utils.scm

    r1928 r2616  
    3636(declare
    3737  (unit utils)
    38   (uses regex extras)
     38  (uses regex extras eval)
    3939  (usual-integrations)
    4040  (fixnum)
     
    4949    (no-procedure-checks-for-usual-bindings)
    5050    (bound-to-procedure
     51      apropos-list apropos
    5152      ##sys#string-append reverse port? read-string with-input-from-file command-line-arguments
    5253      for-each-line ##sys#check-port read-line getenv make-pathname file-exists? call-with-output-file
     
    7374
    7475(register-feature! 'utils)
     76
     77
     78;;; Environment utilities
     79
     80(define ##sys#apropos
     81  (lambda (patt env)
     82    (when (symbol? patt)
     83      (set! patt (symbol->string patt)))
     84    (when (string? patt)
     85      (set! patt (regexp (regexp-escape patt))))
     86    (##sys#environment-symbols env
     87      (lambda (sym)
     88        (not (not (string-search patt (symbol->string sym)))))) ) )
     89
     90(let ([%apropos-list
     91        (lambda (loc patt args)
     92          (let ([env (if (pair? args) (car args) (interaction-environment))])
     93            (##sys#check-structure env 'environment loc)
     94            (unless (or (string? patt) (symbol? patt) (regexp? patt))
     95              (##sys#signal-hook #:type-error loc "bad argument type - not a string, symbol, or regexp" patt))
     96            (##sys#apropos patt env) ) )])
     97  (set! apropos-list
     98    (lambda (patt . args)
     99      (%apropos-list 'apropos-list patt args)))
     100  (set! apropos
     101    (lambda (patt . args)
     102      (for-each
     103        (lambda (sym) (display sym) (newline))
     104        (%apropos-list 'apropos patt args)) ) ) )
    75105
    76106
Note: See TracChangeset for help on using the changeset viewer.