Changeset 34140 in project


Ignore:
Timestamp:
05/31/17 08:04:54 (5 months ago)
Author:
kon
Message:

add csc test, add static

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

Legend:

Unmodified
Added
Removed
  • release/4/stack/tags/2.3.0/stack.meta

    r34096 r34140  
    88 (doc-from-wiki)
    99 (depends
    10         (typed-modules "0.1")
    1110        (setup-helper "1.5.2")
    1211        (check-errors "1.9.0"))
    1312 (test-depends test)
    14  (files "stack.release-info" "stack.setup" "chicken-primitive-object-inlines.scm" "stack.scm" "inline-type-checks.scm" "stack.meta" "tests/run.scm"))
     13 (files "stack.meta" "stack.setup" "stack.scm"
     14  "chicken-primitive-object-inlines.scm"  "inline-type-checks.scm"
     15  "tests/run.scm"))
  • release/4/stack/tags/2.3.0/stack.scm

    r34125 r34140  
    1212;;;
    1313
    14 (import typed-modules)
    15 
    1614(module stack
    1715
    1816(;export
    19   (make-stack : (-> (struct stack)))
    20   (list->stack : (list -> (struct stack)))
    21   (stack? : (* -> boolean))
    22   (stack-empty? : ((struct stack) -> boolean))
    23   (stack-count : ((struct stack) -> fixnum))
    24   (stack-peek : ((struct stack) #!optional fixnum -> *))
    25   (stack-empty! : ((struct stack) -> undefined))
    26   (stack-poke! : ((struct stack) * #!optional fixnum -> undefined))
    27   (stack-push! : ((struct stack) #!rest string -> undefined))
    28   (stack-cut! : ((struct stack) fixnum #!optional fixnum -> list))
    29   (stack-pop! : ((struct stack) -> *))
    30   (stack->list : ((struct stack) -> list))
    31   (stack-fold : ((struct stack) procedure * -> *))
    32   (stack-map : ((struct stack) procedure -> list))
    33   (stack-for-each : ((struct stack) procedure -> undefined)) )
     17  make-stack
     18  list->stack
     19  stack->list
     20  stack?
     21  stack-empty?
     22  stack-count
     23  stack-peek
     24  stack-empty!
     25  stack-poke!
     26  stack-push!
     27  stack-cut!
     28  stack-pop!
     29  stack-map
     30  stack-map
     31  stack-for-each
     32  stack-literal-form)
     33
     34(import scheme)
    3435
    3536(import
    36   scheme
    3737  (only chicken
     38    make-parameter
     39    warning
     40    :
    3841    void
    3942    declare
     
    4952(import
    5053  (only ports with-output-to-port)
     54  (only extras format))
     55
     56(import
    5157  (only type-errors define-error-type error-list error-fixnum))
    52 (require-library ports type-errors)
     58(require-library type-errors)
    5359
    5460(declare
     
    6874  (and
    6975    #;(%stack? obj)
    70    (%fx= 3 (%structure-length obj))
    71    (%list? (%stack-list obj)) ) )
     76    (%fx= 3 (%structure-length obj))
     77    (%list? (%stack-list obj)) ) )
    7278
    7379;; Stack List
     
    150156;;;
    151157
    152 (define (make-stack) (%make-stack))
    153 
     158(: make-stack (-> (struct stack)))
     159(define (make-stack)
     160  (%make-stack) )
     161
     162(: list->stack (list -> (struct stack)))
    154163(define (list->stack ls)
    155164  (%check-list 'list->stack ls)
     
    159168    stk ) )
    160169
     170(: stack? (* -> boolean))
    161171(define (stack? obj) (%stack? obj))
    162172
     173(: stack-empty? ((struct stack) -> boolean))
    163174(define (stack-empty? stk)
    164175        (%stack-empty? (%check-stack 'stack-empty? stk)) )
    165176
     177(: stack-count ((struct stack) -> fixnum))
    166178(define (stack-count stk)
    167179        (%stack-count (%check-stack 'stack-count stk)) )
    168180
     181(: stack-peek ((struct stack) #!optional fixnum -> *))
    169182(define (stack-peek stk #!optional (idx 0))
    170183        (%car (%stack-node-ref 'stack-peek (%check-stack 'stack-peek stk) idx)) )
    171184
     185(: stack-empty! ((struct stack) -> undefined))
    172186(define (stack-empty! stk)
    173187        (%stack-empty! (%check-stack 'stack-empty! stk)) )
    174188
     189(: stack-poke! ((struct stack) * #!optional fixnum -> undefined))
    175190(define (stack-poke! stk obj #!optional (idx 0))
    176191        (%set-car!/mutate (%stack-node-ref 'stack-poke! (%check-stack 'stack-poke! stk) idx) obj) )
    177192
     193(: stack-push! ((struct stack) #!rest * -> undefined))
    178194(define (stack-push! stk #!rest ls)
    179195        (unless (%null? ls) (%stack-push! (%check-stack 'stack-push! stk) ls)) )
    180196
     197(: stack-cut! ((struct stack) fixnum #!optional fixnum -> list))
    181198(define (stack-cut! stk start #!optional (end (%stack-count stk)))
    182199  (%check-stack 'stack-cut! stk)
     
    204221        ls ) ) ) )
    205222
     223(: stack-pop! ((struct stack) -> *))
    206224(define (stack-pop! stk)
    207225  (%check-stack 'stack-pop! stk)
     
    209227        (%stack-pop! stk) )
    210228
     229(: stack->list ((struct stack) -> list))
    211230(define (stack->list stk)
    212231        (%list-copy (%stack-list (%check-stack 'stack->list stk))) )
    213232
     233(: stack-fold ((struct stack) procedure * -> *))
    214234(define (stack-fold stk func init)
    215235        (%list-fold/1 func init (%stack-list (%check-stack 'stack-fold stk))) )
    216236
     237(: stack-map ((struct stack) procedure -> list))
    217238(define (stack-map stk func)
    218239        (%list-map/1 func (%stack-list (%check-stack 'stack-map stk))) )
    219240
     241(: stack-for-each ((struct stack) procedure -> undefined))
    220242(define (stack-for-each stk proc)
    221243        (%list-for-each/1 proc (%stack-list (%check-stack 'stack-for-each stk))) )
     
    223245;;; Read/Print Syntax
    224246
    225 (define-constant SRFI-10-FORMAT "#,(~A )")
    226 
    227247(define-record-printer (stack stk out)
    228   (with-output-to-port out
    229     (lambda ()
    230       (display "#,")
    231       (display "(")
    232       (display "stack ")
    233       (display " ")
    234       (display (%stack-list stk))
    235       (display ")") ) ) )
     248  (format out (stack-literal-format) (%stack-list stk)) )
    236249
    237250(define-reader-ctor 'stack list->stack)
    238251
     252(define stack-literal-form
     253  (make-parameter 'srfi-10
     254    (lambda (x)
     255      (case x
     256        ((SRFI-10 srfi-10)
     257          'srfi-10 )
     258        ((UNREAD unread)
     259          'unread )
     260        (else
     261          (warning 'stack-literal-format "invalid form symbol; 'srfi-10 or 'unread" x)
     262          (stack-literal-format))))))
     263
     264(define-constant SRFI-10-FORMAT "#,(stack ~A)")
     265(define-constant UNREAD-FORMAT "#<stack ~A>")
     266
     267(define (stack-literal-format)
     268  (case (stack-literal-form)
     269    ((srfi-10)
     270      SRFI-10-FORMAT )
     271    (else
     272      UNREAD-FORMAT ) ) )
     273
    239274) ;module stack
  • release/4/stack/tags/2.3.0/stack.setup

    r34125 r34140  
    55(verify-extension-name 'stack)
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "2.2.1")
     7(setup-shared+static-extension-module (extension-name) (extension-version "2.3.0")
    88  #:inline? #t
    99  #:types? #t
    1010  #:compile-options '(
    11     -scrutinize
    1211    -disable-interrupts
     12    -fixnum-arithmetic
    1313    -optimize-level 3
     14    -debug-level 2
    1415    -inline-limit 50
    15     -fixnum-arithmetic
    1616    -no-procedure-checks))
  • release/4/stack/tags/2.3.0/tests/run.scm

    r28421 r34140  
    1 ;;;; stack-test
     1;;;; run.scm
    22
    3 (require-extension test)
    4 (require-extension stack)
     3(use utils)
    54
    6 (test-group "Empty Stack"
    7   (test-assert (make-stack))
    8   (test-assert (stack? (make-stack)))
    9   (test-assert (stack-empty? (make-stack)))
    10   (test 0 (stack-count (make-stack)))
     5(define-constant TEST-SOURCE-FILE "test-impl.scm")
     6
     7(cond-expand
     8
     9  (unix
     10
     11  (define (csi-n-csc fil #!optional (csi "csi") (csc-opt (compile-file-options)))
     12    (let ((rc
     13          (begin
     14            (print) (print "*** Interpreted ***") (print)
     15            (system (string-append csi " -s " fil))) ) )
     16      (receive (normal? code) (process-status rc)
     17        (if (not normal?)
     18          (exit (fxneg code))
     19          (if (not (zero? code))
     20            (exit code)
     21            (begin
     22              (print) (print "*** Compiled ***") (print)
     23              (parameterize ((compile-file-options csc-opt))
     24                ;NOTE this exits due to 'test-exit'!
     25                (compile-file fil)) ) ) ) ) ) )
     26
     27    ;from manual: library # system
     28    ;; Returns two values: #t if the process exited normally or #f otherwise;
     29    ;; and either the exit status, or the signal number if terminated via signal.
     30    (define (process-status rc)
     31      (define (wait-signaled? x) (not (= 0 (bitwise-and x 127))))
     32      (define (wait-signal x) (bitwise-and x 127))
     33      (define (wait-exit-status x) (arithmetic-shift x -8))
     34      (if (wait-signaled? rc)
     35        (values #f (wait-signal rc))
     36        (values #t (wait-exit-status rc)) ) )
     37
     38    (let* ((args (argv) )
     39           (csi (car args) ) )
     40      (csi-n-csc TEST-SOURCE-FILE csi '("-O3" "-d2"))  )
     41    )
     42
     43  (else ;(windows ...)
     44
     45    (include TEST-SOURCE-FILE) )
    1146)
    12 
    13 (test-group "Push!/Pop!/Peek/Poke!"
    14   (let ([stk (make-stack)])
    15     (stack-push! stk 1)
    16     (stack-push! stk 2 3)
    17     (test 3 (stack-count stk))
    18     (test 3 (stack-pop! stk))
    19     (test 2 (stack-pop! stk))
    20     (test 1 (stack-pop! stk))
    21     (test-assert (stack-empty? stk))
    22     (test-error (stack-pop! stk))
    23     (stack-push! stk 1 2 3)
    24     (test 2 (stack-peek stk 1))
    25     (stack-poke! stk 4 1)
    26     (test 3 (stack-pop! stk))
    27     (test 4 (stack-pop! stk))
    28     (test 1 (stack-count stk)) )
    29 )
    30 
    31 (test-group "Cut!"
    32   (let ([stk (make-stack)])
    33     ;3 2 1
    34     (stack-push! stk 1 2 3)
    35     (test '(2) (stack-cut! stk 1 2))
    36     (test 2 (stack-count stk))
    37     ;3 1
    38     (test '(3) (stack-cut! stk 0 1))
    39     (test 1 (stack-count stk))
    40     ;5 4 1
    41     (stack-push! stk 4 5)
    42     (test '(4 1) (stack-cut! stk 1 3))
    43     (test 1 (stack-count stk))
    44     ;
    45     (test-error (stack-cut! stk -1 3))
    46     (test-error (stack-cut! stk 0 3))
    47     (test-error (stack-cut! stk 0 -3)) )
    48 )
    49 
    50 (test-group "Stack from List"
    51   (let ([stk (make-stack)]
    52         [stk1 (list->stack '(1 2 3))])
    53     ;
    54     (stack-push! stk 1 2 3)
    55     (test '(3 2 1) (stack->list stk))
    56     ;
    57     (test-assert (stack? stk1))
    58     (test 3 (stack-count stk1))
    59     (test 1 (stack-pop! stk1)) )
    60 )
    61 
    62 (test-exit)
  • release/4/stack/trunk/stack.meta

    r34096 r34140  
    88 (doc-from-wiki)
    99 (depends
    10         (typed-modules "0.1")
    1110        (setup-helper "1.5.2")
    1211        (check-errors "1.9.0"))
    1312 (test-depends test)
    14  (files "stack.release-info" "stack.setup" "chicken-primitive-object-inlines.scm" "stack.scm" "inline-type-checks.scm" "stack.meta" "tests/run.scm"))
     13 (files "stack.meta" "stack.setup" "stack.scm"
     14  "chicken-primitive-object-inlines.scm"  "inline-type-checks.scm"
     15  "tests/run.scm"))
  • release/4/stack/trunk/stack.scm

    r34125 r34140  
    1212;;;
    1313
    14 (import typed-modules)
    15 
    1614(module stack
    1715
    1816(;export
    19   (make-stack : (-> (struct stack)))
    20   (list->stack : (list -> (struct stack)))
    21   (stack? : (* -> boolean))
    22   (stack-empty? : ((struct stack) -> boolean))
    23   (stack-count : ((struct stack) -> fixnum))
    24   (stack-peek : ((struct stack) #!optional fixnum -> *))
    25   (stack-empty! : ((struct stack) -> undefined))
    26   (stack-poke! : ((struct stack) * #!optional fixnum -> undefined))
    27   (stack-push! : ((struct stack) #!rest string -> undefined))
    28   (stack-cut! : ((struct stack) fixnum #!optional fixnum -> list))
    29   (stack-pop! : ((struct stack) -> *))
    30   (stack->list : ((struct stack) -> list))
    31   (stack-fold : ((struct stack) procedure * -> *))
    32   (stack-map : ((struct stack) procedure -> list))
    33   (stack-for-each : ((struct stack) procedure -> undefined)) )
     17  make-stack
     18  list->stack
     19  stack->list
     20  stack?
     21  stack-empty?
     22  stack-count
     23  stack-peek
     24  stack-empty!
     25  stack-poke!
     26  stack-push!
     27  stack-cut!
     28  stack-pop!
     29  stack-map
     30  stack-map
     31  stack-for-each
     32  stack-literal-form)
     33
     34(import scheme)
    3435
    3536(import
    36   scheme
    3737  (only chicken
     38    make-parameter
     39    warning
     40    :
    3841    void
    3942    declare
     
    4952(import
    5053  (only ports with-output-to-port)
     54  (only extras format))
     55
     56(import
    5157  (only type-errors define-error-type error-list error-fixnum))
    52 (require-library ports type-errors)
     58(require-library type-errors)
    5359
    5460(declare
     
    6874  (and
    6975    #;(%stack? obj)
    70    (%fx= 3 (%structure-length obj))
    71    (%list? (%stack-list obj)) ) )
     76    (%fx= 3 (%structure-length obj))
     77    (%list? (%stack-list obj)) ) )
    7278
    7379;; Stack List
     
    150156;;;
    151157
    152 (define (make-stack) (%make-stack))
    153 
     158(: make-stack (-> (struct stack)))
     159(define (make-stack)
     160  (%make-stack) )
     161
     162(: list->stack (list -> (struct stack)))
    154163(define (list->stack ls)
    155164  (%check-list 'list->stack ls)
     
    159168    stk ) )
    160169
     170(: stack? (* -> boolean))
    161171(define (stack? obj) (%stack? obj))
    162172
     173(: stack-empty? ((struct stack) -> boolean))
    163174(define (stack-empty? stk)
    164175        (%stack-empty? (%check-stack 'stack-empty? stk)) )
    165176
     177(: stack-count ((struct stack) -> fixnum))
    166178(define (stack-count stk)
    167179        (%stack-count (%check-stack 'stack-count stk)) )
    168180
     181(: stack-peek ((struct stack) #!optional fixnum -> *))
    169182(define (stack-peek stk #!optional (idx 0))
    170183        (%car (%stack-node-ref 'stack-peek (%check-stack 'stack-peek stk) idx)) )
    171184
     185(: stack-empty! ((struct stack) -> undefined))
    172186(define (stack-empty! stk)
    173187        (%stack-empty! (%check-stack 'stack-empty! stk)) )
    174188
     189(: stack-poke! ((struct stack) * #!optional fixnum -> undefined))
    175190(define (stack-poke! stk obj #!optional (idx 0))
    176191        (%set-car!/mutate (%stack-node-ref 'stack-poke! (%check-stack 'stack-poke! stk) idx) obj) )
    177192
     193(: stack-push! ((struct stack) #!rest * -> undefined))
    178194(define (stack-push! stk #!rest ls)
    179195        (unless (%null? ls) (%stack-push! (%check-stack 'stack-push! stk) ls)) )
    180196
     197(: stack-cut! ((struct stack) fixnum #!optional fixnum -> list))
    181198(define (stack-cut! stk start #!optional (end (%stack-count stk)))
    182199  (%check-stack 'stack-cut! stk)
     
    204221        ls ) ) ) )
    205222
     223(: stack-pop! ((struct stack) -> *))
    206224(define (stack-pop! stk)
    207225  (%check-stack 'stack-pop! stk)
     
    209227        (%stack-pop! stk) )
    210228
     229(: stack->list ((struct stack) -> list))
    211230(define (stack->list stk)
    212231        (%list-copy (%stack-list (%check-stack 'stack->list stk))) )
    213232
     233(: stack-fold ((struct stack) procedure * -> *))
    214234(define (stack-fold stk func init)
    215235        (%list-fold/1 func init (%stack-list (%check-stack 'stack-fold stk))) )
    216236
     237(: stack-map ((struct stack) procedure -> list))
    217238(define (stack-map stk func)
    218239        (%list-map/1 func (%stack-list (%check-stack 'stack-map stk))) )
    219240
     241(: stack-for-each ((struct stack) procedure -> undefined))
    220242(define (stack-for-each stk proc)
    221243        (%list-for-each/1 proc (%stack-list (%check-stack 'stack-for-each stk))) )
     
    223245;;; Read/Print Syntax
    224246
    225 (define-constant SRFI-10-FORMAT "#,(~A )")
    226 
    227247(define-record-printer (stack stk out)
    228   (with-output-to-port out
    229     (lambda ()
    230       (display "#,")
    231       (display "(")
    232       (display "stack ")
    233       (display " ")
    234       (display (%stack-list stk))
    235       (display ")") ) ) )
     248  (format out (stack-literal-format) (%stack-list stk)) )
    236249
    237250(define-reader-ctor 'stack list->stack)
    238251
     252(define stack-literal-form
     253  (make-parameter 'srfi-10
     254    (lambda (x)
     255      (case x
     256        ((SRFI-10 srfi-10)
     257          'srfi-10 )
     258        ((UNREAD unread)
     259          'unread )
     260        (else
     261          (warning 'stack-literal-format "invalid form symbol; 'srfi-10 or 'unread" x)
     262          (stack-literal-format))))))
     263
     264(define-constant SRFI-10-FORMAT "#,(stack ~A)")
     265(define-constant UNREAD-FORMAT "#<stack ~A>")
     266
     267(define (stack-literal-format)
     268  (case (stack-literal-form)
     269    ((srfi-10)
     270      SRFI-10-FORMAT )
     271    (else
     272      UNREAD-FORMAT ) ) )
     273
    239274) ;module stack
  • release/4/stack/trunk/stack.setup

    r34125 r34140  
    55(verify-extension-name 'stack)
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "2.2.1")
     7(setup-shared+static-extension-module (extension-name) (extension-version "2.3.0")
    88  #:inline? #t
    99  #:types? #t
    1010  #:compile-options '(
    11     -scrutinize
    1211    -disable-interrupts
     12    -fixnum-arithmetic
    1313    -optimize-level 3
     14    -debug-level 2
    1415    -inline-limit 50
    15     -fixnum-arithmetic
    1616    -no-procedure-checks))
  • release/4/stack/trunk/tests/run.scm

    r28421 r34140  
    1 ;;;; stack-test
     1;;;; run.scm
    22
    3 (require-extension test)
    4 (require-extension stack)
     3(use utils)
    54
    6 (test-group "Empty Stack"
    7   (test-assert (make-stack))
    8   (test-assert (stack? (make-stack)))
    9   (test-assert (stack-empty? (make-stack)))
    10   (test 0 (stack-count (make-stack)))
     5(define-constant TEST-SOURCE-FILE "test-impl.scm")
     6
     7(cond-expand
     8
     9  (unix
     10
     11  (define (csi-n-csc fil #!optional (csi "csi") (csc-opt (compile-file-options)))
     12    (let ((rc
     13          (begin
     14            (print) (print "*** Interpreted ***") (print)
     15            (system (string-append csi " -s " fil))) ) )
     16      (receive (normal? code) (process-status rc)
     17        (if (not normal?)
     18          (exit (fxneg code))
     19          (if (not (zero? code))
     20            (exit code)
     21            (begin
     22              (print) (print "*** Compiled ***") (print)
     23              (parameterize ((compile-file-options csc-opt))
     24                ;NOTE this exits due to 'test-exit'!
     25                (compile-file fil)) ) ) ) ) ) )
     26
     27    ;from manual: library # system
     28    ;; Returns two values: #t if the process exited normally or #f otherwise;
     29    ;; and either the exit status, or the signal number if terminated via signal.
     30    (define (process-status rc)
     31      (define (wait-signaled? x) (not (= 0 (bitwise-and x 127))))
     32      (define (wait-signal x) (bitwise-and x 127))
     33      (define (wait-exit-status x) (arithmetic-shift x -8))
     34      (if (wait-signaled? rc)
     35        (values #f (wait-signal rc))
     36        (values #t (wait-exit-status rc)) ) )
     37
     38    (let* ((args (argv) )
     39           (csi (car args) ) )
     40      (csi-n-csc TEST-SOURCE-FILE csi '("-O3" "-d2"))  )
     41    )
     42
     43  (else ;(windows ...)
     44
     45    (include TEST-SOURCE-FILE) )
    1146)
    12 
    13 (test-group "Push!/Pop!/Peek/Poke!"
    14   (let ([stk (make-stack)])
    15     (stack-push! stk 1)
    16     (stack-push! stk 2 3)
    17     (test 3 (stack-count stk))
    18     (test 3 (stack-pop! stk))
    19     (test 2 (stack-pop! stk))
    20     (test 1 (stack-pop! stk))
    21     (test-assert (stack-empty? stk))
    22     (test-error (stack-pop! stk))
    23     (stack-push! stk 1 2 3)
    24     (test 2 (stack-peek stk 1))
    25     (stack-poke! stk 4 1)
    26     (test 3 (stack-pop! stk))
    27     (test 4 (stack-pop! stk))
    28     (test 1 (stack-count stk)) )
    29 )
    30 
    31 (test-group "Cut!"
    32   (let ([stk (make-stack)])
    33     ;3 2 1
    34     (stack-push! stk 1 2 3)
    35     (test '(2) (stack-cut! stk 1 2))
    36     (test 2 (stack-count stk))
    37     ;3 1
    38     (test '(3) (stack-cut! stk 0 1))
    39     (test 1 (stack-count stk))
    40     ;5 4 1
    41     (stack-push! stk 4 5)
    42     (test '(4 1) (stack-cut! stk 1 3))
    43     (test 1 (stack-count stk))
    44     ;
    45     (test-error (stack-cut! stk -1 3))
    46     (test-error (stack-cut! stk 0 3))
    47     (test-error (stack-cut! stk 0 -3)) )
    48 )
    49 
    50 (test-group "Stack from List"
    51   (let ([stk (make-stack)]
    52         [stk1 (list->stack '(1 2 3))])
    53     ;
    54     (stack-push! stk 1 2 3)
    55     (test '(3 2 1) (stack->list stk))
    56     ;
    57     (test-assert (stack? stk1))
    58     (test 3 (stack-count stk1))
    59     (test 1 (stack-pop! stk1)) )
    60 )
    61 
    62 (test-exit)
Note: See TracChangeset for help on using the changeset viewer.