Changeset 13717 in project
- Timestamp:
- 03/12/09 19:11:04 (11 years ago)
- Location:
- release/4/box
- Files:
-
- 4 edited
-
tags/2.0.0/box.scm (modified) (8 diffs)
-
tags/2.0.0/chicken-primitive-object-inlines.scm (modified) (11 diffs)
-
trunk/box.scm (modified) (8 diffs)
-
trunk/chicken-primitive-object-inlines.scm (modified) (11 diffs)
Legend:
- Unmodified
- Added
- Removed
-
release/4/box/tags/2.0.0/box.scm
r13696 r13717 7 7 ;; 8 8 ;; - Note that 'procedure-data' returns #f for anything other than an extended-procedure. 9 10 ;;; Prelude 9 11 10 12 (declare … … 18 20 (bound-to-procedure 19 21 ##sys#signal-hook 20 ##sys#procedure->string)) 21 22 ;;; Prelude 23 24 (require-library ports lolevel) 22 ##sys#procedure->string ) ) 25 23 26 24 (include "chicken-primitive-object-inlines") … … 108 106 (define-inline (%box? obj) (or (%box-structure? obj) (%box-procedure? obj))) 109 107 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 120 109 121 110 (define-inline (%box-print box) … … 123 112 ((%box-procedure? box) (%box-procedure-ref box)) 124 113 (else 125 ( %box-type-error'box-print box)))))114 (error-box-type 'box-print box))))) 126 115 (display "#&") (write val))) 127 116 128 117 129 118 ;;; Module box 119 120 (require-library ports lolevel) 130 121 131 122 (module box (;export … … 162 153 ;;; Internals 163 154 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 164 163 ;; Finishers 165 164 … … 220 219 (case tag 221 220 ((box!) (%box-structure-set! box val)) 222 ((box) ( %box-immutable-error'box-set! box val)))))221 ((box) (error-box-immutable 'box-set! box val))))) 223 222 ((%box-procedure-tag box) => 224 223 (lambda (tag) 225 224 (case tag 226 225 ((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))))) 228 227 (else 229 ( %box-type-error'box-set! box val))))228 (error-box-type 'box-set! box val)))) 230 229 231 230 ;; Assessors … … 236 235 (cond ((%box-structure? box) (%box-structure-ref box)) 237 236 ((%box-procedure? box) (%box-procedure-ref box)) 238 (else ( %box-type-error'box-ref box))))237 (else (error-box-type 'box-ref box)))) 239 238 box-set!)) 240 239 … … 242 241 (cond ((%box-structure? box) ((if weak? make-weak-locative make-locative) box 1)) 243 242 ((%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)))) 245 244 246 245 -
release/4/box/tags/2.0.0/chicken-primitive-object-inlines.scm
r13696 r13717 34 34 ;; k - continuation 35 35 36 37 36 ;;; Unsafe Type Predicates 38 37 … … 134 133 (define-inline (%locative-type? x) (##core#inline "C_locativep" x)) 135 134 136 137 135 ;;; Safe Type Predicates 138 136 … … 259 257 (define-inline (%forwarded? x) (##core#inline "C_forwardedp" x)) 260 258 261 262 259 ;;; Operations 263 260 … … 265 262 266 263 (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))271 264 272 265 ;; Fixnum … … 284 277 (define-inline (%fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y)) 285 278 286 (define-inline (%fxclosed-right? l x h) (and (%< l obj) (%fx<= objh)))287 (define-inline (%fxclosed? l x h) (and (%<= l obj) (%fx<= objh)))288 (define-inline (%fxclosed-left? l x h) (and (%<= l obj) (%fx< objh)))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))) 289 282 290 283 (define-inline (%fxzero? fx) (%fx= 0 fx)) … … 320 313 ;; Block 321 314 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 322 319 ;Safe 323 320 … … 436 433 ;Unsafe 437 434 438 (define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))439 440 435 (define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y)) 441 436 (define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y)) … … 456 451 (define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x)) 457 452 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)) 459 454 460 455 (define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x)) … … 472 467 (define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x)) 473 468 (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)) 475 470 (define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x)) 476 471 (define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x)) … … 953 948 (define-inline (%asin x) (##core#inline_allocate ("C_a_i_asin" 4) x)) 954 949 (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)) 956 951 (define-inline (%cos x) (##core#inline_allocate ("C_a_i_cos" 4) x)) 957 952 (define-inline (%exp x) (##core#inline_allocate ("C_a_i_exp" 4) x)) … … 971 966 972 967 (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 7 7 ;; 8 8 ;; - Note that 'procedure-data' returns #f for anything other than an extended-procedure. 9 10 ;;; Prelude 9 11 10 12 (declare … … 20 22 ##sys#procedure->string ) ) 21 23 22 ;;; Prelude23 24 (require-library ports lolevel)25 26 24 (include "chicken-primitive-object-inlines") 27 25 … … 108 106 (define-inline (%box? obj) (or (%box-structure? obj) (%box-procedure? obj))) 109 107 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 120 109 121 110 (define-inline (%box-print box) … … 123 112 ((%box-procedure? box) (%box-procedure-ref box)) 124 113 (else 125 ( %box-type-error'box-print box)))))114 (error-box-type 'box-print box))))) 126 115 (display "#&") (write val))) 127 116 128 117 129 118 ;;; Module box 119 120 (require-library ports lolevel) 130 121 131 122 (module box (;export … … 162 153 ;;; Internals 163 154 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 164 163 ;; Finishers 165 164 … … 220 219 (case tag 221 220 ((box!) (%box-structure-set! box val)) 222 ((box) ( %box-immutable-error'box-set! box val)))))221 ((box) (error-box-immutable 'box-set! box val))))) 223 222 ((%box-procedure-tag box) => 224 223 (lambda (tag) 225 224 (case tag 226 225 ((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))))) 228 227 (else 229 ( %box-type-error'box-set! box val))))228 (error-box-type 'box-set! box val)))) 230 229 231 230 ;; Assessors … … 236 235 (cond ((%box-structure? box) (%box-structure-ref box)) 237 236 ((%box-procedure? box) (%box-procedure-ref box)) 238 (else ( %box-type-error'box-ref box))))237 (else (error-box-type 'box-ref box)))) 239 238 box-set!)) 240 239 … … 242 241 (cond ((%box-structure? box) ((if weak? make-weak-locative make-locative) box 1)) 243 242 ((%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)))) 245 244 246 245 -
release/4/box/trunk/chicken-primitive-object-inlines.scm
r13696 r13717 34 34 ;; k - continuation 35 35 36 37 36 ;;; Unsafe Type Predicates 38 37 … … 134 133 (define-inline (%locative-type? x) (##core#inline "C_locativep" x)) 135 134 136 137 135 ;;; Safe Type Predicates 138 136 … … 259 257 (define-inline (%forwarded? x) (##core#inline "C_forwardedp" x)) 260 258 261 262 259 ;;; Operations 263 260 … … 265 262 266 263 (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))271 264 272 265 ;; Fixnum … … 284 277 (define-inline (%fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y)) 285 278 286 (define-inline (%fxclosed-right? l x h) (and (%< l obj) (%fx<= objh)))287 (define-inline (%fxclosed? l x h) (and (%<= l obj) (%fx<= objh)))288 (define-inline (%fxclosed-left? l x h) (and (%<= l obj) (%fx< objh)))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))) 289 282 290 283 (define-inline (%fxzero? fx) (%fx= 0 fx)) … … 320 313 ;; Block 321 314 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 322 319 ;Safe 323 320 … … 436 433 ;Unsafe 437 434 438 (define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))439 440 435 (define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y)) 441 436 (define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y)) … … 456 451 (define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x)) 457 452 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)) 459 454 460 455 (define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x)) … … 472 467 (define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x)) 473 468 (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)) 475 470 (define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x)) 476 471 (define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x)) … … 953 948 (define-inline (%asin x) (##core#inline_allocate ("C_a_i_asin" 4) x)) 954 949 (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)) 956 951 (define-inline (%cos x) (##core#inline_allocate ("C_a_i_cos" 4) x)) 957 952 (define-inline (%exp x) (##core#inline_allocate ("C_a_i_exp" 4) x)) … … 971 966 972 967 (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.
