Changeset 16056 in project


Ignore:
Timestamp:
09/23/09 18:41:07 (10 years ago)
Author:
Kon Lovett
Message:

Added SRFI 10 printer/reader. Use of type-errors

Location:
release/4/stack
Files:
8 edited
1 copied

Legend:

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

    r14194 r16056  
    639639        (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
    640640
    641 (define-inline (%append! . lss)
     641(define-inline (%list/1 obj) (%cons obj '()))
     642
     643(define-inline (%list . objs)
     644  (let loop ((objs objs))
     645    (if (%null? objs) '()
     646        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     647
     648(define-inline (%make-list n e)
     649  (let loop ((n n) (ls '()))
     650    (if (%fxzero? n) ls
     651        (loop (%fxsub1 n) (%cons e ls)) ) ) )
     652
     653(define-inline (%list-take ls0 n)
     654  (let loop ((ls ls0) (n n))
     655    (if (%fxzero? n) '()
     656        (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
     657
     658(define-inline (%list-drop ls0 n)
     659  (let loop ((ls ls0) (n n))
     660    (if (%fxzero? n) ls
     661        (loop (%cdr ls) (%fxsub1 n)) ) ) )
     662
     663(define-inline (%list-any/1 pred? ls)
     664  (let loop ((ls ls))
     665    (and (not (%null? ls))
     666         (or (pred? (%car ls))
     667             (loop (%cdr ls)) ) ) ) )
     668
     669(define-inline (%list-every/1 pred? ls)
     670  (let loop ((ls ls))
     671    (or (%null? ls)
     672        (and (pred? (%car ls))
     673             (loop (%cdr ls))) ) ) )
     674
     675(define-inline (%list-length ls0)
     676  (let loop ((ls ls0) (n 0))
     677    (if (%null? ls) n
     678        (loop (%cdr ls) (%fxadd1 n)) ) ) )
     679
     680(define-inline (%list-find pred? ls)
     681  (let loop ((ls ls))
     682    (and (not (%null? ls))
     683         (or (let ((elm (%car ls))) (and (pred? elm) elm))
     684             (loop (%cdr ls)) ) ) ) )
     685
     686(define-inline (%alist-ref key al #!optional (test eqv?) def)
     687  (let loop ((al al))
     688    (cond ((%null? al) def )
     689          ((test key (%caar al)) (%cdar al) )
     690          (else (loop (%cdr al)) ) ) ) )
     691
     692(define-inline (%alist-update! key val al0 #!optional (test eqv?))
     693  (let loop ((al al0))
     694    (cond ((%null? al) (%cons (%cons key val) al0) )
     695          ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
     696          (else (loop (%cdr al)) ) ) ) )
     697
     698(define-inline (%alist-delete! key al0 #!optional (test equal?))
     699  (let loop ((al al0) (prv #f))
     700    (cond ((%null? al) al0)
     701          ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
     702          (else (loop (%cdr al) al) ) ) ) )
     703
     704(define-inline (%list-append! . lss)
    642705  ;(assert (and (proper-list? lss) (for-each (cut proper-list? <>) lss)))
    643706  (let ((lss (let position-at-first-pair ((lss lss))
     
    657720                         (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
    658721
    659 (define-inline (%delq! x ls0)
     722(define-inline (%list-delete!/eq x ls0)
    660723  ;(assert (proper-list? ls0))
    661724  (let find-elm ((ls ls0) (ppr #f))
    662     (cond ((%null? ls)
    663            ls0 )
     725    (cond ((%null? ls) ls0 )
    664726                ((%eq? x (%car ls))
    665                  (cond (ppr
    666                         (%set-cdr! ppr (%cdr ls))
    667                         ls0 )
    668                        (else
    669                         (%cdr ls) ) ) )
     727                 (cond (ppr (%set-cdr! ppr (%cdr ls)) ls0 )
     728                       (else (%cdr ls) ) ) )
    670729                (else
    671730                 (find-elm (%cdr ls) ls) ) ) ) )
     731
     732(define-inline (%delq! x ls0) (%list-delete!/eq x ls0))
    672733
    673734(define-inline (%list-fold/1 func init ls0)
     
    689750      (proc (%car ls))
    690751      (loop (%cdr ls)) ) ) )
    691 
    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 
    699 (define-inline (%make-list n e)
    700   (let loop ((n n) (ls '()))
    701     (if (%fxzero? n) ls
    702         (loop (%fxsub1 n) (%cons e ls)) ) ) )
    703 
    704 (define-inline (%list-take ls0 n)
    705   (let loop ((ls ls0) (n n))
    706     (if (%fxzero? n) '()
    707         (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
    708 
    709 (define-inline (%list-drop ls0 n)
    710   (let loop ((ls ls0) (n n))
    711     (if (%fxzero? n) ls
    712         (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)) ) ) )
    724752
    725753;; Structure (wordblock)
  • release/4/stack/tags/2.1.0/stack.meta

    r13618 r16056  
    88 (license "BSD")
    99 (doc-from-wiki)
    10  (needs setup-helper)
     10 (needs setup-helper check-errors)
    1111 (files
    1212  "chicken-primitive-object-inlines.scm"
  • release/4/stack/tags/2.1.0/stack.scm

    r14030 r16056  
    99;; - All operations inlined & primitive due to high-performance nature.
    1010
    11 ;;; Prelude
    12 
    13 (declare
    14   (usual-integrations)
    15   (disable-interrupts)
    16   (fixnum)
    17   (inline)
    18   (local)
    19   (no-procedure-checks)
    20   (bound-to-procedure
    21     ##sys#signal-hook ) )
    22 
    23 ;;
    24 
    25 (include "chicken-primitive-object-inlines")
     11;;;
     12
     13(module stack
     14
     15  (;export
     16    make-stack
     17    list->stack
     18    stack?
     19    stack-empty?
     20    stack-count
     21    stack-peek
     22    stack-empty!
     23    stack-poke!
     24    stack-push!
     25    stack-cut!
     26    stack-pop!
     27    stack->list
     28    stack-fold
     29    stack-map
     30    stack-for-each)
     31
     32  (import
     33    scheme
     34    (only chicken
     35          declare
     36          define-inline
     37          include
     38          optional let-optionals  ;due to #!optional implementation
     39          unless when
     40          define-record-printer
     41          define-reader-ctor)
     42    (only ports with-output-to-port)
     43    (only type-errors define-error-type error-list error-fixnum))
     44
     45  (require-library ports type-errors)
     46
     47  (declare
     48    (bound-to-procedure
     49      ##sys#signal-hook ) )
     50
     51  (include "chicken-primitive-object-inlines")
     52  (include "inline-type-checks")
    2653
    2754;; Stack Support
     
    3158(define-inline (%stack? obj) (%structure-instance? obj 'stack))
    3259
     60(define-inline (%valid-stack? obj)
     61  (and #;(%stack? obj)
     62       (%fx= 3 (%structure-length obj))
     63       (%list? (%stack-list obj)) ) )
     64
    3365;; Stack List
    3466
    3567(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)) ) )
    4068
    4169(define-inline (%stack-list-empty? stk) (%null? (%stack-list stk)))
     
    84112;; Helpers
    85113
    86 (define-inline (%check-fixnum loc obj) (unless (%fixnum? obj) (error-type-fixnum loc obj)))
    87114
    88115(define-inline (%check-stack loc obj)
    89   (unless (%stack? obj) (error-type-stack loc obj))
     116  (unless (%stack? obj) (error-stack loc obj))
    90117  (unless (%valid-stack? obj) (error-corrupted-stack loc obj)) )
    91118
    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)))
     119(define-inline (%check-stack-underflow loc stk)
     120  (when (%stack-empty? stk) (error-stack-underflow loc stk)) )
     121
     122(define-inline (%check-fixnum-index loc lfx fx hfx)
     123  (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
    97124
    98125;;;
    99126
    100 (require-library ports)
    101 
    102 (module stack (;export
    103         make-stack
    104         list->stack
    105         stack?
    106         stack-empty?
    107         stack-count
    108         stack-peek
    109         stack-empty!
    110         stack-poke!
    111         stack-push!
    112         stack-cut!
    113         stack-pop!
    114         stack->list
    115         stack-fold
    116         stack-map
    117         stack-for-each)
    118 
    119 (import
    120   scheme
    121   (only chicken
    122     optional                ;due to #!optional implementation
    123     let-optionals           ;due to #!optional implementation
    124     unless when
    125     define-record-printer)
    126   (only ports
    127     with-output-to-port) )
    128 
    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) )
     127(define-error-type stack)
    139128
    140129(define (error-corrupted-stack loc obj)
     
    188177  (%check-fixnum 'stack-cut! start)
    189178  (%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))
     179  (%check-fixnum-index 'stack-cut! 0 start end)
     180  (%check-fixnum-index 'stack-cut! start end (%fx+ (%stack-count stk) 1))
    192181  (let ((cnt (%fx- end start)))
    193182    (%stack-count-dec! stk cnt)
     
    235224  (with-output-to-port out
    236225    (lambda ()
    237       (display "#<stack")
    238       (display " count = ") (display (%stack-count stk))
    239       (display ">") ) ) )
     226      (display "#,(stack ")
     227      (display (%stack-list stk))
     228      (display #\)) ) ) )
     229
     230(define-reader-ctor 'stack list->stack)
    240231
    241232) ;module stack
  • release/4/stack/tags/2.1.0/stack.setup

    r13565 r16056  
    55(verify-extension-name 'stack)
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "2.0.0"))
     7(setup-shared-extension-module (extension-name) (extension-version "2.0.0")
     8  #:compile-options '(-optimize-level 3
     9                      -inline-limit 50
     10                      -fixnum-arithmetic
     11                      -no-procedure-checks
     12                      -disable-interrupts))
  • release/4/stack/trunk/chicken-primitive-object-inlines.scm

    r14194 r16056  
    639639        (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
    640640
    641 (define-inline (%append! . lss)
     641(define-inline (%list/1 obj) (%cons obj '()))
     642
     643(define-inline (%list . objs)
     644  (let loop ((objs objs))
     645    (if (%null? objs) '()
     646        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     647
     648(define-inline (%make-list n e)
     649  (let loop ((n n) (ls '()))
     650    (if (%fxzero? n) ls
     651        (loop (%fxsub1 n) (%cons e ls)) ) ) )
     652
     653(define-inline (%list-take ls0 n)
     654  (let loop ((ls ls0) (n n))
     655    (if (%fxzero? n) '()
     656        (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
     657
     658(define-inline (%list-drop ls0 n)
     659  (let loop ((ls ls0) (n n))
     660    (if (%fxzero? n) ls
     661        (loop (%cdr ls) (%fxsub1 n)) ) ) )
     662
     663(define-inline (%list-any/1 pred? ls)
     664  (let loop ((ls ls))
     665    (and (not (%null? ls))
     666         (or (pred? (%car ls))
     667             (loop (%cdr ls)) ) ) ) )
     668
     669(define-inline (%list-every/1 pred? ls)
     670  (let loop ((ls ls))
     671    (or (%null? ls)
     672        (and (pred? (%car ls))
     673             (loop (%cdr ls))) ) ) )
     674
     675(define-inline (%list-length ls0)
     676  (let loop ((ls ls0) (n 0))
     677    (if (%null? ls) n
     678        (loop (%cdr ls) (%fxadd1 n)) ) ) )
     679
     680(define-inline (%list-find pred? ls)
     681  (let loop ((ls ls))
     682    (and (not (%null? ls))
     683         (or (let ((elm (%car ls))) (and (pred? elm) elm))
     684             (loop (%cdr ls)) ) ) ) )
     685
     686(define-inline (%alist-ref key al #!optional (test eqv?) def)
     687  (let loop ((al al))
     688    (cond ((%null? al) def )
     689          ((test key (%caar al)) (%cdar al) )
     690          (else (loop (%cdr al)) ) ) ) )
     691
     692(define-inline (%alist-update! key val al0 #!optional (test eqv?))
     693  (let loop ((al al0))
     694    (cond ((%null? al) (%cons (%cons key val) al0) )
     695          ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
     696          (else (loop (%cdr al)) ) ) ) )
     697
     698(define-inline (%alist-delete! key al0 #!optional (test equal?))
     699  (let loop ((al al0) (prv #f))
     700    (cond ((%null? al) al0)
     701          ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
     702          (else (loop (%cdr al) al) ) ) ) )
     703
     704(define-inline (%list-append! . lss)
    642705  ;(assert (and (proper-list? lss) (for-each (cut proper-list? <>) lss)))
    643706  (let ((lss (let position-at-first-pair ((lss lss))
     
    657720                         (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
    658721
    659 (define-inline (%delq! x ls0)
     722(define-inline (%list-delete!/eq x ls0)
    660723  ;(assert (proper-list? ls0))
    661724  (let find-elm ((ls ls0) (ppr #f))
    662     (cond ((%null? ls)
    663            ls0 )
     725    (cond ((%null? ls) ls0 )
    664726                ((%eq? x (%car ls))
    665                  (cond (ppr
    666                         (%set-cdr! ppr (%cdr ls))
    667                         ls0 )
    668                        (else
    669                         (%cdr ls) ) ) )
     727                 (cond (ppr (%set-cdr! ppr (%cdr ls)) ls0 )
     728                       (else (%cdr ls) ) ) )
    670729                (else
    671730                 (find-elm (%cdr ls) ls) ) ) ) )
     731
     732(define-inline (%delq! x ls0) (%list-delete!/eq x ls0))
    672733
    673734(define-inline (%list-fold/1 func init ls0)
     
    689750      (proc (%car ls))
    690751      (loop (%cdr ls)) ) ) )
    691 
    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 
    699 (define-inline (%make-list n e)
    700   (let loop ((n n) (ls '()))
    701     (if (%fxzero? n) ls
    702         (loop (%fxsub1 n) (%cons e ls)) ) ) )
    703 
    704 (define-inline (%list-take ls0 n)
    705   (let loop ((ls ls0) (n n))
    706     (if (%fxzero? n) '()
    707         (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
    708 
    709 (define-inline (%list-drop ls0 n)
    710   (let loop ((ls ls0) (n n))
    711     (if (%fxzero? n) ls
    712         (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)) ) ) )
    724752
    725753;; Structure (wordblock)
  • release/4/stack/trunk/stack.meta

    r13618 r16056  
    88 (license "BSD")
    99 (doc-from-wiki)
    10  (needs setup-helper)
     10 (needs setup-helper check-errors)
    1111 (files
    1212  "chicken-primitive-object-inlines.scm"
  • release/4/stack/trunk/stack.scm

    r14030 r16056  
    99;; - All operations inlined & primitive due to high-performance nature.
    1010
    11 ;;; Prelude
    12 
    13 (declare
    14   (usual-integrations)
    15   (disable-interrupts)
    16   (fixnum)
    17   (inline)
    18   (local)
    19   (no-procedure-checks)
    20   (bound-to-procedure
    21     ##sys#signal-hook ) )
    22 
    23 ;;
    24 
    25 (include "chicken-primitive-object-inlines")
     11;;;
     12
     13(module stack
     14
     15  (;export
     16    make-stack
     17    list->stack
     18    stack?
     19    stack-empty?
     20    stack-count
     21    stack-peek
     22    stack-empty!
     23    stack-poke!
     24    stack-push!
     25    stack-cut!
     26    stack-pop!
     27    stack->list
     28    stack-fold
     29    stack-map
     30    stack-for-each)
     31
     32  (import
     33    scheme
     34    (only chicken
     35          declare
     36          define-inline
     37          include
     38          optional let-optionals  ;due to #!optional implementation
     39          unless when
     40          define-record-printer
     41          define-reader-ctor)
     42    (only ports with-output-to-port)
     43    (only type-errors define-error-type error-list error-fixnum))
     44
     45  (require-library ports type-errors)
     46
     47  (declare
     48    (bound-to-procedure
     49      ##sys#signal-hook ) )
     50
     51  (include "chicken-primitive-object-inlines")
     52  (include "inline-type-checks")
    2653
    2754;; Stack Support
     
    3158(define-inline (%stack? obj) (%structure-instance? obj 'stack))
    3259
     60(define-inline (%valid-stack? obj)
     61  (and #;(%stack? obj)
     62       (%fx= 3 (%structure-length obj))
     63       (%list? (%stack-list obj)) ) )
     64
    3365;; Stack List
    3466
    3567(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)) ) )
    4068
    4169(define-inline (%stack-list-empty? stk) (%null? (%stack-list stk)))
     
    84112;; Helpers
    85113
    86 (define-inline (%check-fixnum loc obj) (unless (%fixnum? obj) (error-type-fixnum loc obj)))
    87114
    88115(define-inline (%check-stack loc obj)
    89   (unless (%stack? obj) (error-type-stack loc obj))
     116  (unless (%stack? obj) (error-stack loc obj))
    90117  (unless (%valid-stack? obj) (error-corrupted-stack loc obj)) )
    91118
    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)))
     119(define-inline (%check-stack-underflow loc stk)
     120  (when (%stack-empty? stk) (error-stack-underflow loc stk)) )
     121
     122(define-inline (%check-fixnum-index loc lfx fx hfx)
     123  (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
    97124
    98125;;;
    99126
    100 (require-library ports)
    101 
    102 (module stack (;export
    103         make-stack
    104         list->stack
    105         stack?
    106         stack-empty?
    107         stack-count
    108         stack-peek
    109         stack-empty!
    110         stack-poke!
    111         stack-push!
    112         stack-cut!
    113         stack-pop!
    114         stack->list
    115         stack-fold
    116         stack-map
    117         stack-for-each)
    118 
    119 (import
    120   scheme
    121   (only chicken
    122     optional                ;due to #!optional implementation
    123     let-optionals           ;due to #!optional implementation
    124     unless when
    125     define-record-printer)
    126   (only ports
    127     with-output-to-port) )
    128 
    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) )
     127(define-error-type stack)
    139128
    140129(define (error-corrupted-stack loc obj)
     
    188177  (%check-fixnum 'stack-cut! start)
    189178  (%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))
     179  (%check-fixnum-index 'stack-cut! 0 start end)
     180  (%check-fixnum-index 'stack-cut! start end (%fx+ (%stack-count stk) 1))
    192181  (let ((cnt (%fx- end start)))
    193182    (%stack-count-dec! stk cnt)
     
    235224  (with-output-to-port out
    236225    (lambda ()
    237       (display "#<stack")
    238       (display " count = ") (display (%stack-count stk))
    239       (display ">") ) ) )
     226      (display "#,(stack ")
     227      (display (%stack-list stk))
     228      (display #\)) ) ) )
     229
     230(define-reader-ctor 'stack list->stack)
    240231
    241232) ;module stack
  • release/4/stack/trunk/stack.setup

    r13565 r16056  
    55(verify-extension-name 'stack)
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "2.0.0"))
     7(setup-shared-extension-module (extension-name) (extension-version "2.0.0")
     8  #:compile-options '(-optimize-level 3
     9                      -inline-limit 50
     10                      -fixnum-arithmetic
     11                      -no-procedure-checks
     12                      -disable-interrupts))
Note: See TracChangeset for help on using the changeset viewer.