Changeset 13719 in project


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

Moved errors into module.

Location:
release/4/stack
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/stack/tags/2.0.0/chicken-primitive-object-inlines.scm

    r13701 r13719  
    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/stack/tags/2.0.0/stack.scm

    r13692 r13719  
    88;;
    99;; - All operations inlined & primitive due to high-performance nature.
     10
     11;;; Prelude
    1012
    1113(declare
     
    1719  (no-procedure-checks)
    1820  (bound-to-procedure
    19     ##sys#signal-hook
    20     ##sys#check-range
    21     ##sys#check-list
    22     ##sys#check-exact) )
    23 
    24 ;;;
     21    ##sys#signal-hook ) )
     22
     23;;
    2524
    2625(include "chicken-primitive-object-inlines")
    2726
    28 
    29 ;;; Stack Support
     27;; Stack Support
    3028
    3129(define-inline (%make-stack) (%make-structure 'stack '() 0))
    3230
    33 (define-inline (%stack? obj)
    34   (and (%structure-instance? obj 'stack) (%fx= 3 (%structure-length obj))))
     31(define-inline (%stack? obj) (%structure-instance? obj 'stack))
    3532
    3633;; Stack List
    3734
    3835(define-inline (%stack-list stk) (%structure-ref stk 1))
     36
     37(define-inline (%valid-stack? obj)
     38  (and #;(%structure-instance? obj 'stack) (%fx= 3 (%structure-length obj)
     39       (%list? (%stack-list obj)) ) )
    3940
    4041(define-inline (%stack-list-empty? stk) (%null? (%stack-list stk)))
     
    7980  (let ((pr (%list-pair-ref (%stack-list stk) idx)))
    8081                (if (%pair? pr) pr
    81                           (##sys#signal-hook #:bounds-error loc (##core#immutable '"out of range") idx 0 (%stack-count stk)) ) ) )
    82 
    83 
    84 ;;; Helpers
    85 
    86 (define-inline (%check-index loc obj from to) (##sys#check-range obj from to loc))
     82                          (error-outside-range loc idx 0 (%stack-count stk)) ) ) )
     83
     84;; Helpers
     85
     86(define-inline (%check-fixnum loc obj) (unless (%fixnum? obj) (error-type-fixnum loc obj)))
    8787
    8888(define-inline (%check-stack loc obj)
    89         (unless (%stack? obj)
    90           (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a stack") obj) ) )
    91 
    92 (define-inline (%check-list loc obj) (##sys#check-list obj loc))
    93 
    94 (define-inline (%check-stack-underflow loc stk)
    95         (when (%stack-empty? stk)
    96           (##sys#signal-hook #:limit-error loc (##core#immutable '"stack underflow") stk) ) )
    97 
    98 (define-inline (%check-exact loc obj) (##sys#check-exact obj loc))
    99 
     89  (unless (%stack? obj) (error-type-stack loc obj))
     90  (unless (%valid-stack? obj) (error-corrupted-stack loc obj)) )
     91
     92(define-inline (%check-list loc obj) (unless (%list? obj) (error-type-list obj loc)))
     93
     94(define-inline (%check-stack-underflow loc stk) (when (%stack-empty? stk) (error-stack-underflow loc stk)))
     95
     96(define-inline (%check-fixnum-index loc lfx fx hfx) (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx)))
    10097
    10198;;;
     99
     100(require-library ports)
    102101
    103102(module stack (;export
     
    128127    with-output-to-port) )
    129128
     129;;;
     130
     131(define (error-type-fixnum loc obj)
     132  (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
     133
     134(define (error-type-list loc obj)
     135  (##sys#signal-hook #:type-error loc "bad argument type - not a list" obj) )
     136
     137(define (error-type-stack loc obj)
     138  (##sys#signal-hook #:type-error loc "bad argument type - not a stack" obj)
     139
     140(define (error-corrupted-stack loc obj)
     141  (##sys#signal-hook #:runtime-error loc "stack corrupted" obj) )
     142
     143(define (error-stack-underflow loc stk)
     144  (##sys#signal-hook #:limit-error loc "stack underflow" stk) )
     145
     146(define-inline (error-outside-range loc obj low high)
     147  (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
     148
     149;;;
     150
    130151(define (make-stack) (%make-stack))
    131152
     
    165186(define (stack-cut! stk start #!optional (end (%stack-count stk)))
    166187  (%check-stack 'stack-cut! stk)
    167   (%check-exact 'stack-cut! start)
    168   (%check-exact 'stack-cut! end)
    169   (%check-index 'stack-cut! start 0 end)
    170   (%check-index 'stack-cut! end start (%fx+ (%stack-count stk) 1))
     188  (%check-fixnum 'stack-cut! start)
     189  (%check-fixnum 'stack-cut! end)
     190  (%check-fixnum-index 'stack-cut! start 0 end)
     191  (%check-fixnum-index 'stack-cut! end start (%fx+ (%stack-count stk) 1))
    171192  (let ((cnt (%fx- end start)))
    172193    (%stack-count-dec! stk cnt)
  • release/4/stack/trunk/chicken-primitive-object-inlines.scm

    r13701 r13719  
    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/stack/trunk/stack.scm

    r13692 r13719  
    88;;
    99;; - All operations inlined & primitive due to high-performance nature.
     10
     11;;; Prelude
    1012
    1113(declare
     
    1719  (no-procedure-checks)
    1820  (bound-to-procedure
    19     ##sys#signal-hook
    20     ##sys#check-range
    21     ##sys#check-list
    22     ##sys#check-exact) )
    23 
    24 ;;;
     21    ##sys#signal-hook ) )
     22
     23;;
    2524
    2625(include "chicken-primitive-object-inlines")
    2726
    28 
    29 ;;; Stack Support
     27;; Stack Support
    3028
    3129(define-inline (%make-stack) (%make-structure 'stack '() 0))
    3230
    33 (define-inline (%stack? obj)
    34   (and (%structure-instance? obj 'stack) (%fx= 3 (%structure-length obj))))
     31(define-inline (%stack? obj) (%structure-instance? obj 'stack))
    3532
    3633;; Stack List
    3734
    3835(define-inline (%stack-list stk) (%structure-ref stk 1))
     36
     37(define-inline (%valid-stack? obj)
     38  (and #;(%structure-instance? obj 'stack) (%fx= 3 (%structure-length obj)
     39       (%list? (%stack-list obj)) ) )
    3940
    4041(define-inline (%stack-list-empty? stk) (%null? (%stack-list stk)))
     
    7980  (let ((pr (%list-pair-ref (%stack-list stk) idx)))
    8081                (if (%pair? pr) pr
    81                           (##sys#signal-hook #:bounds-error loc (##core#immutable '"out of range") idx 0 (%stack-count stk)) ) ) )
    82 
    83 
    84 ;;; Helpers
    85 
    86 (define-inline (%check-index loc obj from to) (##sys#check-range obj from to loc))
     82                          (error-outside-range loc idx 0 (%stack-count stk)) ) ) )
     83
     84;; Helpers
     85
     86(define-inline (%check-fixnum loc obj) (unless (%fixnum? obj) (error-type-fixnum loc obj)))
    8787
    8888(define-inline (%check-stack loc obj)
    89         (unless (%stack? obj)
    90           (##sys#signal-hook #:type-error loc (##core#immutable '"bad argument type - not a stack") obj) ) )
    91 
    92 (define-inline (%check-list loc obj) (##sys#check-list obj loc))
    93 
    94 (define-inline (%check-stack-underflow loc stk)
    95         (when (%stack-empty? stk)
    96           (##sys#signal-hook #:limit-error loc (##core#immutable '"stack underflow") stk) ) )
    97 
    98 (define-inline (%check-exact loc obj) (##sys#check-exact obj loc))
    99 
     89  (unless (%stack? obj) (error-type-stack loc obj))
     90  (unless (%valid-stack? obj) (error-corrupted-stack loc obj)) )
     91
     92(define-inline (%check-list loc obj) (unless (%list? obj) (error-type-list obj loc)))
     93
     94(define-inline (%check-stack-underflow loc stk) (when (%stack-empty? stk) (error-stack-underflow loc stk)))
     95
     96(define-inline (%check-fixnum-index loc lfx fx hfx) (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx)))
    10097
    10198;;;
     99
     100(require-library ports)
    102101
    103102(module stack (;export
     
    128127    with-output-to-port) )
    129128
     129;;;
     130
     131(define (error-type-fixnum loc obj)
     132  (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
     133
     134(define (error-type-list loc obj)
     135  (##sys#signal-hook #:type-error loc "bad argument type - not a list" obj) )
     136
     137(define (error-type-stack loc obj)
     138  (##sys#signal-hook #:type-error loc "bad argument type - not a stack" obj)
     139
     140(define (error-corrupted-stack loc obj)
     141  (##sys#signal-hook #:runtime-error loc "stack corrupted" obj) )
     142
     143(define (error-stack-underflow loc stk)
     144  (##sys#signal-hook #:limit-error loc "stack underflow" stk) )
     145
     146(define-inline (error-outside-range loc obj low high)
     147  (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
     148
     149;;;
     150
    130151(define (make-stack) (%make-stack))
    131152
     
    165186(define (stack-cut! stk start #!optional (end (%stack-count stk)))
    166187  (%check-stack 'stack-cut! stk)
    167   (%check-exact 'stack-cut! start)
    168   (%check-exact 'stack-cut! end)
    169   (%check-index 'stack-cut! start 0 end)
    170   (%check-index 'stack-cut! end start (%fx+ (%stack-count stk) 1))
     188  (%check-fixnum 'stack-cut! start)
     189  (%check-fixnum 'stack-cut! end)
     190  (%check-fixnum-index 'stack-cut! start 0 end)
     191  (%check-fixnum-index 'stack-cut! end start (%fx+ (%stack-count stk) 1))
    171192  (let ((cnt (%fx- end start)))
    172193    (%stack-count-dec! stk cnt)
Note: See TracChangeset for help on using the changeset viewer.