Changeset 34096 in project


Ignore:
Timestamp:
05/28/17 09:22:05 (3 months ago)
Author:
kon
Message:

re-order, use typed-modules

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

Legend:

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

    r19816 r34096  
    384384(define-inline (%bytevector=? bv1 bv2)
    385385  (let ((n (%bytevector-length bv1)))
    386     (and (%fx= n (%bytevector-length bv2))
    387          (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) ) )
     386    (and
     387      (%fx= n (%bytevector-length bv2))
     388      (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) ) )
    388389
    389390(define-inline (%bytevector-ref bv i) (%byteblock-ref bv i))
     
    439440         (d (%fx- l1 l2))
    440441         (r (%string-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
    441     (if (%fxzero? r) d
    442         r ) ) )
     442    (if (%fxzero? r)
     443      d
     444      r ) ) )
    443445
    444446(define-inline (%string=? s1 s2) (%fxzero? (%string-compare s1 s2)))
     
    455457         (d (%fx- l1 l2))
    456458         (r (%string-ci-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
    457     (if (%fxzero? r) d
    458         r ) ) )
     459    (if (%fxzero? r)
     460      d
     461      r ) ) )
    459462
    460463(define-inline (%string-ci=? s1 s2) (%fxzero? (%string-ci-compare s1 s2)))
     
    538541(define-inline (%wordblock-set!/immediate wb i v) (##core#inline "C_i_set_i_slot" wb i v))
    539542(define-inline (%wordblock-set! wb i v)
    540   (if (%immediate? v) (%wordblock-set!/immediate wb i v)
    541       (%wordblock-set!/mutate wb i v) ) )
     543  (if (%immediate? v)
     544    (%wordblock-set!/immediate wb i v)
     545    (%wordblock-set!/mutate wb i v) ) )
    542546
    543547;; Generic-vector (wordblock)
     
    617621  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
    618622  (let loop ((ls ls0) (i i0))
    619     (cond ((%null? ls)  '() )
    620                 ((%fx= 0 i)   (%car ls) )
    621                 (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
     623    (cond
     624      ((%null? ls)  '() )
     625      ((%fx= 0 i)   (%car ls) )
     626      (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
    622627
    623628(define-inline (%list-pair-ref ls0 i0)
    624629  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
    625630  (let loop ((ls ls0) (i i0))
    626     (cond ((%null? ls)  '() )
    627                 ((%fx= 0 i)   ls )
    628                 (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
     631    (cond
     632      ((%null? ls)  '() )
     633      ((%fx= 0 i)   ls )
     634      (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
    629635
    630636(define-inline (%last-pair ls0)
     
    636642  ;(assert (proper-list? ls0))
    637643  (let copy-rest ((ls ls0))
    638     (if (%null? ls) '()
    639         (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
     644    (if (%null? ls)
     645      '()
     646      (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
    640647
    641648(define-inline (%append! . lss)
    642649  ;(assert (and (proper-list? lss) (for-each (cut proper-list? <>) lss)))
    643   (let ((lss (let position-at-first-pair ((lss lss))
    644                (cond ((%null? lss)        '() )
    645                      ((%null? (%car lss))  (position-at-first-pair (%cdr lss)) )
    646                      (else                 lss ) ) ) ) )
    647     (if (%null? lss) '()
    648         (let ((ls0 (%car lss)))
    649           ;(assert (pair? ls0))
    650           (let append!-rest ((lss (%cdr lss)) (pls ls0))
    651             (if (%null? lss) ls0
    652                 (let ((ls (%car lss)))
    653                   (cond ((%null? ls)
    654                          (append!-rest (%cdr lss) pls) )
    655                         (else
    656                          (%set-cdr!/mutate (%last-pair pls) ls)
    657                          (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
     650  (let ((lss
     651          (let position-at-first-pair ((lss lss))
     652            (cond
     653              ((%null? lss)        '() )
     654              ((%null? (%car lss))  (position-at-first-pair (%cdr lss)) )
     655              (else                 lss ) ) ) ) )
     656    (if (%null? lss)
     657      '()
     658      (let ((ls0 (%car lss)))
     659        ;(assert (pair? ls0))
     660        (let append!-rest ((lss (%cdr lss)) (pls ls0))
     661          (if (%null? lss)
     662            ls0
     663            (let ((ls (%car lss)))
     664              (cond
     665                ((%null? ls)
     666                  (append!-rest (%cdr lss) pls) )
     667                (else
     668                  (%set-cdr!/mutate (%last-pair pls) ls)
     669                  (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
    658670
    659671(define-inline (%delq! x ls0)
    660672  ;(assert (proper-list? ls0))
    661673  (let find-elm ((ls ls0) (ppr #f))
    662     (cond ((%null? ls)
    663            ls0 )
    664                 ((%eq? x (%car ls))
    665                  (cond (ppr
    666                         (%set-cdr! ppr (%cdr ls))
    667                         ls0 )
    668                        (else
    669                         (%cdr ls) ) ) )
    670                 (else
    671                  (find-elm (%cdr ls) ls) ) ) ) )
     674    (cond
     675      ((%null? ls)
     676       ls0 )
     677      ((%eq? x (%car ls))
     678        (cond
     679          (ppr
     680            (%set-cdr! ppr (%cdr ls))
     681            ls0 )
     682          (else
     683            (%cdr ls) ) ) )
     684      (else
     685        (find-elm (%cdr ls) ls) ) ) ) )
    672686
    673687(define-inline (%list-fold/1 func init ls0)
    674688  ;(assert (and (proper-list? ls0) (procedure? func)))
    675689  (let loop ((ls ls0) (acc init))
    676     (if (%null? ls) acc
    677         (loop (%cdr ls) (func (%car ls) acc)) ) ) )
     690    (if (%null? ls)
     691      acc
     692      (loop (%cdr ls) (func (%car ls) acc)) ) ) )
    678693
    679694(define-inline (%list-map/1 func ls0)
    680695  ;(assert (and (proper-list? ls0) (procedure? func)))
    681696  (let loop ((ls ls0))
    682     (if (%null? ls) '()
    683         (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
     697    (if (%null? ls)
     698      '()
     699      (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
    684700
    685701(define-inline (%list-for-each/1 proc ls0)
     
    694710(define-inline (%list . objs)
    695711  (let loop ((objs objs))
    696     (if (%null? objs) '()
    697         (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     712    (if (%null? objs)
     713      '()
     714      (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
    698715
    699716(define-inline (%make-list n e)
    700717  (let loop ((n n) (ls '()))
    701     (if (%fxzero? n) ls
    702         (loop (%fxsub1 n) (%cons e ls)) ) ) )
     718    (if (%fxzero? n)
     719      ls
     720      (loop (%fxsub1 n) (%cons e ls)) ) ) )
    703721
    704722(define-inline (%list-take ls0 n)
    705723  (let loop ((ls ls0) (n n))
    706     (if (%fxzero? n) '()
    707         (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
     724    (if (%fxzero? n)
     725      '()
     726      (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
    708727
    709728(define-inline (%list-drop ls0 n)
    710729  (let loop ((ls ls0) (n n))
    711     (if (%fxzero? n) ls
    712         (loop (%cdr ls) (%fxsub1 n)) ) ) )
     730    (if (%fxzero? n)
     731      ls
     732      (loop (%cdr ls) (%fxsub1 n)) ) ) )
    713733
    714734(define-inline (%list-any/1 pred? ls)
    715735  (let loop ((ls ls))
    716     (and (not (%null? ls))
    717          (or (pred? (%car ls))
    718              (loop (%cdr ls)) ) ) ) )
     736    (and
     737      (not (%null? ls))
     738      (or
     739        (pred? (%car ls))
     740        (loop (%cdr ls)) ) ) ) )
    719741
    720742(define-inline (%list-every/1 pred? ls)
    721743  (let loop ((ls ls) (last #t))
    722     (if (%null? ls) last
    723         (let ((this (pred? (%car ls))))
    724           (and this
    725                (loop (%cdr ls) this)) ) ) ) )
     744    (if (%null? ls)
     745      last
     746      (let ((this (pred? (%car ls))))
     747        (and
     748          this
     749          (loop (%cdr ls) this)) ) ) ) )
    726750
    727751(define-inline (%list-length ls0)
    728752  (let loop ((ls ls0) (n 0))
    729     (if (%null? ls) n
    730         (loop (%cdr ls) (%fxadd1 n)) ) ) )
     753    (if (%null? ls)
     754      n
     755      (loop (%cdr ls) (%fxadd1 n)) ) ) )
    731756
    732757(define-inline (%list-find pred? ls)
    733758  (let loop ((ls ls))
    734     (and (not (%null? ls))
    735          (or (let ((elm (%car ls))) (and (pred? elm) elm))
    736              (loop (%cdr ls)) ) ) ) )
     759    (and
     760      (not (%null? ls))
     761      (or
     762        (let ((elm (%car ls))) (and (pred? elm) elm))
     763        (loop (%cdr ls)) ) ) ) )
    737764
    738765(define-inline (%alist-ref key al #!optional (test eqv?) def)
    739766  (let loop ((al al))
    740     (cond ((%null? al) def )
    741           ((test key (%caar al)) (%cdar al) )
    742           (else (loop (%cdr al)) ) ) ) )
     767    (cond
     768      ((%null? al) def )
     769      ((test key (%caar al)) (%cdar al) )
     770      (else (loop (%cdr al)) ) ) ) )
    743771
    744772(define-inline (%alist-update! key val al0 #!optional (test eqv?))
    745773  (let loop ((al al0))
    746     (cond ((%null? al) (%cons (%cons key val) al0) )
    747           ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
    748           (else (loop (%cdr al)) ) ) ) )
     774    (cond
     775      ((%null? al) (%cons (%cons key val) al0) )
     776      ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
     777      (else (loop (%cdr al)) ) ) ) )
    749778
    750779(define-inline (%alist-delete! key al0 #!optional (test equal?))
    751780  (let loop ((al al0) (prv #f))
    752     (cond ((%null? al) al0)
    753           ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
    754           (else (loop (%cdr al) al) ) ) ) )
     781    (cond
     782      ((%null? al) al0)
     783      ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
     784      (else (loop (%cdr al) al) ) ) ) )
    755785
    756786;; Structure (wordblock)
     
    905935(define-inline (%closure-decoration c test)
    906936  (let find-decor ((i (%fxsub1 (%closure-length c))))
    907     (and (%fxpositive? i)
    908          (let ((x (%closure-ref c i)))
    909            (if (test x) x
    910                (find-decor (%fxsub1 i)) ) ) ) ) )
     937    (and
     938      (%fxpositive? i)
     939      (let ((x (%closure-ref c i)))
     940        (if (test x)
     941          x
     942          (find-decor (%fxsub1 i)) ) ) ) ) )
    911943
    912944(define-inline (%closure-decorate! c test dcor)
    913945  (let ((l (%closure-length c)))
    914946    (let find-decor ((i (%fxsub l)))
    915       (cond ((%fxzero? i)
    916              (let ((nc (%make-closure (%fxadd1 l))))
    917                (%closure-copy nc c l)
    918                (##core#inline "C_copy_pointer" c nc)
    919                (dcor nc i) ) )
    920             (else
    921              (let ((x (%closure-ref c i)))
    922                (if (test x) (dcor c i)
    923                    (find-decor (%fxsub i)) ) ) ) ) ) ) )
     947      (cond
     948        ((%fxzero? i)
     949          (let ((nc (%make-closure (%fxadd1 l))))
     950            (%closure-copy nc c l)
     951            (##core#inline "C_copy_pointer" c nc)
     952            (dcor nc i) ) )
     953        (else
     954          (let ((x (%closure-ref c i)))
     955            (if (test x)
     956              (dcor c i)
     957              (find-decor (%fxsub i)) ) ) ) ) ) ) )
    924958
    925959(define-inline (%closure-lambda-info c)
     
    938972(define-inline (%qualified-symbol? s)
    939973  (let ((str (%symbol-string s)))
    940     (and (%fxpositive? (%string-size str))
    941          (%fx<= (%byteblock-ref str 0) NAMESPACE-MAX-ID-LEN) ) ) )
     974    (and
     975      (%fxpositive? (%string-size str))
     976      (%fx<= (%byteblock-ref str 0) NAMESPACE-MAX-ID-LEN) ) ) )
    942977
    943978;Safe
  • release/4/stack/tags/2.2.0/stack.meta

    r33631 r34096  
    88 (doc-from-wiki)
    99 (depends
     10        (typed-modules "0.1")
    1011        (setup-helper "1.5.2")
    1112        (check-errors "1.9.0"))
  • release/4/stack/tags/2.2.0/stack.scm

    r19816 r34096  
    11;;;; stack.scm
    22;;;; Kon Lovett, Mar '09
     3;;;; Kon Lovett, May '17
    34
    45;;;; Stack data structure (LIFO queue) where the value is mutable,
     
    1112;;;
    1213
     14(import typed-modules)
     15
    1316(module stack
    1417
    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       define-constant
    38       define-for-syntax
    39       include
    40       optional let-optionals  ;due to #!optional implementation
    41       unless when
    42       define-record-printer
    43       define-reader-ctor)
    44     (only ports with-output-to-port)
    45     (only type-errors define-error-type error-list error-fixnum))
    46 
    47   (require-library ports type-errors)
    48 
    49   (declare
    50     (bound-to-procedure
    51       ##sys#signal-hook ) )
    52 
    53   (include "chicken-primitive-object-inlines")
    54   (include "inline-type-checks")
     18(;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 list -> 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)) )
     34
     35(import
     36  scheme
     37  (only chicken
     38    void
     39    declare
     40    define-inline
     41    define-constant
     42    define-for-syntax
     43    include
     44    optional let-optionals  ;due to #!optional implementation
     45    unless when
     46    define-record-printer
     47    define-reader-ctor))
     48
     49(import
     50  (only ports with-output-to-port)
     51  (only type-errors define-error-type error-list error-fixnum))
     52(require-library ports type-errors)
     53
     54(declare
     55  (bound-to-procedure
     56    ##sys#signal-hook ) )
     57
     58(include "chicken-primitive-object-inlines")
     59(include "inline-type-checks")
    5560
    5661;; Stack Support
     
    6166
    6267(define-inline (%valid-stack? obj)
    63   (and #;(%stack? obj)
    64        (%fx= 3 (%structure-length obj))
    65        (%list? (%stack-list obj)) ) )
     68  (and
     69    #;(%stack? obj)
     70   (%fx= 3 (%structure-length obj))
     71   (%list? (%stack-list obj)) ) )
    6672
    6773;; Stack List
     
    104110
    105111(define-inline (%stack-push! stk ls)
    106   (if (%null? (%cdr ls)) (%stack-push/1! stk (%car ls))
    107             (%list-for-each/1 (lambda (x) (%stack-push/1! stk x)) ls) ) )
     112  (if (%null? (%cdr ls))
     113    (%stack-push/1! stk (%car ls))
     114    (%list-for-each/1 (lambda (x) (%stack-push/1! stk x)) ls) ) )
    108115
    109116(define-inline (%stack-node-ref loc stk idx)
    110117  (let ((pr (%list-pair-ref (%stack-list stk) idx)))
    111                 (if (%pair? pr) pr
    112                           (error-outside-range loc idx 0 (%stack-count stk)) ) ) )
     118                (if (%pair? pr)
     119                  pr
     120      (error-outside-range loc idx 0 (%stack-count stk)) ) ) )
    113121
    114122;; Helpers
    115 
    116123
    117124(define-inline (%check-stack loc obj)
    118125  (unless (%stack? obj) (error-stack loc obj))
    119   (unless (%valid-stack? obj) (error-corrupted-stack loc obj)) )
     126  (unless (%valid-stack? obj) (error-corrupted-stack loc obj))
     127  obj )
    120128
    121129(define-inline (%check-stack-underflow loc stk)
    122   (when (%stack-empty? stk) (error-stack-underflow loc stk)) )
     130  (when (%stack-empty? stk) (error-stack-underflow loc stk))
     131  stk )
    123132
    124133(define-inline (%check-fixnum-index loc lfx fx hfx)
    125   (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
     134  (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx))
     135  (void) )
    126136
    127137;;;
     
    152162
    153163(define (stack-empty? stk)
    154   (%check-stack 'stack-empty? stk)
    155         (%stack-empty? stk) )
     164        (%stack-empty? (%check-stack 'stack-empty? stk)) )
    156165
    157166(define (stack-count stk)
    158   (%check-stack 'stack-count stk)
    159         (%stack-count stk) )
     167        (%stack-count (%check-stack 'stack-count stk)) )
    160168
    161169(define (stack-peek stk #!optional (idx 0))
    162   (%check-stack 'stack-peek stk)
    163         (%car (%stack-node-ref 'stack-peek stk idx)) )
     170        (%car (%stack-node-ref 'stack-peek (%check-stack 'stack-peek stk) idx)) )
    164171
    165172(define (stack-empty! stk)
    166   (%check-stack 'stack-empty! stk)
    167         (%stack-empty! stk) )
     173        (%stack-empty! (%check-stack 'stack-empty! stk)) )
    168174
    169175(define (stack-poke! stk obj #!optional (idx 0))
    170   (%check-stack 'stack-poke! stk)
    171         (%set-car!/mutate (%stack-node-ref 'stack-poke! stk idx) obj) )
     176        (%set-car!/mutate (%stack-node-ref 'stack-poke! (%check-stack 'stack-poke! stk) idx) obj) )
    172177
    173178(define (stack-push! stk #!rest ls)
    174   (%check-stack 'stack-push! stk)
    175         (unless (%null? ls) (%stack-push! stk ls)) )
     179        (unless (%null? ls) (%stack-push! (%check-stack 'stack-push! stk) ls)) )
    176180
    177181(define (stack-cut! stk start #!optional (end (%stack-count stk)))
     
    185189    ; From the top?
    186190    (if (%fx= 0 start)
    187         ;then removing leading elements
    188         (let* ((spr (%stack-list stk))
    189                (epr (%list-pair-ref spr (%fx- cnt 1)))
    190                (ls spr))
    191           (%stack-list-set! stk (%cdr epr))
    192           (%set-cdr!/immediate epr '())
    193           ls )
    194         ;else removing interior elements
    195         (let* ((spr (%stack-node-ref 'stack-cut! stk (%fx- start 1)))
    196                (epr (%list-pair-ref spr cnt))
    197                (ls (%cdr spr)))
    198           (%set-cdr!/mutate spr (%cdr epr))
    199           (%set-cdr!/immediate epr '())
    200           ls ) ) ) )
     191      ;then removing leading elements
     192      (let* ((spr (%stack-list stk))
     193             (epr (%list-pair-ref spr (%fx- cnt 1)))
     194             (ls spr))
     195        (%stack-list-set! stk (%cdr epr))
     196        (%set-cdr!/immediate epr '())
     197        ls )
     198      ;else removing interior elements
     199      (let* ((spr (%stack-node-ref 'stack-cut! stk (%fx- start 1)))
     200             (epr (%list-pair-ref spr cnt))
     201             (ls (%cdr spr)))
     202        (%set-cdr!/mutate spr (%cdr epr))
     203        (%set-cdr!/immediate epr '())
     204        ls ) ) ) )
    201205
    202206(define (stack-pop! stk)
     
    206210
    207211(define (stack->list stk)
    208   (%check-stack 'stack->list stk)
    209         (%list-copy (%stack-list stk)) )
     212        (%list-copy (%stack-list (%check-stack 'stack->list stk))) )
    210213
    211214(define (stack-fold stk func init)
    212   (%check-stack 'stack-fold stk)
    213         (%list-fold/1 func init (%stack-list stk)) )
     215        (%list-fold/1 func init (%stack-list (%check-stack 'stack-fold stk))) )
    214216
    215217(define (stack-map stk func)
    216   (%check-stack 'stack-map stk)
    217         (%list-map/1 func (%stack-list stk)) )
     218        (%list-map/1 func (%stack-list (%check-stack 'stack-map stk))) )
    218219
    219220(define (stack-for-each stk proc)
    220   (%check-stack 'stack-for-each stk)
    221         (%list-for-each/1 proc (%stack-list stk)) )
     221        (%list-for-each/1 proc (%stack-list (%check-stack 'stack-for-each stk))) )
    222222
    223223;;; Read/Print Syntax
     224
     225(define-constant SRFI-10-FORMAT "#,(~A )")
    224226
    225227(define-record-printer (stack stk out)
    226228  (with-output-to-port out
    227229    (lambda ()
    228       (display "#,(stack ")
     230      (display "#,")
     231      (display "(")
     232      (display "stack ")
     233      (display " ")
    229234      (display (%stack-list stk))
    230       (display #\)) ) ) )
     235      (display ")") ) ) )
    231236
    232237(define-reader-ctor 'stack list->stack)
  • release/4/stack/tags/2.2.0/stack.setup

    r33631 r34096  
    55(verify-extension-name 'stack)
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "2.1.5")
     7(setup-shared-extension-module (extension-name) (extension-version "2.2.0")
    88  #:inline? #t
    99  #:types? #t
  • release/4/stack/trunk/chicken-primitive-object-inlines.scm

    r19816 r34096  
    384384(define-inline (%bytevector=? bv1 bv2)
    385385  (let ((n (%bytevector-length bv1)))
    386     (and (%fx= n (%bytevector-length bv2))
    387          (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) ) )
     386    (and
     387      (%fx= n (%bytevector-length bv2))
     388      (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) ) )
    388389
    389390(define-inline (%bytevector-ref bv i) (%byteblock-ref bv i))
     
    439440         (d (%fx- l1 l2))
    440441         (r (%string-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
    441     (if (%fxzero? r) d
    442         r ) ) )
     442    (if (%fxzero? r)
     443      d
     444      r ) ) )
    443445
    444446(define-inline (%string=? s1 s2) (%fxzero? (%string-compare s1 s2)))
     
    455457         (d (%fx- l1 l2))
    456458         (r (%string-ci-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
    457     (if (%fxzero? r) d
    458         r ) ) )
     459    (if (%fxzero? r)
     460      d
     461      r ) ) )
    459462
    460463(define-inline (%string-ci=? s1 s2) (%fxzero? (%string-ci-compare s1 s2)))
     
    538541(define-inline (%wordblock-set!/immediate wb i v) (##core#inline "C_i_set_i_slot" wb i v))
    539542(define-inline (%wordblock-set! wb i v)
    540   (if (%immediate? v) (%wordblock-set!/immediate wb i v)
    541       (%wordblock-set!/mutate wb i v) ) )
     543  (if (%immediate? v)
     544    (%wordblock-set!/immediate wb i v)
     545    (%wordblock-set!/mutate wb i v) ) )
    542546
    543547;; Generic-vector (wordblock)
     
    617621  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
    618622  (let loop ((ls ls0) (i i0))
    619     (cond ((%null? ls)  '() )
    620                 ((%fx= 0 i)   (%car ls) )
    621                 (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
     623    (cond
     624      ((%null? ls)  '() )
     625      ((%fx= 0 i)   (%car ls) )
     626      (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
    622627
    623628(define-inline (%list-pair-ref ls0 i0)
    624629  ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
    625630  (let loop ((ls ls0) (i i0))
    626     (cond ((%null? ls)  '() )
    627                 ((%fx= 0 i)   ls )
    628                 (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
     631    (cond
     632      ((%null? ls)  '() )
     633      ((%fx= 0 i)   ls )
     634      (else         (loop (%cdr ls) (%fx- i 1)) ) ) ) )
    629635
    630636(define-inline (%last-pair ls0)
     
    636642  ;(assert (proper-list? ls0))
    637643  (let copy-rest ((ls ls0))
    638     (if (%null? ls) '()
    639         (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
     644    (if (%null? ls)
     645      '()
     646      (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
    640647
    641648(define-inline (%append! . lss)
    642649  ;(assert (and (proper-list? lss) (for-each (cut proper-list? <>) lss)))
    643   (let ((lss (let position-at-first-pair ((lss lss))
    644                (cond ((%null? lss)        '() )
    645                      ((%null? (%car lss))  (position-at-first-pair (%cdr lss)) )
    646                      (else                 lss ) ) ) ) )
    647     (if (%null? lss) '()
    648         (let ((ls0 (%car lss)))
    649           ;(assert (pair? ls0))
    650           (let append!-rest ((lss (%cdr lss)) (pls ls0))
    651             (if (%null? lss) ls0
    652                 (let ((ls (%car lss)))
    653                   (cond ((%null? ls)
    654                          (append!-rest (%cdr lss) pls) )
    655                         (else
    656                          (%set-cdr!/mutate (%last-pair pls) ls)
    657                          (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
     650  (let ((lss
     651          (let position-at-first-pair ((lss lss))
     652            (cond
     653              ((%null? lss)        '() )
     654              ((%null? (%car lss))  (position-at-first-pair (%cdr lss)) )
     655              (else                 lss ) ) ) ) )
     656    (if (%null? lss)
     657      '()
     658      (let ((ls0 (%car lss)))
     659        ;(assert (pair? ls0))
     660        (let append!-rest ((lss (%cdr lss)) (pls ls0))
     661          (if (%null? lss)
     662            ls0
     663            (let ((ls (%car lss)))
     664              (cond
     665                ((%null? ls)
     666                  (append!-rest (%cdr lss) pls) )
     667                (else
     668                  (%set-cdr!/mutate (%last-pair pls) ls)
     669                  (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
    658670
    659671(define-inline (%delq! x ls0)
    660672  ;(assert (proper-list? ls0))
    661673  (let find-elm ((ls ls0) (ppr #f))
    662     (cond ((%null? ls)
    663            ls0 )
    664                 ((%eq? x (%car ls))
    665                  (cond (ppr
    666                         (%set-cdr! ppr (%cdr ls))
    667                         ls0 )
    668                        (else
    669                         (%cdr ls) ) ) )
    670                 (else
    671                  (find-elm (%cdr ls) ls) ) ) ) )
     674    (cond
     675      ((%null? ls)
     676       ls0 )
     677      ((%eq? x (%car ls))
     678        (cond
     679          (ppr
     680            (%set-cdr! ppr (%cdr ls))
     681            ls0 )
     682          (else
     683            (%cdr ls) ) ) )
     684      (else
     685        (find-elm (%cdr ls) ls) ) ) ) )
    672686
    673687(define-inline (%list-fold/1 func init ls0)
    674688  ;(assert (and (proper-list? ls0) (procedure? func)))
    675689  (let loop ((ls ls0) (acc init))
    676     (if (%null? ls) acc
    677         (loop (%cdr ls) (func (%car ls) acc)) ) ) )
     690    (if (%null? ls)
     691      acc
     692      (loop (%cdr ls) (func (%car ls) acc)) ) ) )
    678693
    679694(define-inline (%list-map/1 func ls0)
    680695  ;(assert (and (proper-list? ls0) (procedure? func)))
    681696  (let loop ((ls ls0))
    682     (if (%null? ls) '()
    683         (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
     697    (if (%null? ls)
     698      '()
     699      (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
    684700
    685701(define-inline (%list-for-each/1 proc ls0)
     
    694710(define-inline (%list . objs)
    695711  (let loop ((objs objs))
    696     (if (%null? objs) '()
    697         (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     712    (if (%null? objs)
     713      '()
     714      (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
    698715
    699716(define-inline (%make-list n e)
    700717  (let loop ((n n) (ls '()))
    701     (if (%fxzero? n) ls
    702         (loop (%fxsub1 n) (%cons e ls)) ) ) )
     718    (if (%fxzero? n)
     719      ls
     720      (loop (%fxsub1 n) (%cons e ls)) ) ) )
    703721
    704722(define-inline (%list-take ls0 n)
    705723  (let loop ((ls ls0) (n n))
    706     (if (%fxzero? n) '()
    707         (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
     724    (if (%fxzero? n)
     725      '()
     726      (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
    708727
    709728(define-inline (%list-drop ls0 n)
    710729  (let loop ((ls ls0) (n n))
    711     (if (%fxzero? n) ls
    712         (loop (%cdr ls) (%fxsub1 n)) ) ) )
     730    (if (%fxzero? n)
     731      ls
     732      (loop (%cdr ls) (%fxsub1 n)) ) ) )
    713733
    714734(define-inline (%list-any/1 pred? ls)
    715735  (let loop ((ls ls))
    716     (and (not (%null? ls))
    717          (or (pred? (%car ls))
    718              (loop (%cdr ls)) ) ) ) )
     736    (and
     737      (not (%null? ls))
     738      (or
     739        (pred? (%car ls))
     740        (loop (%cdr ls)) ) ) ) )
    719741
    720742(define-inline (%list-every/1 pred? ls)
    721743  (let loop ((ls ls) (last #t))
    722     (if (%null? ls) last
    723         (let ((this (pred? (%car ls))))
    724           (and this
    725                (loop (%cdr ls) this)) ) ) ) )
     744    (if (%null? ls)
     745      last
     746      (let ((this (pred? (%car ls))))
     747        (and
     748          this
     749          (loop (%cdr ls) this)) ) ) ) )
    726750
    727751(define-inline (%list-length ls0)
    728752  (let loop ((ls ls0) (n 0))
    729     (if (%null? ls) n
    730         (loop (%cdr ls) (%fxadd1 n)) ) ) )
     753    (if (%null? ls)
     754      n
     755      (loop (%cdr ls) (%fxadd1 n)) ) ) )
    731756
    732757(define-inline (%list-find pred? ls)
    733758  (let loop ((ls ls))
    734     (and (not (%null? ls))
    735          (or (let ((elm (%car ls))) (and (pred? elm) elm))
    736              (loop (%cdr ls)) ) ) ) )
     759    (and
     760      (not (%null? ls))
     761      (or
     762        (let ((elm (%car ls))) (and (pred? elm) elm))
     763        (loop (%cdr ls)) ) ) ) )
    737764
    738765(define-inline (%alist-ref key al #!optional (test eqv?) def)
    739766  (let loop ((al al))
    740     (cond ((%null? al) def )
    741           ((test key (%caar al)) (%cdar al) )
    742           (else (loop (%cdr al)) ) ) ) )
     767    (cond
     768      ((%null? al) def )
     769      ((test key (%caar al)) (%cdar al) )
     770      (else (loop (%cdr al)) ) ) ) )
    743771
    744772(define-inline (%alist-update! key val al0 #!optional (test eqv?))
    745773  (let loop ((al al0))
    746     (cond ((%null? al) (%cons (%cons key val) al0) )
    747           ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
    748           (else (loop (%cdr al)) ) ) ) )
     774    (cond
     775      ((%null? al) (%cons (%cons key val) al0) )
     776      ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
     777      (else (loop (%cdr al)) ) ) ) )
    749778
    750779(define-inline (%alist-delete! key al0 #!optional (test equal?))
    751780  (let loop ((al al0) (prv #f))
    752     (cond ((%null? al) al0)
    753           ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
    754           (else (loop (%cdr al) al) ) ) ) )
     781    (cond
     782      ((%null? al) al0)
     783      ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
     784      (else (loop (%cdr al) al) ) ) ) )
    755785
    756786;; Structure (wordblock)
     
    905935(define-inline (%closure-decoration c test)
    906936  (let find-decor ((i (%fxsub1 (%closure-length c))))
    907     (and (%fxpositive? i)
    908          (let ((x (%closure-ref c i)))
    909            (if (test x) x
    910                (find-decor (%fxsub1 i)) ) ) ) ) )
     937    (and
     938      (%fxpositive? i)
     939      (let ((x (%closure-ref c i)))
     940        (if (test x)
     941          x
     942          (find-decor (%fxsub1 i)) ) ) ) ) )
    911943
    912944(define-inline (%closure-decorate! c test dcor)
    913945  (let ((l (%closure-length c)))
    914946    (let find-decor ((i (%fxsub l)))
    915       (cond ((%fxzero? i)
    916              (let ((nc (%make-closure (%fxadd1 l))))
    917                (%closure-copy nc c l)
    918                (##core#inline "C_copy_pointer" c nc)
    919                (dcor nc i) ) )
    920             (else
    921              (let ((x (%closure-ref c i)))
    922                (if (test x) (dcor c i)
    923                    (find-decor (%fxsub i)) ) ) ) ) ) ) )
     947      (cond
     948        ((%fxzero? i)
     949          (let ((nc (%make-closure (%fxadd1 l))))
     950            (%closure-copy nc c l)
     951            (##core#inline "C_copy_pointer" c nc)
     952            (dcor nc i) ) )
     953        (else
     954          (let ((x (%closure-ref c i)))
     955            (if (test x)
     956              (dcor c i)
     957              (find-decor (%fxsub i)) ) ) ) ) ) ) )
    924958
    925959(define-inline (%closure-lambda-info c)
     
    938972(define-inline (%qualified-symbol? s)
    939973  (let ((str (%symbol-string s)))
    940     (and (%fxpositive? (%string-size str))
    941          (%fx<= (%byteblock-ref str 0) NAMESPACE-MAX-ID-LEN) ) ) )
     974    (and
     975      (%fxpositive? (%string-size str))
     976      (%fx<= (%byteblock-ref str 0) NAMESPACE-MAX-ID-LEN) ) ) )
    942977
    943978;Safe
  • release/4/stack/trunk/stack.meta

    r33631 r34096  
    88 (doc-from-wiki)
    99 (depends
     10        (typed-modules "0.1")
    1011        (setup-helper "1.5.2")
    1112        (check-errors "1.9.0"))
  • release/4/stack/trunk/stack.scm

    r19816 r34096  
    11;;;; stack.scm
    22;;;; Kon Lovett, Mar '09
     3;;;; Kon Lovett, May '17
    34
    45;;;; Stack data structure (LIFO queue) where the value is mutable,
     
    1112;;;
    1213
     14(import typed-modules)
     15
    1316(module stack
    1417
    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       define-constant
    38       define-for-syntax
    39       include
    40       optional let-optionals  ;due to #!optional implementation
    41       unless when
    42       define-record-printer
    43       define-reader-ctor)
    44     (only ports with-output-to-port)
    45     (only type-errors define-error-type error-list error-fixnum))
    46 
    47   (require-library ports type-errors)
    48 
    49   (declare
    50     (bound-to-procedure
    51       ##sys#signal-hook ) )
    52 
    53   (include "chicken-primitive-object-inlines")
    54   (include "inline-type-checks")
     18(;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 list -> 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)) )
     34
     35(import
     36  scheme
     37  (only chicken
     38    void
     39    declare
     40    define-inline
     41    define-constant
     42    define-for-syntax
     43    include
     44    optional let-optionals  ;due to #!optional implementation
     45    unless when
     46    define-record-printer
     47    define-reader-ctor))
     48
     49(import
     50  (only ports with-output-to-port)
     51  (only type-errors define-error-type error-list error-fixnum))
     52(require-library ports type-errors)
     53
     54(declare
     55  (bound-to-procedure
     56    ##sys#signal-hook ) )
     57
     58(include "chicken-primitive-object-inlines")
     59(include "inline-type-checks")
    5560
    5661;; Stack Support
     
    6166
    6267(define-inline (%valid-stack? obj)
    63   (and #;(%stack? obj)
    64        (%fx= 3 (%structure-length obj))
    65        (%list? (%stack-list obj)) ) )
     68  (and
     69    #;(%stack? obj)
     70   (%fx= 3 (%structure-length obj))
     71   (%list? (%stack-list obj)) ) )
    6672
    6773;; Stack List
     
    104110
    105111(define-inline (%stack-push! stk ls)
    106   (if (%null? (%cdr ls)) (%stack-push/1! stk (%car ls))
    107             (%list-for-each/1 (lambda (x) (%stack-push/1! stk x)) ls) ) )
     112  (if (%null? (%cdr ls))
     113    (%stack-push/1! stk (%car ls))
     114    (%list-for-each/1 (lambda (x) (%stack-push/1! stk x)) ls) ) )
    108115
    109116(define-inline (%stack-node-ref loc stk idx)
    110117  (let ((pr (%list-pair-ref (%stack-list stk) idx)))
    111                 (if (%pair? pr) pr
    112                           (error-outside-range loc idx 0 (%stack-count stk)) ) ) )
     118                (if (%pair? pr)
     119                  pr
     120      (error-outside-range loc idx 0 (%stack-count stk)) ) ) )
    113121
    114122;; Helpers
    115 
    116123
    117124(define-inline (%check-stack loc obj)
    118125  (unless (%stack? obj) (error-stack loc obj))
    119   (unless (%valid-stack? obj) (error-corrupted-stack loc obj)) )
     126  (unless (%valid-stack? obj) (error-corrupted-stack loc obj))
     127  obj )
    120128
    121129(define-inline (%check-stack-underflow loc stk)
    122   (when (%stack-empty? stk) (error-stack-underflow loc stk)) )
     130  (when (%stack-empty? stk) (error-stack-underflow loc stk))
     131  stk )
    123132
    124133(define-inline (%check-fixnum-index loc lfx fx hfx)
    125   (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
     134  (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx))
     135  (void) )
    126136
    127137;;;
     
    152162
    153163(define (stack-empty? stk)
    154   (%check-stack 'stack-empty? stk)
    155         (%stack-empty? stk) )
     164        (%stack-empty? (%check-stack 'stack-empty? stk)) )
    156165
    157166(define (stack-count stk)
    158   (%check-stack 'stack-count stk)
    159         (%stack-count stk) )
     167        (%stack-count (%check-stack 'stack-count stk)) )
    160168
    161169(define (stack-peek stk #!optional (idx 0))
    162   (%check-stack 'stack-peek stk)
    163         (%car (%stack-node-ref 'stack-peek stk idx)) )
     170        (%car (%stack-node-ref 'stack-peek (%check-stack 'stack-peek stk) idx)) )
    164171
    165172(define (stack-empty! stk)
    166   (%check-stack 'stack-empty! stk)
    167         (%stack-empty! stk) )
     173        (%stack-empty! (%check-stack 'stack-empty! stk)) )
    168174
    169175(define (stack-poke! stk obj #!optional (idx 0))
    170   (%check-stack 'stack-poke! stk)
    171         (%set-car!/mutate (%stack-node-ref 'stack-poke! stk idx) obj) )
     176        (%set-car!/mutate (%stack-node-ref 'stack-poke! (%check-stack 'stack-poke! stk) idx) obj) )
    172177
    173178(define (stack-push! stk #!rest ls)
    174   (%check-stack 'stack-push! stk)
    175         (unless (%null? ls) (%stack-push! stk ls)) )
     179        (unless (%null? ls) (%stack-push! (%check-stack 'stack-push! stk) ls)) )
    176180
    177181(define (stack-cut! stk start #!optional (end (%stack-count stk)))
     
    185189    ; From the top?
    186190    (if (%fx= 0 start)
    187         ;then removing leading elements
    188         (let* ((spr (%stack-list stk))
    189                (epr (%list-pair-ref spr (%fx- cnt 1)))
    190                (ls spr))
    191           (%stack-list-set! stk (%cdr epr))
    192           (%set-cdr!/immediate epr '())
    193           ls )
    194         ;else removing interior elements
    195         (let* ((spr (%stack-node-ref 'stack-cut! stk (%fx- start 1)))
    196                (epr (%list-pair-ref spr cnt))
    197                (ls (%cdr spr)))
    198           (%set-cdr!/mutate spr (%cdr epr))
    199           (%set-cdr!/immediate epr '())
    200           ls ) ) ) )
     191      ;then removing leading elements
     192      (let* ((spr (%stack-list stk))
     193             (epr (%list-pair-ref spr (%fx- cnt 1)))
     194             (ls spr))
     195        (%stack-list-set! stk (%cdr epr))
     196        (%set-cdr!/immediate epr '())
     197        ls )
     198      ;else removing interior elements
     199      (let* ((spr (%stack-node-ref 'stack-cut! stk (%fx- start 1)))
     200             (epr (%list-pair-ref spr cnt))
     201             (ls (%cdr spr)))
     202        (%set-cdr!/mutate spr (%cdr epr))
     203        (%set-cdr!/immediate epr '())
     204        ls ) ) ) )
    201205
    202206(define (stack-pop! stk)
     
    206210
    207211(define (stack->list stk)
    208   (%check-stack 'stack->list stk)
    209         (%list-copy (%stack-list stk)) )
     212        (%list-copy (%stack-list (%check-stack 'stack->list stk))) )
    210213
    211214(define (stack-fold stk func init)
    212   (%check-stack 'stack-fold stk)
    213         (%list-fold/1 func init (%stack-list stk)) )
     215        (%list-fold/1 func init (%stack-list (%check-stack 'stack-fold stk))) )
    214216
    215217(define (stack-map stk func)
    216   (%check-stack 'stack-map stk)
    217         (%list-map/1 func (%stack-list stk)) )
     218        (%list-map/1 func (%stack-list (%check-stack 'stack-map stk))) )
    218219
    219220(define (stack-for-each stk proc)
    220   (%check-stack 'stack-for-each stk)
    221         (%list-for-each/1 proc (%stack-list stk)) )
     221        (%list-for-each/1 proc (%stack-list (%check-stack 'stack-for-each stk))) )
    222222
    223223;;; Read/Print Syntax
     224
     225(define-constant SRFI-10-FORMAT "#,(~A )")
    224226
    225227(define-record-printer (stack stk out)
    226228  (with-output-to-port out
    227229    (lambda ()
    228       (display "#,(stack ")
     230      (display "#,")
     231      (display "(")
     232      (display "stack ")
     233      (display " ")
    229234      (display (%stack-list stk))
    230       (display #\)) ) ) )
     235      (display ")") ) ) )
    231236
    232237(define-reader-ctor 'stack list->stack)
  • release/4/stack/trunk/stack.setup

    r33631 r34096  
    55(verify-extension-name 'stack)
    66
    7 (setup-shared-extension-module (extension-name) (extension-version "2.1.5")
     7(setup-shared-extension-module (extension-name) (extension-version "2.2.0")
    88  #:inline? #t
    99  #:types? #t
Note: See TracChangeset for help on using the changeset viewer.