Changeset 13717 in project


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

Moved errors into module.

Location:
release/4/box
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/box/tags/2.0.0/box.scm

    r13696 r13717  
    77;;
    88;; - Note that 'procedure-data' returns #f for anything other than an extended-procedure.
     9
     10;;; Prelude
    911
    1012(declare
     
    1820  (bound-to-procedure
    1921    ##sys#signal-hook
    20     ##sys#procedure->string))
    21 
    22 ;;; Prelude
    23 
    24 (require-library ports lolevel)
     22    ##sys#procedure->string ) )
    2523
    2624(include "chicken-primitive-object-inlines")
     
    108106(define-inline (%box? obj) (or (%box-structure? obj) (%box-procedure? obj)))
    109107
    110 ;;; Errors
    111 
    112 (define-inline (%box-immutable-error loc box . args)
    113   (apply ##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a mutable box") box args))
    114 
    115 (define-inline (%box-type-error loc obj . args)
    116   (apply ##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a box") obj args))
    117 
    118 
    119 ;;; Print
     108;; Print
    120109
    121110(define-inline (%box-print box)
     
    123112                   ((%box-procedure? box)  (%box-procedure-ref box))
    124113                   (else
    125                     (%box-type-error 'box-print box)))))
     114                    (error-box-type 'box-print box)))))
    126115          (display "#&") (write val)))
    127116
    128117
    129118;;; Module box
     119
     120(require-library ports lolevel)
    130121
    131122(module box (;export
     
    162153;;; Internals
    163154
     155;; Errors
     156
     157(define-inline (error-box-immutable loc box . args)
     158  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args))
     159
     160(define-inline (error-box-type loc obj . args)
     161  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args))
     162
    164163;; Finishers
    165164
     
    220219           (case tag
    221220             ((box!) (%box-structure-set! box val))
    222              ((box)  (%box-immutable-error 'box-set! box val)))))
     221             ((box)  (error-box-immutable 'box-set! box val)))))
    223222        ((%box-procedure-tag box) =>
    224223         (lambda (tag)
    225224           (case tag
    226225             ((boxvar! boxloc!) (%box-procedure-set! box val))
    227              ((boxvar boxloc)   (%box-immutable-error 'box-set! box val)))))
     226             ((boxvar boxloc)   (error-box-immutable 'box-set! box val)))))
    228227        (else
    229          (%box-type-error 'box-set! box val))))
     228         (error-box-type 'box-set! box val))))
    230229
    231230;; Assessors
     
    236235      (cond ((%box-structure? box)  (%box-structure-ref box))
    237236            ((%box-procedure? box)  (%box-procedure-ref box))
    238             (else                   (%box-type-error 'box-ref box))))
     237            (else                   (error-box-type 'box-ref box))))
    239238    box-set!))
    240239
     
    242241  (cond ((%box-structure? box)   ((if weak? make-weak-locative make-locative) box 1))
    243242        ((%box-procedure? box)   (box (lambda (ref set loc) (loc))))
    244         (else                    (%box-type-error 'box-location box))))
     243        (else                    (error-box-type 'box-location box))))
    245244
    246245
  • release/4/box/tags/2.0.0/chicken-primitive-object-inlines.scm

    r13696 r13717  
    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
     
    284277(define-inline (%fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))
    285278
    286 (define-inline (%fxclosed-right? l x h) (and (%< l obj) (%fx<= obj h)))
    287 (define-inline (%fxclosed? l x h) (and (%<= l obj) (%fx<= obj h)))
    288 (define-inline (%fxclosed-left? l x h) (and (%<= l obj) (%fx< obj h)))
     279(define-inline (%fxclosed-right? l x h) (and (%< l x) (%fx<= x h)))
     280(define-inline (%fxclosed? l x h) (and (%<= l x) (%fx<= x h)))
     281(define-inline (%fxclosed-left? l x h) (and (%<= l x) (%fx< x h)))
    289282
    290283(define-inline (%fxzero? fx) (%fx= 0 fx))
     
    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
     
    436433;Unsafe
    437434
    438 (define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))
    439 
    440435(define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y))
    441436(define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y))
     
    456451(define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x))
    457452
    458 (define-inline (%fpnegate x y) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x y))
     453(define-inline (%fpnegate x) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x))
    459454
    460455(define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x))
     
    472467(define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
    473468(define-inline (%fpatan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
    474 (define-inline (%fpatan2 x) (##core#inline_allocate ("C_a_i_atan2" 4) x))
     469(define-inline (%fpatan2 x y) (##core#inline_allocate ("C_a_i_atan2" 4) x y))
    475470(define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
    476471(define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
     
    953948(define-inline (%asin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
    954949(define-inline (%atan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
    955 (define-inline (%atan2 x) (##core#inline_allocate ("C_a_i_atan2" 4) x))
     950(define-inline (%atan2 x y) (##core#inline_allocate ("C_a_i_atan2" 4) x y))
    956951(define-inline (%cos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
    957952(define-inline (%exp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
     
    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/box/trunk/box.scm

    r13696 r13717  
    77;;
    88;; - Note that 'procedure-data' returns #f for anything other than an extended-procedure.
     9
     10;;; Prelude
    911
    1012(declare
     
    2022    ##sys#procedure->string ) )
    2123
    22 ;;; Prelude
    23 
    24 (require-library ports lolevel)
    25 
    2624(include "chicken-primitive-object-inlines")
    2725
     
    108106(define-inline (%box? obj) (or (%box-structure? obj) (%box-procedure? obj)))
    109107
    110 ;;; Errors
    111 
    112 (define-inline (%box-immutable-error loc box . args)
    113   (apply ##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a mutable box") box args))
    114 
    115 (define-inline (%box-type-error loc obj . args)
    116   (apply ##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a box") obj args))
    117 
    118 
    119 ;;; Print
     108;; Print
    120109
    121110(define-inline (%box-print box)
     
    123112                   ((%box-procedure? box)  (%box-procedure-ref box))
    124113                   (else
    125                     (%box-type-error 'box-print box)))))
     114                    (error-box-type 'box-print box)))))
    126115          (display "#&") (write val)))
    127116
    128117
    129118;;; Module box
     119
     120(require-library ports lolevel)
    130121
    131122(module box (;export
     
    162153;;; Internals
    163154
     155;; Errors
     156
     157(define-inline (error-box-immutable loc box . args)
     158  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args))
     159
     160(define-inline (error-box-type loc obj . args)
     161  (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args))
     162
    164163;; Finishers
    165164
     
    220219           (case tag
    221220             ((box!) (%box-structure-set! box val))
    222              ((box)  (%box-immutable-error 'box-set! box val)))))
     221             ((box)  (error-box-immutable 'box-set! box val)))))
    223222        ((%box-procedure-tag box) =>
    224223         (lambda (tag)
    225224           (case tag
    226225             ((boxvar! boxloc!) (%box-procedure-set! box val))
    227              ((boxvar boxloc)   (%box-immutable-error 'box-set! box val)))))
     226             ((boxvar boxloc)   (error-box-immutable 'box-set! box val)))))
    228227        (else
    229          (%box-type-error 'box-set! box val))))
     228         (error-box-type 'box-set! box val))))
    230229
    231230;; Assessors
     
    236235      (cond ((%box-structure? box)  (%box-structure-ref box))
    237236            ((%box-procedure? box)  (%box-procedure-ref box))
    238             (else                   (%box-type-error 'box-ref box))))
     237            (else                   (error-box-type 'box-ref box))))
    239238    box-set!))
    240239
     
    242241  (cond ((%box-structure? box)   ((if weak? make-weak-locative make-locative) box 1))
    243242        ((%box-procedure? box)   (box (lambda (ref set loc) (loc))))
    244         (else                    (%box-type-error 'box-location box))))
     243        (else                    (error-box-type 'box-location box))))
    245244
    246245
  • release/4/box/trunk/chicken-primitive-object-inlines.scm

    r13696 r13717  
    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
     
    284277(define-inline (%fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))
    285278
    286 (define-inline (%fxclosed-right? l x h) (and (%< l obj) (%fx<= obj h)))
    287 (define-inline (%fxclosed? l x h) (and (%<= l obj) (%fx<= obj h)))
    288 (define-inline (%fxclosed-left? l x h) (and (%<= l obj) (%fx< obj h)))
     279(define-inline (%fxclosed-right? l x h) (and (%< l x) (%fx<= x h)))
     280(define-inline (%fxclosed? l x h) (and (%<= l x) (%fx<= x h)))
     281(define-inline (%fxclosed-left? l x h) (and (%<= l x) (%fx< x h)))
    289282
    290283(define-inline (%fxzero? fx) (%fx= 0 fx))
     
    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
     
    436433;Unsafe
    437434
    438 (define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))
    439 
    440435(define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y))
    441436(define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y))
     
    456451(define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x))
    457452
    458 (define-inline (%fpnegate x y) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x y))
     453(define-inline (%fpnegate x) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x))
    459454
    460455(define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x))
     
    472467(define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
    473468(define-inline (%fpatan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
    474 (define-inline (%fpatan2 x) (##core#inline_allocate ("C_a_i_atan2" 4) x))
     469(define-inline (%fpatan2 x y) (##core#inline_allocate ("C_a_i_atan2" 4) x y))
    475470(define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
    476471(define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
     
    953948(define-inline (%asin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
    954949(define-inline (%atan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
    955 (define-inline (%atan2 x) (##core#inline_allocate ("C_a_i_atan2" 4) x))
     950(define-inline (%atan2 x y) (##core#inline_allocate ("C_a_i_atan2" 4) x y))
    956951(define-inline (%cos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
    957952(define-inline (%exp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
     
    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) '#()))
Note: See TracChangeset for help on using the changeset viewer.