Changeset 13716 in project


Ignore:
Timestamp:
03/12/09 19:10:43 (11 years ago)
Author:
Kon Lovett
Message:

Moved errors into module.

Location:
release/4/err5rs-arithmetic/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/err5rs-arithmetic/trunk/chicken-primitive-object-inlines.scm

    r13706 r13716  
    3434;; k       - continuation
    3535
    36 
    3736;;; Unsafe Type Predicates
    3837
     
    134133(define-inline (%locative-type? x) (##core#inline "C_locativep" x))
    135134
    136 
    137135;;; Safe Type Predicates
    138136
     
    259257(define-inline (%forwarded? x) (##core#inline "C_forwardedp" x))
    260258
    261 
    262259;;; Operations
    263260
     
    265262
    266263(define-inline (%eq? x y) (##core#inline "C_eqp" x y))
    267 
    268 (define-inline (%peek-signed-integer b i) ((##core#primitive "C_peek_signed_integer") b i))
    269 (define-inline (%peek-unsigned-integer b i) ((##core#primitive "C_peek_unsigned_integer") b i))
    270 (define-inline (%poke-integer b i n) (##core#inline "C_poke_integer" b i n))
    271264
    272265;; Fixnum
     
    320313;; Block
    321314
     315(define-inline (%peek-signed-integer b i) ((##core#primitive "C_peek_signed_integer") b i))
     316(define-inline (%peek-unsigned-integer b i) ((##core#primitive "C_peek_unsigned_integer") b i))
     317(define-inline (%poke-integer b i n) (##core#inline "C_poke_integer" b i n))
     318
    322319;Safe
    323320
     
    435432
    436433;Unsafe
    437 
    438 (define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))
    439434
    440435(define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y))
     
    971966
    972967(define-inline (%randomize n) (##core#inline "C_randomize" n))
     968
     969;;; Operations
     970
     971;Safe
     972
     973(define-inline (%->boolean obj) (and obj #t))
     974
     975(define-inline (%make-unique-object #!optional id) (if id (%make-vector 1 id) '#()))
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-bitwise.scm

    r13706 r13716  
    11;;;; err5rs-arithmetic-bitwise.scm
    22;;;; Kon Lovett, Mar '09
    3 
    43
    54;;; Prelude
     
    1312        (no-procedure-checks)
    1413  (bound-to-procedure
    15     ##sys#check-list
    16     ##sys#check-integer
    1714    ##sys#signal-hook
    1815    ##sys#string-append ) )
    1916
    2017;;
    21 
    22 (require-library srfi-1 int-limits)
    2318
    2419(include "chicken-primitive-object-inlines")
     
    259254;;
    260255
    261 (define-inline (%error-outside-range loc obj low high)
    262   (##sys#signal-hook #:bounds-error loc (##core#immutable '"out of range") obj low high) )
    263 
    264 ;;
    265 
    266 (define-inline (%check-list loc obj) (##sys#check-list obj loc))
    267 
    268 (define-inline (%check-integer loc obj) (##sys#check-integer obj loc))
    269 
    270 (define-inline (%check-fixnum loc obj)
    271   (unless (%fixnum? obj)
    272     (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a fixnum") obj) ) )
     256(define-inline (%check-fixnum loc obj) (unless (%fixnum? obj) (error-type-fixnum loc obj)))
     257
     258(define-inline (%check-list loc obj) (unless (%list? obj) (error-type-list obj loc)))
     259
     260(define-inline (%check-integer loc obj) (unless (%integer? obj) (error-type-integer obj loc)))
    273261
    274262;;
     
    276264(define-inline (%check-fixnum-bounds-order loc fx1 fx2)
    277265  (unless (%fx<= fx1 fx2)
    278     (##sys#signal-hook #:bounds-error loc (##core#immutable '"bounds reversed") fx1 fx2) ) )
     266    (error-bounds-order loc start end) ) )
    279267
    280268(define-inline (%check-fixnum-range loc lfx fx hfx)
    281269  (unless (%fxclosed? lfx fx hfx)
    282     (%error-outside-range loc fx lfx hfx) ) )
     270    (error-outside-range loc fx lfx hfx) ) )
    283271
    284272;;
     
    297285(define-inline (%check-fixnum-bits-count loc count start end)
    298286  (unless (%fx< (%fxabs count) (%fx- end start))
    299     (##sys#signal-hook #:bounds-error loc (##core#immutable '"too many bits for range") count start end) ) )
     287    (error-bits-count loc count start end) ) )
    300288
    301289;;
     
    309297
    310298;;;
     299
     300(require-library srfi-1 int-limits)
    311301
    312302(module err5rs-arithmetic-bitwise (;export
     
    350340(import scheme chicken foreign srfi-1 int-limits)
    351341
     342;;; Errors
     343
     344(define (error-type-fixnum loc obj)
     345  (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
     346
     347(define (error-type-integer loc obj)
     348  (##sys#signal-hook #:type-error loc "bad argument type - not an integer" obj) )
     349
     350(define (error-type-list loc obj)
     351  (##sys#signal-hook #:type-error loc "bad argument type - not a list" obj) )
     352
     353(define-inline (error-outside-range loc obj low high)
     354  (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
     355
     356(define (error-bounds-order loc start end)
     357  (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
     358
     359(define (error-bits-count loc count start end)
     360  (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
    352361
    353362;;; Extras
     
    469478(define (boolean->bit bit) (%boolean->bit* bit))
    470479
    471 
    472480;;; ERR5RS
    473481
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

    r13706 r13716  
    11;;;; err5rs-arithmetic-fixnums.scm
    22;;;; Kon Lovett, Mar '09
    3 
    43
    54;;; Prelude
     
    1817;;
    1918
    20 (require-library data-structures err5rs-arithmetic-bitwise)
    21 
    2219(include "chicken-primitive-object-inlines")
    2320
    2421;;
    2522
    26 (define-inline (%error-outside-range loc obj low high)
    27   (##sys#signal-hook #:bounds-error loc (##core#immutable '"out of range") obj low high) )
    28 
    29 (define-inline (%error-invalid-radix loc radix)
    30   (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - invalid radix") radix) )
    31 
    32 (define-inline (%error-zero-division loc fx1 fx2)
    33   (##sys#signal-hook #:arithmetic-error loc (##core#immutable '"division by zero") fx1 fx2) )
    34 
    35 (define-inline (%error-fixnum-representation loc fx1 fx2)
    36   (##sys#signal-hook #:arithmetic-error loc (##core#immutable '"results not representable as fixnums") fx1 fx2) )
    37 
    38 ;;
    39 
    40 (define-inline (%check-fixnum loc obj)
    41   (unless (%fixnum? obj)
    42     (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a fixnum") obj) ) )
     23(define-inline (%check-fixnum loc obj) (unless (%fixnum? obj) (error-type-fixnum loc obj)))
    4324
    4425(define-inline (%check-cardinal-fixnum loc obj)
    4526  (unless (and (%fixnum? obj) (%fxcardinal? obj))
    46     (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a cardinal fixnum") obj) ) )
     27    (error-type-cardinal-fixnum loc obj) ) )
    4728
    4829;;
     
    5031(define-inline (%check-fixnum-bounds-order loc start end)
    5132  (unless (%fx<= start end)
    52     (##sys#signal-hook #:bounds-error loc (##core#immutable '"bounds reversed") start end) ) )
     33    (error-bounds-order loc start end) ) )
    5334
    5435(define-inline (%check-fixnum-range loc lfx fx hfx)
    5536  (unless (%fxclosed? lfx fx hfx)
    56     (%error-outside-range loc fx lfx hfx) ) )
     37    (error-outside-range loc fx lfx hfx) ) )
    5738
    5839;;
     
    7354(define-inline (%check-fixnum-bits-count loc count start end)
    7455  (unless (%fx< count (%fx- end start))
    75     (##sys#signal-hook #:bounds-error loc (##core#immutable '"too many bits for interval") count start end) ) )
     56    (error-bits-count loc count start end) ) )
    7657
    7758;;
     
    7960(define-inline (%check-zero-division loc fx1 fx2)
    8061  (when (%fxzero? fx2)
    81     (%error-zero-division loc fx1 fx2) ) )
     62    (error-zero-division loc fx1 fx2) ) )
    8263
    8364;;
     
    152133(define-inline (%string-append s1 s2) (##sys#string-append s1 s2))
    153134
    154 
    155 ;;;
     135;;;
     136
     137(require-library data-structures err5rs-arithmetic-bitwise)
    156138
    157139(module err5rs-arithmetic-fixnums (;export
     
    190172(import scheme
    191173        (rename chicken
    192          (fxmax chicken:fxmax)
    193          (fxmin chicken:fxmin)
    194          (fx- chicken:fx-)
    195          (fxand chicken:fxand)
    196          (fxior chicken:fxior)
    197          (fxxor chicken:fxxor))
     174          (fxmax chicken:fxmax)
     175          (fxmin chicken:fxmin)
     176          (fx- chicken:fx-)
     177          (fxand chicken:fxand)
     178          (fxior chicken:fxior)
     179          (fxxor chicken:fxxor))
    198180        data-structures
    199181        foreign
    200182        err5rs-arithmetic-bitwise)
    201183
     184;;; Errors
     185
     186(define (error-type-fixnum loc obj)
     187  (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
     188
     189(define (error-type-cardinal-fixnum loc obj)
     190  (##sys#signal-hook #:type-error loc "bad argument type - not a cardinal fixnum" obj) )
     191
     192(define (error-type-radix loc radix)
     193  (##sys#signal-hook #:type-error loc "bad argument type - invalid radix" radix) )
     194
     195(define (error-outside-range loc obj low high)
     196  (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
     197
     198(define (error-zero-division loc fx1 fx2)
     199  (##sys#signal-hook #:arithmetic-error loc "division by zero" fx1 fx2) )
     200
     201(define (error-fixnum-representation loc fx1 fx2)
     202  (##sys#signal-hook #:arithmetic-error loc "results not representable as fixnums" fx1 fx2) )
     203
     204(define (error-bounds-order loc start end)
     205  (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
     206
     207(define (error-bits-count loc count start end)
     208  (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
     209
     210;;; Constants
     211
     212(define *fixnum-negated-precision* (%fxneg fixnum-precision))
    202213
    203214;;; Procedures wrapping primitive-inlines for fold operations
     
    218229(define (*fx/ x y) (%fx/ x y))
    219230
    220 
    221 ;;; Used by '%' inlines.
    222 
    223 (define *fixnum-negated-precision* (%fxneg fixnum-precision))
    224 
    225 
    226231;;;
    227232
     
    229234(define (least-fixnum) most-negative-fixnum)
    230235(define (greatest-fixnum) most-positive-fixnum)
    231 
    232236
    233237;;;
     
    257261          (loop (%cdr fxs) (%fxmax mx cur) (%fxmin mn cur)) ) ) ) )
    258262
    259 
    260263;;;
    261264
     
    279282  (%check-fixnum 'fxeven? fx)
    280283  (%fxeven? fx) )
    281 
    282284
    283285;;;
     
    305307  (let ((d (%fxdiv0 fxn fxd)))
    306308    (if (%fixnum? d) d
    307         (%error-fixnum-representation 'fxdiv0 fxn fxd) ) ) )
     309        (error-fixnum-representation 'fxdiv0 fxn fxd) ) ) )
    308310
    309311(define (fxmod0 fxn fxd)
     
    313315  (let ((m (%fxmod0 fxn fxd)))
    314316    (if (%fixnum? m) m
    315         (%error-fixnum-representation 'fxmod0 fxn fxd) ) ) )
     317        (error-fixnum-representation 'fxmod0 fxn fxd) ) ) )
    316318
    317319(define (fxdiv0-and-mod0 fxn fxd)
     
    321323  (let-values (((d m) (%fxdiv0-and-mod0 fxn fxd)))
    322324    (if (and (%fixnum? d) (%fixnum? m)) (values d m)
    323         (%error-fixnum-representation 'fxdiv0-and-mod0 fxn fxd) ) ) )
     325        (error-fixnum-representation 'fxdiv0-and-mod0 fxn fxd) ) ) )
    324326
    325327(define (fx*/carry fx1 fx2 fx3)
     
    393395        (%fx- fx fx2) ) ) )
    394396
    395 
    396397;;;
    397398
     
    399400(define (fxior fx . fxs) (%fxfold 'fxior *fxior fx fxs))
    400401(define (fxxor fx . fxs) (%fxfold 'fxxor *fxxor fx fxs))
    401 
    402402
    403403;;;
     
    458458  (%check-bits-range 'fxreverse-bit-field start end)
    459459  (*bitwise-reverse-bit-field fx start end) )
    460 
    461460
    462461;;; Extras
     
    492491          (fx->str fx))
    493492        (else
    494           (%error-invalid-radix 'fixnum->string radix) ) ) ) ) )
     493          (error-type-radix 'fixnum->string radix) ) ) ) ) )
    495494
    496495;;
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r13706 r13716  
    11;;;; err5rs-arithmetic-flonums.scm
    22;;;; Kon Lovett, Mar '09
    3 
    43
    54;;; Prelude
     
    2019;;
    2120
    22 (require-library srfi-1 mathh)
    23 
    2421(include "chicken-primitive-object-inlines")
    2522
    2623;;
    2724
    28 (define-inline (%check-fixnum loc obj) (##sys#check-exact obj loc))
    29 
    30 (define-inline (%check-flonum loc obj) (##sys#check-inexact obj loc))
    31 
    32 (define-inline (%check-not-negative loc obj)
    33   (unless (%<= 0 obj)
    34     (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a cardinal number") obj) ) )
    35 
    36 (define-inline (%check-real loc obj)
    37   (unless (real? obj)
    38     (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a real") obj) ) )
     25(define-inline (%check-fixnum loc obj) (unless (%fixnum? obj) (error-type-fixnum loc obj)))
     26
     27(define-inline (%check-flonum loc obj) (unless (%flonum? obj) (error-type-flonum loc obj)))
     28
     29(define-inline (%check-cardinal loc obj) (unless (%<= 0 obj) (error-type-cardinal loc obj)))
     30
     31(define-inline (%check-real loc obj) (unless (real? obj) (error-type-real loc obj)))
    3932
    4033;;
     
    118111           (%fp+ rem fpd) ) ) ) )
    119112
    120 
    121113;;;
     114
     115(require-library srfi-1 mathh)
    122116
    123117(module err5rs-arithmetic-flonums (;export
     
    141135(import scheme chicken foreign srfi-1 mathh)
    142136
     137;;; Errors
     138
     139(define (error-type-fixnum loc obj)
     140  (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
     141
     142(define (error-type-flonum loc obj)
     143  (##sys#signal-hook #:type-error loc "bad argument type - not a flonum" obj) )
     144
     145(define (error-type-real loc obj)
     146  (##sys#signal-hook #:type-error loc "bad argument type - not a real" obj) )
     147
     148(define (error-type-cardinal loc obj)
     149  (##sys#signal-hook #:type-error loc "bad argument type - not a cardinal" obj) )
    143150
    144151;;; Procedures wrapping primitive-inlines for fold operations
     
    156163(define (*fp/ x y) (%fp/ x y))
    157164
    158 
    159165;;;
    160166
     
    169175  (%check-fixnum 'fixnum->flonum fx)
    170176  (%exact->inexact fx) )
    171 
    172177
    173178;;;
     
    214219          (loop (%cdr ls) (%fpmax mx cur) (%fpmin mn cur)) ) ) ) )
    215220
    216 
    217221;;;
    218222
     
    252256  (%check-flonum 'flnan? fp)
    253257  (%fpnan? fp) )
    254 
    255258
    256259;;;
     
    340343  (if (not base) (%fplog fp)
    341344      (begin
    342         (%check-not-negative 'fllog base)
     345        (%check-cardinal 'fllog base)
    343346        ((log/base base) fp) ) ) )
    344347
Note: See TracChangeset for help on using the changeset viewer.