Changeset 11084 in project


Ignore:
Timestamp:
06/26/08 09:02:24 (12 years ago)
Author:
felix winkelmann
Message:

numbers debugging

Location:
release/4
Files:
2 edited
1 moved

Legend:

Unmodified
Added
Removed
  • release/4/easyffi/easyffi.scm

    r11074 r11084  
    1919        (if (every string? strs)
    2020            `(,(r 'declare)
    21               (,(r 'foreign-declare) ,@strs))
     21              (foreign-declare ,@strs))
    2222            (syntax-error
    2323             'foreign-declare "syntax error in declaration" strs) ) ) ))
     
    3535      (let ((strs (append (cdr x) '("\n"))))
    3636        `(,(r 'begin)
    37           (,(r 'declare) (,(r 'foreign-declare) ,@strs))
     37          (,(r 'declare) (foreign-declare ,@strs))
    3838          (,(r 'foreign-parse) ,@strs)) ) ))
    3939
  • release/4/numbers/numbers.scm

    r11082 r11084  
    1 ;;;; numbers-base.scm
     1;;;; numbers.scm
    22;
    3 ; Copyright (c) 2000-2005, Felix L. Winkelmann
     3; Copyright (c) 2008 The CHICKEN Team
     4; Copyright (c) 2000-2007, Felix L. Winkelmann
    45; All rights reserved.
    56;
     
    2324; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    2425; POSSIBILITY OF SUCH DAMAGE.
    25 ;
    26 ; Send bugs, suggestions and ideas to:
    27 ;
    28 ; felix@call-with-current-continuation.org
    29 ;
    30 ; Felix L. Winkelmann
    31 ; Unter den Gleichen 1
    32 ; 37130 Gleichen
    33 ; Germany
    34 
    35 
    36 #>!
    37 #include "numbers-c.h"
    38 <#
    39 
    40 #>
    41 #include "numbers-c.c"
    42 
    43 #define C_specialequalptrs(x, y)   C_mk_bool(C_block_item(x, 0) == C_block_item(y, 0))
    44 <#
    45 
    46 
    47 (include "numbers.scm")
    4826
    4927
     
    5331  (disable-warning redef)
    5432  (no-bound-checks)
    55   (no-procedure-checks)
    56   (export + - * / = > < >= <=
    57           ##numbers#fetch-counters
    58           ##sys#string->number ##sys#number->string ##sys#number?
    59           ##sys#integer? ##sys#exact? ##sys#inexact?
    60           ##sys#inexact->exact ##sys#exact->inexact
    61           add1 sub1 signum number->string string->number
    62           bitwise-and bitwise-ior bitwise-xor bitwise-not arithmetic-shift
    63           numbers:bitwise-and numbers:bitwise-ior numbers:bitwise-xor
    64           numbers:bitwise-not
    65           eqv? equal?
    66           exp log sin cos tan atan acos asin expt sqrt conj
    67           quotient modulo remainder
    68           numerator denominator
    69           abs max min gcd lcm
    70           positive? negative? odd? even? zero?
    71           exact? inexact?
    72           rationalize
    73           random randomize
    74           floor ceiling truncate round
    75           inexact->exact exact->inexact
    76           number? complex? real? rational? integer?
    77           make-rectangular make-polar real-part imag-part magnitude angle
    78           bignum? ratnum? cflonum? rectnum? compnum?
    79           numbers:+ numbers:- numbers:> numbers:< numbers:=
    80           numbers:>= numbers:<=) )
    81 
    82 (eval-when (compile) (match-error-control #:unspecified))
     33  (no-procedure-checks))
     34
     35
     36
     37(module numbers
     38    (+ - * / = > < >= <=
     39       add1 sub1 signum number->string string->number
     40       bitwise-and bitwise-ior bitwise-xor bitwise-not arithmetic-shift
     41       numbers:bitwise-and numbers:bitwise-ior numbers:bitwise-xor
     42       numbers:bitwise-not
     43       eqv? equal?
     44       exp log sin cos tan atan acos asin expt sqrt conj
     45       quotient modulo remainder
     46       numerator denominator
     47       abs max min gcd lcm
     48       positive? negative? odd? even? zero?
     49       exact? inexact?
     50       rationalize
     51       random randomize
     52       floor ceiling truncate round
     53       inexact->exact exact->inexact
     54       number? complex? real? rational? integer?
     55       make-rectangular make-polar real-part imag-part magnitude angle
     56       bignum? ratnum? cflonum? rectnum? compnum?
     57       numbers:+ numbers:- numbers:> numbers:< numbers:=
     58       numbers:>= numbers:<=)
     59
     60  (import scheme chicken foreign regex easyffi)
     61
     62
     63#>!
     64#include "numbers-c.h"
     65<#
     66
     67#>
     68#include "numbers-c.c"
     69
     70#define C_specialequalptrs(x, y)   C_mk_bool(C_block_item(x, 0) == C_block_item(y, 0))
     71<#
    8372
    8473
     
    9079(define-inline (bad-complex/o loc x) (##sys#signal-hook #:type-error loc "bad argument type - complex number has no ordering" x))
    9180(define-inline (bad-base loc x) (##sys#signal-hook #:type-error loc "bad argument type - not a valid base" x))
     81
     82(define-inline (%init-tags tagvec) (##core#inline "init_tags" tagvec))
     83(define-inline (%check-number x) (##core#inline "check_number" x))
    9284
    9385(define-inline (assert-number x loc)
     
    122114(define-inline (complex-imag c) (##sys#slot c 2))
    123115(define-inline (%make-complex r i) (##sys#make-structure 'compnum r i))
    124 
    125 (define-inline (%init-tags tagvec) (##core#inline "init_tags" tagvec))
    126 (define-inline (%check-number x) (##core#inline "check_number" x))
    127116
    128117(define-inline (%fix->flo n) (##core#inline_allocate ("fix_to_flo" 4) n))
     
    233222;;; Support macros
    234223
    235 (define-macro (switchq exp . body)
    236   (let ((tmp (gensym)))
    237     `(let ((,tmp ,exp))
    238        ,(let expand ((clauses body))
    239           (if (not (pair? clauses))
    240               '(##core#undefined)
    241               (let ((clause (##sys#slot clauses 0))
    242                     (rclauses (##sys#slot clauses 1)) )
    243                 (##sys#check-syntax 'switch clause '#(_ 1))
    244                 (if (eq? 'else (car clause))
    245                     `(begin ,@(cdr clause))
    246                     `(if (eq? ,tmp ,(car clause))
    247                          (begin ,@(cdr clause))
    248                          ,(expand rclauses) ) ) ) ) ) ) ) )
     224(define-syntax switchq
     225  (syntax-rules (else)
     226    ((_ "aux" _) (##core#undefined))
     227    ((_ "aux" _ (else body ...))
     228     (begin body ...))
     229    ((_ "aux" tmp (val body ...) more ...)
     230     (if (eq? tmp val)
     231         (begin body ...)
     232         (switchq "aux" tmp more ...)))
     233    ((_ exp body ...)
     234     (let ((tmp exp))
     235       (switchq "aux" tmp body ...)))))
    249236
    250237
     
    670657                (%* r (##core#inline_allocate ("C_a_i_sin" 4) phi))))
    671658
    672 (set! make-polar %make-polar)
     659(define make-polar %make-polar)
    673660
    674661(define (real-part x)
     
    744731    (NONE (bad-number 'abs x)) ) )
    745732
    746 (set! abs %abs)
     733(define abs %abs)
    747734
    748735(define (number? x)
     
    752739
    753740(set! ##sys#number? number?)
    754 (set! complex? number?)
     741(define complex? number?)
    755742
    756743(define (real? x)
     
    769756    (else #f) ) )
    770757
    771 (set! integer? %integer?)
     758(define integer? %integer?)
    772759(set! ##sys#integer? %integer?)
    773760
     
    779766    (else #t) ) )
    780767
    781 (set! exact? %exact?)
     768(define exact? %exact?)
    782769(set! ##sys#exact? %exact?)
    783770
     
    789776    (else #f) ) )
    790777
    791 (set! inexact? %inexact?)
     778(define inexact? %inexact?)
    792779(set! ##sys#inexact? %inexact?)
    793780
     
    802789    (else #f) ) )
    803790
    804 (set! zero? %zero?)
     791(define zero? %zero?)
    805792
    806793(define (odd? x)
     
    872859      (if i (%exact->inexact r) r) ) ) )
    873860
    874 (set! quotient %quotient)
     861(define quotient %quotient)
    875862
    876863(define (%remainder x y)
    877864  (%- x (%* (%quotient x y) y)) )
    878865
    879 (set! remainder %remainder)
     866(define remainder %remainder)
    880867
    881868(define (modulo x y)
     
    895882    (NONE (bad-number 'inexact->exact x)) ) )
    896883
    897 (set! inexact->exact %inexact->exact)
     884(define inexact->exact %inexact->exact)
    898885(set! ##sys#inexact->exact %inexact->exact)
    899886
     
    907894    (NONE (bad-number 'exact->inexact x)) ) )
    908895
    909 (set! exact->inexact %exact->inexact)
     896(define exact->inexact %exact->inexact)
    910897(set! ##sys#exact->inexact %exact->inexact)
    911898
     
    949936    (COMP (bad-real 'floor x)) ) )
    950937
    951 (set! floor %floor)
     938(define floor %floor)
    952939
    953940(define (ceiling x)
     
    10441031    (else (##core#inline_allocate ("C_a_i_exp" 4) (%exact->inexact n)) ) ))
    10451032
    1046 (set! exp %exp)
     1033(define exp %exp)
    10471034
    10481035(define (%log n)
     
    10521039    (else (##core#inline_allocate ("C_a_i_log" 4) (%exact->inexact n)) ) ) )
    10531040
    1054 (set! log %log)
     1041(define log %log)
    10551042
    10561043(define %i (%make-complex 0 1))
     
    10651052    (else (##core#inline_allocate ("C_a_i_sin" 4) (%exact->inexact n)) ) ))
    10661053
    1067 (set! sin %sin)
     1054(define sin %sin)
    10681055
    10691056(define (%cos n)
     
    10741061    (else (##core#inline_allocate ("C_a_i_cos" 4) (%exact->inexact n)) ) ) )
    10751062
    1076 (set! cos %cos)
     1063(define cos %cos)
    10771064
    10781065(define (tan n)
     
    10881075    (else (##core#inline_allocate ("C_a_i_asin" 4) (%exact->inexact n)) ) ))
    10891076
    1090 (set! asin %asin)
     1077(define asin %asin)
    10911078
    10921079(define acos
     
    11241111       (##core#inline_allocate ("C_a_i_sqrt" 4) (%exact->inexact n)) ) )))
    11251112
    1126 (set! sqrt %sqrt)
     1113(define sqrt %sqrt)
    11271114
    11281115(define (%power base e)
     
    12661253          (else (bad-number 'number->string n)) ) ) ) ) )
    12671254
    1268 (set! number->string %number->string)
     1255(define number->string %number->string)
    12691256(set! ##sys#number->string %number->string)
    12701257
     
    13481335                           ((string=? sub "-i") (fin (make-complex 0 -1)))
    13491336                           (else
    1350                             (match (string-match-positions rxp sub)
    1351                               ((_ (a1 a2) (b1 b2))
    1352                                (and-let* ((a (real sub a1 a2))
    1353                                           (b (real sub b1 b2)) )
    1354                                  (fin (%make-polar a b) ) ) )
    1355                               (_ (match (string-match-positions rxr sub)
    1356                                    ((_ (a1 a2) #f)
    1357                                     (and-let* ((a (real sub a1 a2)))
    1358                                       (fin (make-complex 0 a)) ) )
    1359                                    ((_ (r1 r2) (i1 i2))
    1360                                     (and-let* ((rp (real sub r1 r2))
    1361                                                (ip (if (eq? i2 (fx+ i1 1))
    1362                                                        (case (%subchar sub i1)
    1363                                                          ((#\-) -1)
    1364                                                          ((#\+) 1)
    1365                                                          (else #f) )
    1366                                                        (real sub i1 i2)) ) )
    1367                                       (fin (make-complex rp ip)) ) )
    1368                                    (_ (match (string-match-positions rxr0 sub)
    1369                                         ((_ (i1 i2))
    1370                                          (fin (make-complex 0 (real sub i1 i2))) )
    1371                                         (_ (fin (or (real str start len)
    1372                                                     (string->number-0 str) )) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
     1337                            (let ((m (string-match-positions rxp sub)))
     1338                              (if (and (= 3 (length m))
     1339                                       (pair? (cadr m))
     1340                                       (pair? (caddr m)))
     1341                                  (and-let* ((a (real sub (caadr m) (cadadr m)))
     1342                                             (b (real sub (caaddr m) (cadadr (cdr m)))))
     1343                                    (fin (%make-polar a b) ) )
     1344                                  (let* ((m (string-match-positions rxr sub))
     1345                                         (lm (length m)))
     1346                                    (cond ((and (= 3 lm)
     1347                                                (pair? (cadr m))
     1348                                                (not (caddr m)))
     1349                                           (and-let* ((a (real sub (caadr m) (cadadr m))))
     1350                                             (fin (make-complex 0 a)) ) )
     1351                                          ((and (= 3 lm)
     1352                                                (pair? (cadr m))
     1353                                                (pair? (caddr m)))
     1354                                           (let ((r1 (caadr m))
     1355                                                 (r2 (cadadr m))
     1356                                                 (i1 (caaddr m))
     1357                                                 (i2 (cadadr (cdr m))))
     1358                                             (and-let* ((rp (real sub r1 r2))
     1359                                                        (ip (if (eq? i2 (fx+ i1 1))
     1360                                                                (case (%subchar sub i1)
     1361                                                                  ((#\-) -1)
     1362                                                                  ((#\+) 1)
     1363                                                                  (else #f) )
     1364                                                                (real sub i1 i2))))
     1365                                               (fin (make-complex rp ip)) ) ) )
     1366                                          (else
     1367                                           (let ((m (string-match-positions rxr0 sub)))
     1368                                             (if (and (pair? (cdr m)) (pair? (cadr m)))
     1369                                                 (fin (make-complex 0 (real sub (caadr m) (cadadr m))))
     1370                                                 (fin (or (real str start len)
     1371                                                          (string->number-0 str) )) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) ) )
    13731372
    13741373(define (randomize #!optional (seed (##sys#fudge 2)))
     
    13841383    (else (bad-integer 'random n)) ) )
    13851384
    1386 (set! string->number %string->number)
     1385(define string->number %string->number)
    13871386(set! ##sys#string->number %string->number)
    13881387
     
    14191418
    14201419(register-feature! #:full-numeric-tower)
     1420
     1421)
  • release/4/numbers/numbers.setup

    r10401 r11084  
    1 (define d-c-m? (string>=? (chicken-version) "2.622"))
    2 (define easyffi? (string>=? (chicken-version) "2.424"))
    3 (define has-exports? (string>=? (chicken-version) "2.310"))
     1(compile -s -O2 -d1 numbers.scm -lgmp
     2         -j numbers
     3         -extend easyffi)
    44
    5 (compile -s -O2 -d1 numbers-base.scm -lgmp
    6          -D numbers-bootstrap
    7          ,@(if has-exports? '(-check-imports -emit-exports numbers.exports) '())
    8          ,@(if easyffi? '(-extend easyffi) '())
    9          ,@(if d-c-m? '(-disable-compiler-macros) '()))
     5(compile -O2 -d1 numbers.scm -c
     6         -unit numbers -o numbers-static.o
     7         -extend easyffi)
    108
    11 (compile -O2 -d1 numbers-base.scm -c
    12          -D numbers-bootstrap -unit numbers -o numbers-static.o
    13          ,@(if easyffi? '(-extend easyffi) '())
    14          ,@(if d-c-m? '(-disable-compiler-macros) '()))
     9(compile -s -O2 -d0 numbers.import.scm)
    1510
    1611(install-extension
    1712  'numbers
    18   '("numbers-base.so" "numbers.scm" "numbers-compiler-macros.scm"
    19     "numbers-static.o")
     13  '("numbers.so" "numbers-static.o" "numbers.import.so")
    2014  `((syntax)
    21     (documentation "numbers.html")
    22     (version "1.806")
     15    (version "1.807")
    2316    (static "numbers-static.o")
    24     (static-options "-lgmp")
    25     ,@(if has-exports? `((exports "numbers.exports")) '())
    26     (require-at-runtime numbers-base)) )
     17    (static-options "-lgmp")))
Note: See TracChangeset for help on using the changeset viewer.