- Timestamp:
- 04/18/20 19:31:06 (9 months ago)
- Location:
- release/5/stack/trunk
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
release/5/stack/trunk/stack.egg
r38501 r38630 3 3 4 4 ((synopsis "Provides LIFO queue (stack) operations") 5 (version "3.0. 3")5 (version "3.0.4") 6 6 (category data) 7 7 (author "[[kon lovett]]") … … 13 13 (extension stack 14 14 (types-file) 15 (csc-options "-O3" "-d1" "- local" "-no-procedure-checks" "-no-bound-checks") ) ) )15 (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") ) ) ) -
release/5/stack/trunk/stack.scm
r38501 r38630 17 17 18 18 (;export 19 ;stack20 19 make-stack 21 20 list->stack … … 66 65 67 66 (define-constant stack 'stack#stack) 68 ;(define stack 'stack#stack) 69 70 ;; Stack Support 71 72 (define-inline (%make-stack) 73 (%make-structure stack '() 0) ) 74 75 (define-inline (%stack? obj) 76 (%structure-instance? obj stack) ) 77 78 (define-inline (%valid-stack? obj) 67 68 (define stack) 69 70 ;; Stack List 71 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 '())) 76 77 ;; Stack Count 78 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))) 83 84 ;; Stack Object 85 86 (define-inline (%make-stack) (%make-structure stack '() 0)) 87 88 (define-inline (%stack? obj) (%structure-instance? obj stack)) 89 90 (define-inline (%valid-as-stack? obj) 79 91 (and 80 #;(%stack? obj)81 92 (%fx= 3 (%structure-length obj)) 82 93 (%list? (%stack-list obj)) ) ) 83 94 84 ;; Stack List85 86 (define-inline (%stack-list stk)87 (%structure-ref stk 1) )88 89 (define-inline (%stack-list-empty? stk)90 (%null? (%stack-list stk)) )91 92 (define-inline (%stack-list-set! stk ls)93 (%structure-set! stk 1 ls) )94 95 (define-inline (%stack-list-empty! stk)96 (%structure-set!/immediate stk 1 '()) )97 98 ;; Stack Count99 100 (define-inline (%stack-count stk)101 (%structure-ref stk 2) )102 103 (define-inline (%stack-count-set! stk cnt)104 (%structure-set!/immediate stk 2 cnt) )105 106 (define-inline (%stack-count-inc! stk cnt)107 (%stack-count-set! stk (%fx+ (%stack-count stk) cnt)) )108 109 (define-inline (%stack-count-dec! stk cnt)110 (%stack-count-set! stk (%fx- (%stack-count stk) cnt)) )111 112 95 ;; Stack Operations 113 96 114 (define-inline (%stack-empty? stk) 115 (%stack-list-empty? stk)) 97 (define-inline (%stack-empty? stk) (%stack-list-empty? stk)) 116 98 117 99 (define-inline (%stack-empty! stk) … … 144 126 (define-inline (%check-stack loc obj) 145 127 (unless (%stack? obj) (error-stack loc obj)) 146 (unless (%valid- stack? obj) (error-corrupted-stack loc obj))128 (unless (%valid-as-stack? obj) (error-corrupted-stack loc obj)) 147 129 obj ) 148 130 … … 153 135 (define-inline (%check-fixnum-index loc lfx fx hfx) 154 136 (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx)) 137 ;cannot return useful value (singular) 155 138 (void) ) 156 139 … … 159 142 (define-error-type stack) 160 143 161 (define (error-corrupted-stack loc obj) 162 (##sys#signal-hook #:runtime-error loc "stack corrupted" obj) ) 163 164 (define (error-stack-underflow loc stk) 165 (##sys#signal-hook #:limit-error loc "stack underflow" stk) ) 166 167 (define (error-outside-range loc obj low high) 168 (##sys#signal-hook #:bounds-error loc "out of range" obj low high) ) 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)) 169 147 170 148 ;;; 171 149 172 (define stack )173 174 150 (: make-stack (-> stack)) 175 151 ; 176 (define (make-stack) 177 (%make-stack) ) 152 (define (make-stack) (%make-stack)) 178 153 179 154 (: list->stack (list -> stack)) … … 192 167 (: stack-empty? (stack -> boolean)) 193 168 ; 194 (define (stack-empty? stk) 195 (%stack-empty? (%check-stack 'stack-empty? stk)) ) 169 (define (stack-empty? stk) (%stack-empty? (%check-stack 'stack-empty? stk))) 196 170 197 171 (: stack-count (stack -> fixnum)) 198 172 ; 199 (define (stack-count stk) 200 (%stack-count (%check-stack 'stack-count stk)) ) 173 (define (stack-count stk) (%stack-count (%check-stack 'stack-count stk))) 201 174 202 175 (: stack-peek (stack #!optional fixnum -> *)) 203 176 ; 204 (define (stack-peek stk #!optional (idx 0)) 205 (%car (%stack-node-ref 'stack-peek (%check-stack 'stack-peek stk) idx)) ) 177 (define (stack-peek stk #!optional (idx 0)) (%car (%stack-node-ref 'stack-peek (%check-stack 'stack-peek stk) idx))) 206 178 207 179 (: stack-empty! (stack -> void)) 208 180 ; 209 (define (stack-empty! stk) 210 (%stack-empty! (%check-stack 'stack-empty! stk)) ) 181 (define (stack-empty! stk) (%stack-empty! (%check-stack 'stack-empty! stk))) 211 182 212 183 (: stack-poke! (stack * #!optional fixnum -> void)) 213 184 ; 214 (define (stack-poke! stk obj #!optional (idx 0)) 215 (%set-car!/mutate (%stack-node-ref 'stack-poke! (%check-stack 'stack-poke! stk) idx) obj) ) 185 (define (stack-poke! stk obj #!optional (idx 0)) (%set-car!/mutate (%stack-node-ref 'stack-poke! (%check-stack 'stack-poke! stk) idx) obj)) 216 186 217 187 (: stack-push! (stack #!rest * -> void)) 218 188 ; 219 (define (stack-push! stk #!rest ls) 220 (unless (%null? ls) (%stack-push! (%check-stack 'stack-push! stk) ls)) ) 189 (define (stack-push! stk #!rest ls) (unless (%null? ls) (%stack-push! (%check-stack 'stack-push! stk) ls))) 221 190 222 191 (: stack-cut! (stack fixnum #!optional fixnum -> list)) … … 233 202 (if (%fx= 0 start) 234 203 ;then removing leading elements 235 (let* ((spr (%stack-list stk)) 236 (epr (%list-pair-ref spr (%fx- cnt 1))) 237 (ls spr)) 204 (let* ( 205 (spr (%stack-list stk)) 206 (epr (%list-pair-ref spr (%fx- cnt 1))) 207 (ls spr) ) 238 208 (%stack-list-set! stk (%cdr epr)) 239 209 (%set-cdr!/immediate epr '()) 240 210 ls ) 241 211 ;else removing interior elements 242 (let* ((spr (%stack-node-ref 'stack-cut! stk (%fx- start 1))) 243 (epr (%list-pair-ref spr cnt)) 244 (ls (%cdr spr))) 212 (let* ( 213 (spr (%stack-node-ref 'stack-cut! stk (%fx- start 1))) 214 (epr (%list-pair-ref spr cnt)) 215 (ls (%cdr spr)) ) 245 216 (%set-cdr!/mutate spr (%cdr epr)) 246 217 (%set-cdr!/immediate epr '()) … … 256 227 (: stack->list (stack -> list)) 257 228 ; 258 (define (stack->list stk) 259 (%list-copy (%stack-list (%check-stack 'stack->list stk))) ) 229 (define (stack->list stk) (%list-copy (%stack-list (%check-stack 'stack->list stk)))) 260 230 261 231 (: stack-fold (stack procedure * -> *)) 262 232 ; 263 (define (stack-fold stk func init) 264 (%list-fold/1 func init (%stack-list (%check-stack 'stack-fold stk))) ) 233 (define (stack-fold stk func init) (%list-fold/1 func init (%stack-list (%check-stack 'stack-fold stk)))) 265 234 266 235 (: stack-map (stack procedure -> list)) 267 236 ; 268 (define (stack-map stk func) 269 (%list-map/1 func (%stack-list (%check-stack 'stack-map stk))) ) 237 (define (stack-map stk func) (%list-map/1 func (%stack-list (%check-stack 'stack-map stk)))) 270 238 271 239 (: stack-for-each (stack procedure -> void)) 272 240 ; 273 (define (stack-for-each stk proc) 274 (%list-for-each/1 proc (%stack-list (%check-stack 'stack-for-each stk))) ) 241 (define (stack-for-each stk proc) (%list-for-each/1 proc (%stack-list (%check-stack 'stack-for-each stk)))) 275 242 276 243 ;;; Read/Print Syntax 277 244 278 (define-record-printer (stack stk out) 279 (format out (stack-literal-format) (%stack-list stk)) ) 245 (define-record-printer (stack stk out) (format out (stack-literal-format) (%stack-list stk))) 280 246 281 247 (define-reader-ctor 'stack list->stack) … … 285 251 (lambda (x) 286 252 (case x 287 ((SRFI-10 srfi-10) 288 'srfi-10 ) 289 ((UNREAD unread) 290 'unread ) 253 ((SRFI-10 srfi-10) 'srfi-10 ) 254 ((UNREAD unread) 'unread ) 291 255 (else 292 256 (warning 'stack-literal-format "invalid form symbol; 'srfi-10 or 'unread" x) … … 298 262 (define (stack-literal-format) 299 263 (case (stack-literal-form) 300 ((srfi-10) 301 SRFI-10-FORMAT ) 302 (else 303 UNREAD-FORMAT ) ) ) 264 ((srfi-10) SRFI-10-FORMAT ) 265 (else UNREAD-FORMAT ) ) ) 304 266 305 267 ) ;module stack -
release/5/stack/trunk/tests/run.scm
r38501 r38630 32 32 (define *csc-options* "-inline-global -local -inline \ 33 33 -specialize -optimize-leaf-routines -clustering -lfa2 \ 34 -no-trace -unsafe") 34 -no-trace -unsafe \ 35 -strict-types") 35 36 36 37 (define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
Note: See TracChangeset
for help on using the changeset viewer.