Changeset 39694 in project for release/5/stack/trunk/stack.scm


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

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

File:
1 edited

Legend:

Unmodified
Added
Removed
  • 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
Note: See TracChangeset for help on using the changeset viewer.