Changeset 39694 in project


Ignore:
Timestamp:
03/13/21 22:10:44 (2 months ago)
Author:
Kon Lovett
Message:

remove "primitives", use record-variants, add hof tests, new test runner

Location:
release/5/stack/trunk
Files:
1 added
2 deleted
4 edited

Legend:

Unmodified
Added
Removed
  • release/5/stack/trunk/stack.egg

    r38630 r39694  
    33
    44((synopsis "Provides LIFO queue (stack) operations")
    5  (version "3.0.4")
     5 (version "3.0.5")
    66 (category data)
    7  (author "[[kon lovett]]")
     7 (author "Kon Lovett")
    88 (license "BSD")
    9  (dependencies
    10         (check-errors "3.1.0"))
     9 (dependencies record-variants check-errors)
    1110 (test-dependencies test)
    1211 (components
  • release/5/stack/trunk/stack.scm

    r38630 r39694  
    1 ;;;; stack.scm
     1;;;; stack.scm -*- Scheme -*-
    22;;;; Kon Lovett, May '17
    33;;;; Kon Lovett, Mar '09
     
    88;; Issues
    99;;
    10 ;; - All operations inlined & primitive due to high-performance nature.
    1110
    1211(declare
     
    2928  stack-cut!
    3029  stack-pop!
     30  stack-fold
    3131  stack-map
    3232  stack-for-each
    3333  stack-literal-form)
    3434
    35 (import scheme)
    36 (import (srfi 10))
    37 (import (chicken base))
    38 (import (chicken fixnum))
    39 (import (chicken type))
    40 (import (only (chicken port) with-output-to-port))
    41 (import (only (chicken format) format))
    42 (import (only type-errors define-error-type error-list error-fixnum))
    43 
    44 (include "chicken-primitive-object-inlines")
    45 (include "inline-type-checks")
     35(import scheme
     36  (srfi 10)
     37  (chicken base)
     38  (chicken fixnum)
     39  (chicken type)
     40  (only (chicken port) with-output-to-port)
     41  (only (chicken format) format)
     42  (only record-variants define-record-type-variant)
     43  (only type-checks define-check+error-type check-list check-fixnum))
    4644
    4745#| chicken
     46flip
     47foldl
     48foldr
    4849warning
    4950:
     
    6061|#
    6162
     63(define-inline (%list-pair-ref ls0 i0)
     64  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
     65  (let loop ((ls ls0) (i i0))
     66    (cond
     67      ((null? ls) '() )
     68      ((fx= 0 i)  ls )
     69      (else       (loop (cdr ls) (fx- i 1)) ) ) ) )
     70
     71(define-inline (%list-copy ls) (foldr cons '() ls))
     72
     73(define-inline (%list-fold f init ls) (foldl (flip f) init ls))
     74
     75(define-inline (%fxclosed-left? l x h) (and (fx<= l x) (fx< x h)))
     76
    6277;; Stack Type
    6378
    64 (define-type stack (struct stack#stack))
    65 
    66 (define-constant stack 'stack#stack)
    67 
    68 (define stack)
     79;(define-type stack (struct stack#stack))
     80(define-type stack (struct stack))
     81
     82(: make-stack (-> stack))
     83(: list->stack (list -> stack))
     84(: stack? (* -> boolean))
     85(: stack-empty? (stack -> boolean))
     86(: stack-count (stack -> fixnum))
     87(: stack-peek (stack #!optional fixnum -> *))
     88(: stack-empty! (stack -> void))
     89(: stack-poke! (stack * #!optional fixnum -> void))
     90(: stack-push! (stack #!rest * -> void))
     91(: stack-cut! (stack fixnum #!optional fixnum -> list))
     92(: stack-pop! (stack -> *))
     93(: stack->list (stack -> list))
     94(: stack-fold (stack procedure * -> *))
     95(: stack-map (stack procedure -> list))
     96(: stack-for-each (stack procedure -> void))
     97
     98;; Stack Object
     99
     100(define stack 'stack)
     101(define-record-type-variant stack (unchecked inline unsafe)
     102  (%make-stack lst cnt)
     103  (%stack?)
     104  (lst %stack-list %stack-list-set!)
     105  (cnt %stack-count %stack-count-set!))
     106
     107;NOTE ref's forward defined `stack?'
     108(define-check+error-type stack)
     109
     110(define (error-corrupted-stack loc obj)         (##sys#signal-hook #:runtime-error loc "stack corrupted" obj))
     111(define (error-stack-underflow loc stk)         (##sys#signal-hook #:limit-error loc "stack underflow" stk))
     112(define (error-outside-range loc obj low high)  (##sys#signal-hook #:bounds-error loc "out of range" obj low high))
     113
     114(define-inline (%make-empty-stack) (%make-stack '() 0))
    69115
    70116;; Stack List
    71117
    72 (define-inline (%stack-list stk)          (%structure-ref stk 1))
    73 (define-inline (%stack-list-empty? stk)   (%null? (%stack-list stk)))
    74 (define-inline (%stack-list-set! stk ls)  (%structure-set! stk 1 ls))
    75 (define-inline (%stack-list-empty! stk)   (%structure-set!/immediate stk 1 '()))
     118(define-inline (%stack-list-empty? stk)   (null? (%stack-list stk)))
     119(define-inline (%stack-list-empty! stk)   (%stack-list-set! stk '()))
    76120
    77121;; Stack Count
    78122
    79 (define-inline (%stack-count stk)           (%structure-ref stk 2))
    80 (define-inline (%stack-count-set! stk cnt)  (%structure-set!/immediate stk 2 cnt))
    81 (define-inline (%stack-count-inc! stk cnt)  (%stack-count-set! stk (%fx+ (%stack-count stk) cnt)))
    82 (define-inline (%stack-count-dec! stk cnt)  (%stack-count-set! stk (%fx- (%stack-count stk) cnt)))
     123(define-inline (%stack-count-inc! stk cnt)  (%stack-count-set! stk (fx+ (%stack-count stk) cnt)))
     124(define-inline (%stack-count-dec! stk cnt)  (%stack-count-set! stk (fx- (%stack-count stk) cnt)))
    83125
    84126;; Stack Object
    85127
    86 (define-inline (%make-stack) (%make-structure stack '() 0))
    87 
    88 (define-inline (%stack? obj) (%structure-instance? obj stack))
    89 
     128#; ;UNUSED
    90129(define-inline (%valid-as-stack? obj)
    91130  (and
    92     (%fx= 3 (%structure-length obj))
    93     (%list? (%stack-list obj)) ) )
     131    (fx= 3 (%structure-length obj))
     132    (list? (%stack-list obj))
     133    (fixnum? (%stack-count obj)) ) )
    94134
    95135;; Stack Operations
     
    104144  (%stack-count-dec! stk 1)
    105145        (let ((ls (%stack-list stk)))
    106                 (%stack-list-set! stk (%cdr ls))
    107                 (%car ls) ) )
     146                (%stack-list-set! stk (cdr ls))
     147                (car ls) ) )
    108148
    109149(define-inline (%stack-push/1! stk obj)
    110150  (%stack-count-inc! stk 1)
    111         (%stack-list-set! stk (%cons obj (%stack-list stk))) )
     151        (%stack-list-set! stk (cons obj (%stack-list stk))) )
    112152
    113153(define-inline (%stack-push! stk ls)
    114   (if (%null? (%cdr ls))
    115     (%stack-push/1! stk (%car ls))
    116     (%list-for-each/1 (lambda (x) (%stack-push/1! stk x)) ls) ) )
     154  (if (null? (cdr ls))
     155    (%stack-push/1! stk (car ls))
     156    (for-each (lambda (x) (%stack-push/1! stk x)) ls) ) )
    117157
    118158(define-inline (%stack-node-ref loc stk idx)
    119159  (let ((pr (%list-pair-ref (%stack-list stk) idx)))
    120                 (if (%pair? pr)
     160                (if (pair? pr)
    121161                  pr
    122162      (error-outside-range loc idx 0 (%stack-count stk)) ) ) )
     
    124164;; Helpers
    125165
    126 (define-inline (%check-stack loc obj)
    127   (unless (%stack? obj) (error-stack loc obj))
    128   (unless (%valid-as-stack? obj) (error-corrupted-stack loc obj))
    129   obj )
    130 
    131 (define-inline (%check-stack-underflow loc stk)
     166(define (check-stack-underflow loc stk)
    132167  (when (%stack-empty? stk) (error-stack-underflow loc stk))
    133168  stk )
    134169
    135 (define-inline (%check-fixnum-index loc lfx fx hfx)
     170(define (check-fixnum-index loc lfx fx hfx)
    136171  (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx))
    137172  ;cannot return useful value (singular)
     
    140175;;;
    141176
    142 (define-error-type stack)
    143 
    144 (define (error-corrupted-stack loc obj)         (##sys#signal-hook #:runtime-error loc "stack corrupted" obj))
    145 (define (error-stack-underflow loc stk)         (##sys#signal-hook #:limit-error loc "stack underflow" stk))
    146 (define (error-outside-range loc obj low high)  (##sys#signal-hook #:bounds-error loc "out of range" obj low high))
    147 
    148 ;;;
    149 
    150 (: make-stack (-> stack))
    151 ;
    152 (define (make-stack) (%make-stack))
    153 
    154 (: list->stack (list -> stack))
    155 ;
     177(define (make-stack) (%make-empty-stack))
     178
    156179(define (list->stack ls)
    157   (%check-list 'list->stack ls)
    158         (let ((stk (%make-stack)))
    159     (%stack-count-set! stk (%length ls))
     180  (check-list 'list->stack ls)
     181        (let ((stk (%make-empty-stack)))
     182    (%stack-count-set! stk (length ls))
    160183    (%stack-list-set! stk (%list-copy ls))
    161184    stk ) )
    162185
    163 (: stack? (* -> boolean))
    164 ;
    165186(define (stack? obj) (%stack? obj))
    166187
    167 (: stack-empty? (stack -> boolean))
    168 ;
    169 (define (stack-empty? stk) (%stack-empty? (%check-stack 'stack-empty? stk)))
    170 
    171 (: stack-count (stack -> fixnum))
    172 ;
    173 (define (stack-count stk) (%stack-count (%check-stack 'stack-count stk)))
    174 
    175 (: stack-peek (stack #!optional fixnum -> *))
    176 ;
    177 (define (stack-peek stk #!optional (idx 0)) (%car (%stack-node-ref 'stack-peek (%check-stack 'stack-peek stk) idx)))
    178 
    179 (: stack-empty! (stack -> void))
    180 ;
    181 (define (stack-empty! stk) (%stack-empty! (%check-stack 'stack-empty! stk)))
    182 
    183 (: stack-poke! (stack * #!optional fixnum -> void))
    184 ;
    185 (define (stack-poke! stk obj #!optional (idx 0)) (%set-car!/mutate (%stack-node-ref 'stack-poke! (%check-stack 'stack-poke! stk) idx) obj))
    186 
    187 (: stack-push! (stack #!rest * -> void))
    188 ;
    189 (define (stack-push! stk #!rest ls) (unless (%null? ls) (%stack-push! (%check-stack 'stack-push! stk) ls)))
    190 
    191 (: stack-cut! (stack fixnum #!optional fixnum -> list))
    192 ;
     188(define (stack-empty? stk) (%stack-empty? (check-stack 'stack-empty? stk)))
     189
     190(define (stack-count stk) (%stack-count (check-stack 'stack-count stk)))
     191
     192(define (stack-peek stk #!optional (idx 0)) (car (%stack-node-ref 'stack-peek (check-stack 'stack-peek stk) idx)))
     193
     194(define (stack-empty! stk) (%stack-empty! (check-stack 'stack-empty! stk)))
     195
     196(define (stack-poke! stk obj #!optional (idx 0)) (set-car! (%stack-node-ref 'stack-poke! (check-stack 'stack-poke! stk) idx) obj))
     197
     198(define (stack-push! stk #!rest ls) (unless (null? ls) (%stack-push! (check-stack 'stack-push! stk) ls)))
     199
    193200(define (stack-cut! stk start #!optional (end (%stack-count stk)))
    194   (%check-stack 'stack-cut! stk)
    195   (%check-fixnum 'stack-cut! start)
    196   (%check-fixnum 'stack-cut! end)
    197   (%check-fixnum-index 'stack-cut! 0 start end)
    198   (%check-fixnum-index 'stack-cut! start end (%fx+ (%stack-count stk) 1))
    199   (let ((cnt (%fx- end start)))
     201  (check-stack 'stack-cut! stk)
     202  (check-fixnum 'stack-cut! start)
     203  (check-fixnum 'stack-cut! end)
     204  (check-fixnum-index 'stack-cut! 0 start end)
     205  (check-fixnum-index 'stack-cut! start end (fx+ (%stack-count stk) 1))
     206  (let ((cnt (fx- end start)))
    200207    (%stack-count-dec! stk cnt)
    201208    ; From the top?
    202     (if (%fx= 0 start)
     209    (if (fx= 0 start)
    203210      ;then removing leading elements
    204211      (let* (
    205212        (spr (%stack-list stk))
    206         (epr (%list-pair-ref spr (%fx- cnt 1)))
     213        (epr (%list-pair-ref spr (fx- cnt 1)))
    207214        (ls spr) )
    208         (%stack-list-set! stk (%cdr epr))
    209         (%set-cdr!/immediate epr '())
     215        (%stack-list-set! stk (cdr epr))
     216        (set-cdr! epr '())
    210217        ls )
    211218      ;else removing interior elements
    212219      (let* (
    213         (spr (%stack-node-ref 'stack-cut! stk (%fx- start 1)))
     220        (spr (%stack-node-ref 'stack-cut! stk (fx- start 1)))
    214221        (epr (%list-pair-ref spr cnt))
    215         (ls (%cdr spr)) )
    216         (%set-cdr!/mutate spr (%cdr epr))
    217         (%set-cdr!/immediate epr '())
     222        (ls (cdr spr)) )
     223        (set-cdr! spr (cdr epr))
     224        (set-cdr! epr '())
    218225        ls ) ) ) )
    219226
    220 (: stack-pop! (stack -> *))
    221 ;
    222227(define (stack-pop! stk)
    223   (%check-stack 'stack-pop! stk)
    224         (%check-stack-underflow 'stack-pop! stk)
     228  (check-stack 'stack-pop! stk)
     229        (check-stack-underflow 'stack-pop! stk)
    225230        (%stack-pop! stk) )
    226231
    227 (: stack->list (stack -> list))
    228 ;
    229 (define (stack->list stk) (%list-copy (%stack-list (%check-stack 'stack->list stk))))
    230 
    231 (: stack-fold (stack procedure * -> *))
    232 ;
    233 (define (stack-fold stk func init) (%list-fold/1 func init (%stack-list (%check-stack 'stack-fold stk))))
    234 
    235 (: stack-map (stack procedure -> list))
    236 ;
    237 (define (stack-map stk func) (%list-map/1 func (%stack-list (%check-stack 'stack-map stk))))
    238 
    239 (: stack-for-each (stack procedure -> void))
    240 ;
    241 (define (stack-for-each stk proc) (%list-for-each/1 proc (%stack-list (%check-stack 'stack-for-each stk))))
     232(define (stack->list stk) (%list-copy (%stack-list (check-stack 'stack->list stk))))
     233
     234(define (stack-fold stk func init) (%list-fold func init (%stack-list (check-stack 'stack-fold stk))))
     235
     236(define (stack-map stk func) (map func (%stack-list (check-stack 'stack-map stk))))
     237
     238(define (stack-for-each stk proc) (for-each proc (%stack-list (check-stack 'stack-for-each stk))))
    242239
    243240;;; Read/Print Syntax
  • release/5/stack/trunk/tests/run.scm

    r38630 r39694  
    33(import scheme)
    44
    5 ;;; Create Egg Const
     5;; Create Egg Const
    66
    7 (define EGG-NAME "stack")
     7(include-relative "run-ident")
    88
    99;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
     
    1818
    1919(define *args* (argv))
     20(define *current-directory* (cond-expand (unix "./") (else #f)))
     21;no -disable-interrupts or -no-lambda-info
     22(define *csc-init-options* '(-inline-global -local -inline -specialize
     23  -optimize-leaf-routines -clustering -lfa2 -no-trace -unsafe -strict-types))
     24(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
    2025
    21 (define (egg-name args #!optional (def EGG-NAME))
     26(define (remq obj ls)
     27  (let loop ((curr ls) (prev '()))
     28    (cond
     29      ((null? curr)
     30        ls )
     31      ((eq? obj (car curr))
     32        (if (null? prev)
     33          (cdr ls)
     34          (begin
     35            (set-cdr! prev (cdr curr))
     36            ls ) ) )
     37      (else
     38        (loop (cdr curr) curr) ) ) ) )
     39
     40(define (remqs os ls)
     41  (let loop ((ls ls) (os os))
     42    (cond
     43      ((null? os)
     44        ls )
     45      (else
     46        (loop (remq (car os) ls) (cdr os)) ) ) ) )
     47
     48(define (egg-name #!optional (args *args*) (def EGG-NAME))
    2249  (cond
    2350    ((<= 4 (length *args*)) (cadddr *args*) )
     
    2653      (error 'run "cannot determine egg-name") ) ) )
    2754
    28 (define *current-directory* (cond-expand (unix "./") (else #f)))
    29 (define *egg* (egg-name *args*))
     55(define (as-csc-options ls)
     56  (apply string-append (intersperse (map symbol->string ls) " ")) )
    3057
    31 ;no -disable-interrupts or -no-lambda-info
    32 (define *csc-options* "-inline-global -local -inline \
    33   -specialize -optimize-leaf-routines -clustering -lfa2 \
    34   -no-trace -unsafe \
    35   -strict-types")
     58(define (csc-options)
     59  (as-csc-options (remqs *csc-remv-options* *csc-init-options*)) )
    3660
    37 (define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
    3861(define (test-filename name) (string-append name "-test"))
     62
    3963(define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
    4064
     
    4367    name
    4468    (make-pathname *current-directory* (test-filename name) "scm") ) )
     69
     70;;
    4571
    4672(define (run-test-evaluated source)
     
    5480  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
    5581
    56 ;;;
    57 
    58 (define (run-test #!optional (name *egg*) (csc-options *csc-options*))
     82(define (run-test #!optional (name (egg-name)) (csc-options (csc-options)))
    5983  (let (
    6084    (source (ensure-test-source-name name)) )
     
    6589    (run-test-compiled source csc-options) ) )
    6690
    67 (define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     91(define (run-tests #!optional (tests (test-files)) (csc-options (csc-options)))
    6892  (for-each (cut run-test <> csc-options) tests) )
    6993
    70 ;;; Do Test
     94;; Do Test
    7195
    7296(run-tests)
  • release/5/stack/trunk/tests/stack-test.scm

    r35980 r39694  
    1818
    1919(test-group "Push!/Pop!/Peek/Poke!"
    20   (let ([stk (make-stack)])
     20  (let ((stk (make-stack)))
    2121    (stack-push! stk 1)
    2222    (stack-push! stk 2 3)
     
    3636
    3737(test-group "Cut!"
    38   (let ([stk (make-stack)])
     38  (let ((stk (make-stack)))
    3939    ;3 2 1
    4040    (stack-push! stk 1 2 3)
     
    5555
    5656(test-group "Stack from List"
    57   (let ([stk (make-stack)]
    58         [stk1 (list->stack '(1 2 3))])
     57  (let ((stk (make-stack))
     58        (stk1 (list->stack '(1 2 3))))
    5959    ;
    6060    (stack-push! stk 1 2 3)
     
    6666)
    6767
     68(test-group "Stack HOF"
     69  (let ((stk (list->stack '(1 2 3))))
     70    (test 6 (stack-fold stk + 0))
     71    (test '(2 3 4) (stack-map stk add1)) )
     72)
     73
    6874;;;
    6975
Note: See TracChangeset for help on using the changeset viewer.