Changeset 14189 in project


Ignore:
Timestamp:
04/08/09 18:56:18 (11 years ago)
Author:
Kon Lovett
Message:

Update.

Location:
release/4/box
Files:
5 edited
6 copied

Legend:

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

    r14077 r14189  
    690690      (loop (%cdr ls)) ) ) )
    691691
     692(define-inline (%list/1 obj) (%cons obj '()))
     693
     694(define-inline (%list . objs)
     695  (let loop ((objs objs))
     696    (if (%null? objs) '()
     697        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     698
    692699(define-inline (%make-list n e)
    693700  (let loop ((n n) (ls '()))
     
    704711    (if (%fxzero? n) ls
    705712        (loop (%cdr ls) (%fxsub1 n)) ) ) )
     713
     714(define-inline (%any/1 pred? ls)
     715  (let loop ((ls ls))
     716    (and (not (%null? ls))
     717         (or (pred? (%car ls))
     718             (loop (%cdr ls)) ) ) ) )
     719
     720(define-inline (%list-length ls0)
     721  (let loop ((ls ls0) (n 0))
     722    (if (%null? ls) n
     723        (loop (%cdr ls) (%fxadd1 n)) ) ) )
    706724
    707725;; Structure (wordblock)
     
    738756
    739757(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    740 (define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
    741 (define-inline (%port-class port) (%wordblock-ref? port 2))
    742 (define-inline (%port-name port) (%wordblock-ref? port 3))
    743 (define-inline (%port-row port) (%wordblock-ref? port 4))
    744 (define-inline (%port-column port) (%wordblock-ref? port 5))
    745 (define-inline (%port-eof? port) (%wordblock-ref? port 6))
    746 (define-inline (%port-type port) (%wordblock-ref? port 7))
    747 (define-inline (%port-closed? port) (%wordblock-ref? port 8))
    748 (define-inline (%port-data port) (%wordblock-ref? port 9))
    749 
    750 (define-inline (%input-port? x) (and (%port x) (%port-input-mode? x)))
    751 (define-inline (%output-port? x) (and (%port x) (not (%port-input-mode? x))))
     758(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
     759(define-inline (%port-class port) (%wordblock-ref port 2))
     760(define-inline (%port-name port) (%wordblock-ref port 3))
     761(define-inline (%port-row port) (%wordblock-ref port 4))
     762(define-inline (%port-column port) (%wordblock-ref port 5))
     763(define-inline (%port-eof? port) (%wordblock-ref port 6))
     764(define-inline (%port-type port) (%wordblock-ref port 7))
     765(define-inline (%port-closed? port) (%wordblock-ref port 8))
     766(define-inline (%port-data port) (%wordblock-ref port 9))
     767
     768(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
     769(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
    752770
    753771(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
  • release/4/box/tags/2.1.0/chicken-primitive-object-inlines.scm

    r14077 r14189  
    690690      (loop (%cdr ls)) ) ) )
    691691
     692(define-inline (%list/1 obj) (%cons obj '()))
     693
     694(define-inline (%list . objs)
     695  (let loop ((objs objs))
     696    (if (%null? objs) '()
     697        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     698
    692699(define-inline (%make-list n e)
    693700  (let loop ((n n) (ls '()))
     
    704711    (if (%fxzero? n) ls
    705712        (loop (%cdr ls) (%fxsub1 n)) ) ) )
     713
     714(define-inline (%any/1 pred? ls)
     715  (let loop ((ls ls))
     716    (and (not (%null? ls))
     717         (or (pred? (%car ls))
     718             (loop (%cdr ls)) ) ) ) )
     719
     720(define-inline (%list-length ls0)
     721  (let loop ((ls ls0) (n 0))
     722    (if (%null? ls) n
     723        (loop (%cdr ls) (%fxadd1 n)) ) ) )
    706724
    707725;; Structure (wordblock)
     
    738756
    739757(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    740 (define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
    741 (define-inline (%port-class port) (%wordblock-ref? port 2))
    742 (define-inline (%port-name port) (%wordblock-ref? port 3))
    743 (define-inline (%port-row port) (%wordblock-ref? port 4))
    744 (define-inline (%port-column port) (%wordblock-ref? port 5))
    745 (define-inline (%port-eof? port) (%wordblock-ref? port 6))
    746 (define-inline (%port-type port) (%wordblock-ref? port 7))
    747 (define-inline (%port-closed? port) (%wordblock-ref? port 8))
    748 (define-inline (%port-data port) (%wordblock-ref? port 9))
    749 
    750 (define-inline (%input-port? x) (and (%port x) (%port-input-mode? x)))
    751 (define-inline (%output-port? x) (and (%port x) (not (%port-input-mode? x))))
     758(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
     759(define-inline (%port-class port) (%wordblock-ref port 2))
     760(define-inline (%port-name port) (%wordblock-ref port 3))
     761(define-inline (%port-row port) (%wordblock-ref port 4))
     762(define-inline (%port-column port) (%wordblock-ref port 5))
     763(define-inline (%port-eof? port) (%wordblock-ref port 6))
     764(define-inline (%port-type port) (%wordblock-ref port 7))
     765(define-inline (%port-closed? port) (%wordblock-ref port 8))
     766(define-inline (%port-data port) (%wordblock-ref port 9))
     767
     768(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
     769(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
    752770
    753771(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
  • release/4/box/tags/2.2.0/box.meta

    r14185 r14189  
    77 (doc-from-wiki #t)
    88 (author "[[kon lovett]]")
    9  (needs setup-helper)
     9 (needs check-errors setup-helper)
    1010 (files
    1111  "chicken-primitive-object-inlines.scm"
  • release/4/box/tags/2.2.0/box.scm

    r14185 r14189  
    107107                   ((%box-procedure? box)  (%box-procedure-ref box))
    108108                   (else
    109                     (error-box-type 'box-print box)))))
     109                    (error-box 'box-print box)))))
    110110          (display "#&") (write val)))
    111111
    112112
    113113;;; Module box
    114 
    115 (require-library ports lolevel)
    116114
    117115(module box (;export
     
    146144  (only lolevel
    147145    extend-procedure procedure-data
    148     make-weak-locative make-locative))
     146    make-weak-locative make-locative)
     147  (only type-errors
     148    define-error-type) )
     149
     150(require-library ports lolevel type-errors)
    149151
    150152
     
    153155;; Errors
    154156
    155 (define (error-box-immutable loc box . args)
    156   (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args))
    157 
    158 (define (error-box-type loc obj . args)
    159   (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args))
     157(define-error-type box-immutable "mutable box")
     158(define-error-type box)
    160159
    161160;; Finishers
     
    228227           (case tag
    229228             ((box!) (%box-structure-set! box val))
    230              ((box)  (error-box-immutable 'box-set! box val)))))
     229             ((box)  (error-box-immutable 'box-set! box 'box)))))
    231230        ((%box-procedure-tag box) =>
    232231         (lambda (tag)
    233232           (case tag
    234233             ((boxvar! boxloc!) (%box-procedure-set! box val))
    235              ((boxvar boxloc)   (error-box-immutable 'box-set! box val)))))
     234             ((boxvar boxloc)   (error-box-immutable 'box-set! box 'box)))))
    236235        (else
    237          (error-box-type 'box-set! box val))))
     236         (error-box 'box-set! box val))))
    238237
    239238;; Assessors
     
    244243      (cond ((%box-structure? box)  (%box-structure-ref box))
    245244            ((%box-procedure? box)  (%box-procedure-ref box))
    246             (else                   (error-box-type 'box-ref box))))
     245            (else                   (error-box 'box-ref box 'box))))
    247246    box-set!))
    248247
     
    250249  (cond ((%box-structure? box)   ((if weak? make-weak-locative make-locative) box 1))
    251250        ((%box-procedure? box)   (box (lambda (ref set loc) (loc))))
    252         (else                    (error-box-type 'box-location box))))
     251        (else                    (error-box 'box-location box 'box))))
    253252
    254253
  • release/4/box/tags/2.2.0/chicken-primitive-object-inlines.scm

    r14185 r14189  
    690690      (loop (%cdr ls)) ) ) )
    691691
     692(define-inline (%list/1 obj) (%cons obj '()))
     693
     694(define-inline (%list . objs)
     695  (let loop ((objs objs))
     696    (if (%null? objs) '()
     697        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     698
    692699(define-inline (%make-list n e)
    693700  (let loop ((n n) (ls '()))
     
    704711    (if (%fxzero? n) ls
    705712        (loop (%cdr ls) (%fxsub1 n)) ) ) )
     713
     714(define-inline (%any/1 pred? ls)
     715  (let loop ((ls ls))
     716    (and (not (%null? ls))
     717         (or (pred? (%car ls))
     718             (loop (%cdr ls)) ) ) ) )
     719
     720(define-inline (%list-length ls0)
     721  (let loop ((ls ls0) (n 0))
     722    (if (%null? ls) n
     723        (loop (%cdr ls) (%fxadd1 n)) ) ) )
    706724
    707725;; Structure (wordblock)
     
    738756
    739757(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    740 (define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
    741 (define-inline (%port-class port) (%wordblock-ref? port 2))
    742 (define-inline (%port-name port) (%wordblock-ref? port 3))
    743 (define-inline (%port-row port) (%wordblock-ref? port 4))
    744 (define-inline (%port-column port) (%wordblock-ref? port 5))
    745 (define-inline (%port-eof? port) (%wordblock-ref? port 6))
    746 (define-inline (%port-type port) (%wordblock-ref? port 7))
    747 (define-inline (%port-closed? port) (%wordblock-ref? port 8))
    748 (define-inline (%port-data port) (%wordblock-ref? port 9))
    749 
    750 (define-inline (%input-port? x) (and (%port x) (%port-input-mode? x)))
    751 (define-inline (%output-port? x) (and (%port x) (not (%port-input-mode? x))))
     758(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
     759(define-inline (%port-class port) (%wordblock-ref port 2))
     760(define-inline (%port-name port) (%wordblock-ref port 3))
     761(define-inline (%port-row port) (%wordblock-ref port 4))
     762(define-inline (%port-column port) (%wordblock-ref port 5))
     763(define-inline (%port-eof? port) (%wordblock-ref port 6))
     764(define-inline (%port-type port) (%wordblock-ref port 7))
     765(define-inline (%port-closed? port) (%wordblock-ref port 8))
     766(define-inline (%port-data port) (%wordblock-ref port 9))
     767
     768(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
     769(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
    752770
    753771(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
  • release/4/box/trunk/box.meta

    r13616 r14189  
    77 (doc-from-wiki #t)
    88 (author "[[kon lovett]]")
    9  (needs setup-helper)
     9 (needs check-errors setup-helper)
    1010 (files
    1111  "chicken-primitive-object-inlines.scm"
  • release/4/box/trunk/box.scm

    r14012 r14189  
    107107                   ((%box-procedure? box)  (%box-procedure-ref box))
    108108                   (else
    109                     (error-box-type 'box-print box)))))
     109                    (error-box 'box-print box)))))
    110110          (display "#&") (write val)))
    111111
    112112
    113113;;; Module box
    114 
    115 (require-library ports lolevel)
    116114
    117115(module box (;export
     
    146144  (only lolevel
    147145    extend-procedure procedure-data
    148     make-weak-locative make-locative))
     146    make-weak-locative make-locative)
     147  (only type-errors
     148    define-error-type) )
     149
     150(require-library ports lolevel type-errors)
    149151
    150152
     
    153155;; Errors
    154156
    155 (define (error-box-immutable loc box . args)
    156   (apply ##sys#signal-hook #:type-error loc "bad argument type - not a mutable box" box args))
    157 
    158 (define (error-box-type loc obj . args)
    159   (apply ##sys#signal-hook #:type-error loc "bad argument type - not a box" obj args))
     157(define-error-type box-immutable "mutable box")
     158(define-error-type box)
    160159
    161160;; Finishers
     
    228227           (case tag
    229228             ((box!) (%box-structure-set! box val))
    230              ((box)  (error-box-immutable 'box-set! box val)))))
     229             ((box)  (error-box-immutable 'box-set! box 'box)))))
    231230        ((%box-procedure-tag box) =>
    232231         (lambda (tag)
    233232           (case tag
    234233             ((boxvar! boxloc!) (%box-procedure-set! box val))
    235              ((boxvar boxloc)   (error-box-immutable 'box-set! box val)))))
     234             ((boxvar boxloc)   (error-box-immutable 'box-set! box 'box)))))
    236235        (else
    237          (error-box-type 'box-set! box val))))
     236         (error-box 'box-set! box val))))
    238237
    239238;; Assessors
     
    244243      (cond ((%box-structure? box)  (%box-structure-ref box))
    245244            ((%box-procedure? box)  (%box-procedure-ref box))
    246             (else                   (error-box-type 'box-ref box))))
     245            (else                   (error-box 'box-ref box 'box))))
    247246    box-set!))
    248247
     
    250249  (cond ((%box-structure? box)   ((if weak? make-weak-locative make-locative) box 1))
    251250        ((%box-procedure? box)   (box (lambda (ref set loc) (loc))))
    252         (else                    (error-box-type 'box-location box))))
     251        (else                    (error-box 'box-location box 'box))))
    253252
    254253
  • release/4/box/trunk/chicken-primitive-object-inlines.scm

    r14077 r14189  
    690690      (loop (%cdr ls)) ) ) )
    691691
     692(define-inline (%list/1 obj) (%cons obj '()))
     693
     694(define-inline (%list . objs)
     695  (let loop ((objs objs))
     696    (if (%null? objs) '()
     697        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     698
    692699(define-inline (%make-list n e)
    693700  (let loop ((n n) (ls '()))
     
    704711    (if (%fxzero? n) ls
    705712        (loop (%cdr ls) (%fxsub1 n)) ) ) )
     713
     714(define-inline (%any/1 pred? ls)
     715  (let loop ((ls ls))
     716    (and (not (%null? ls))
     717         (or (pred? (%car ls))
     718             (loop (%cdr ls)) ) ) ) )
     719
     720(define-inline (%list-length ls0)
     721  (let loop ((ls ls0) (n 0))
     722    (if (%null? ls) n
     723        (loop (%cdr ls) (%fxadd1 n)) ) ) )
    706724
    707725;; Structure (wordblock)
     
    738756
    739757(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    740 (define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
    741 (define-inline (%port-class port) (%wordblock-ref? port 2))
    742 (define-inline (%port-name port) (%wordblock-ref? port 3))
    743 (define-inline (%port-row port) (%wordblock-ref? port 4))
    744 (define-inline (%port-column port) (%wordblock-ref? port 5))
    745 (define-inline (%port-eof? port) (%wordblock-ref? port 6))
    746 (define-inline (%port-type port) (%wordblock-ref? port 7))
    747 (define-inline (%port-closed? port) (%wordblock-ref? port 8))
    748 (define-inline (%port-data port) (%wordblock-ref? port 9))
    749 
    750 (define-inline (%input-port? x) (and (%port x) (%port-input-mode? x)))
    751 (define-inline (%output-port? x) (and (%port x) (not (%port-input-mode? x))))
     758(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
     759(define-inline (%port-class port) (%wordblock-ref port 2))
     760(define-inline (%port-name port) (%wordblock-ref port 3))
     761(define-inline (%port-row port) (%wordblock-ref port 4))
     762(define-inline (%port-column port) (%wordblock-ref port 5))
     763(define-inline (%port-eof? port) (%wordblock-ref port 6))
     764(define-inline (%port-type port) (%wordblock-ref port 7))
     765(define-inline (%port-closed? port) (%wordblock-ref port 8))
     766(define-inline (%port-data port) (%wordblock-ref port 9))
     767
     768(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
     769(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
    752770
    753771(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
Note: See TracChangeset for help on using the changeset viewer.