Changeset 40086 in project


Ignore:
Timestamp:
05/12/21 11:41:41 (5 weeks ago)
Author:
felix winkelmann
Message:

mdh 0.1

Location:
release/5
Files:
1 added
1 deleted
5 edited
8 copied

Legend:

Unmodified
Added
Removed
  • release/5/egg-locations

    r40073 r40086  
    205205(mathh "http://code.call-cc.org/release-info?egg={egg-name};release={chicken-release}")
    206206(md5 "http://code.call-cc.org/release-info?egg={egg-name};release={chicken-release}")
     207(mdh "http://code.call-cc.org/release-info?egg={egg-name};release={chicken-release}")
    207208(medea "https://bitbucket.org/DerGuteMoritz/medea/raw/master/medea.release-info.chicken-5")
    208209(memcached "http://code.call-cc.org/release-info?egg={egg-name};release={chicken-release}")
  • release/5/mdh/tags/0.1/mdh.egg

    r40068 r40086  
    22 (category db)
    33 (license "GPL")
    4  (version "0.1")
    54 (author "Kevin O'Kane")
    65 (maintainer "felix")
     
    98 (component-options
    109   (csc-options "-C" "-w" "-C" "-DNATIVE_SHARED" "-C" "-I."
    11                 "-C" "-D_FILE_OFFSET_BITS=64" "-C" "-D_LARGEFILE_SOURCE"
    12                 "-C" "-I/usr/local/include")) ; for libpcre on OpenBSD
     10                "-C" "-D_FILE_OFFSET_BITS=64" "-C" "-D_LARGEFILE_SOURCE"))
     11 (cond-expand
     12   (openbsd (component-options (csc-options "-C" "-I/usr/local/include"))) ; for libpcre
     13   (else))
    1314 (components
    1415   (c-object arith (source "arith.cpp") (csc-options "-c++"))
     
    3132       strmanip sym sysfunc bmgsubs)
    3233     (csc-options "-c++" "-C" "-D_MDH_")
    33      (link-options "-L" "-L/usr/local/lib" "-L" "-lpcre"))))
     34     (cond-expand
     35       (openbsd (link-options "-L" "-L/usr/local/lib" "-L" "-lpcre"))
     36       (else (link-options "-L" "-lpcre"))))))
  • release/5/mdh/tags/0.1/mdh.scm

    r40083 r40086  
    22
    33
    4 (module mdh (^ ^next ^previous ^data ^count ^kill global?
     4(module mdh (^ ^next ^previous ^data ^count ^kill global? global-reference?
    55             global global-name global-free global-kill global-object
    6              global-count global-merge flush-globals
     6             global-count global-merge flush-globals global-reference-name
    77             global-ref global-set! global-next global-previous global-data
    88             close-globals global-name)
     
    4343        (else (error "expected string, symbol or numeric value" x))))
    4444
    45 (define (make-ref g args)
    46   (let ((p (check-ptr g)))
    47     (%make-ref p args)))
     45(define (make-ref g)
     46  (let* ((gr (->gref g))
     47         (p (check-ptr (global-reference-global gr)))
     48         (args (global-reference-indices gr)))
     49    (%make-ref p args)
     50    p))
     51
     52(define (->gref g)
     53  (cond ((global-reference? g) g)
     54        (else (make-global-reference (global-object g) '()))))
    4855
    4956(define (%make-ref p args)
    50   (let ((len (length args))
    51          (args (map ->val args)))
     57  (let ((len (length args)))
    5258    (case len
    5359      ((0) ((foreign-lambda* void (((c-pointer "global") p))
     
    98104
    99105(define-record global name ptr)
     106(define-record global-reference global indices)
     107
     108(define (global-reference-name gr)
     109  (global-name (global-reference-global gr)))
    100110
    101111(define-record-printer (global g out)
    102112  (fprintf out "<global ~s>" (global-name g)))
     113
     114(define-record-printer (global-reference g out)
     115  (fprintf out "<global-reference ~s ~s>"
     116    (global-reference-name g)
     117    (global-reference-indices g)))
    103118
    104119(define STR_MAX (foreign-value "STR_MAX" int))
     
    110125        y)))
    111126
    112 (define (->global x loc)
    113   (if (global? x)
    114       x
    115       (global-object x)))
    116 
    117127(define (global-object x)
    118128  (cond ((global? x) x)
     129        ((global-reference? x) (global-reference-global x))
    119130        ((and (procedure? x) (procedure-data x))
    120131          => (lambda (g)
     
    135146(define (wrap g)
    136147  (extend-procedure
    137     (getter-with-setter
    138       (lambda ix
    139         (make-ref g ix)
    140         (%get (global-ptr g)))
    141       (lambda rest
    142         (let ((c (split-rest rest)))
    143           (make-ref g (car c))
    144           (%set (global-ptr g) (->val (cdr c))))))
     148    (lambda ix
     149      (make-global-reference g (map ->val ix)))
    145150    g))
    146151
     
    159164(define (global-free g)
    160165  (let ((g (global-object g)))
    161     (%free (global-ptr g))
    162     (global-ptr-set! g #f)))
     166    (and-let* ((ptr (global-ptr g)))
     167      (%free ptr)
     168      (global-ptr-set! g #f))))
    163169
    164170(define %free
     
    166172    "delete g;"))
    167173
    168 (define (global-count g . ix)
    169   (make-ref g ix)
    170   (%count (global-ptr g)))
     174(define (global-count g)
     175  (%count (make-ref g)))
    171176
    172177(define %count
     
    174179    "return(g->Count());"))
    175180
    176 (define (global-kill g . ix)
    177   (make-ref g ix)
    178   (%kill (global-ptr g)))
     181(define (global-kill g)
     182  (%kill (make-ref g)))
    179183
    180184(define %kill
     
    182186    "g->Kill();"))
    183187
    184 (define (global-ref g . ix)
    185   (make-ref g ix)
    186   (%get (check-ptr g)))
     188(define (global-ref g)
     189  (%get (make-ref g)))
    187190
    188191(define %get
     
    191194     return(buf);"))
    192195
    193 (define (global-set! g val . ix)
    194   (make-ref g ix)
    195   (%set (global-ptr g) (->val val)))
     196(define (global-set! g val)
     197  (%set (make-ref g) (->val val)))
    196198
    197199(define %set
     
    199201    "set_global(g->ref, val);"))
    200202
    201 (define (global-next g . ix)
    202   (make-ref g ix)
    203   (%order (global-ptr g) 1))
    204 
    205 (define (global-previous g . ix)
    206   (make-ref g ix)
    207   (%order (global-ptr g) -1))
     203(define (global-next g)
     204  (%order (make-ref g) 1))
     205
     206(define (global-previous g)
     207  (%order (make-ref g) -1))
    208208
    209209(define %order
     
    211211    "return(g->C_Order(dir));"))
    212212
    213 (define (global-merge g1 ix1 g2 ix2)
    214   (make-ref g1 ix1)
    215   (make-ref g2 ix2)
    216   (%merge (global-ptr g1) (global-ptr g2)))
     213(define (global-merge g1 g2)
     214  (let ((p1 (make-ref g1))
     215        (p2 (make-ref g2)))
     216    (%merge p1 p2)))
    217217
    218218(define %merge
     
    220220    "g1->Merge(*g2);"))
    221221
    222 (define (global-data g . ix)
    223   (make-ref g ix)
    224   (data-name (%data (global-ptr g))))
     222(define (global-data g)
     223  (data-name (%data (make-ref g))))
    225224
    226225(define (data-name d)
     
    235234    "return(g->Data());"))
    236235
    237 (define (with-ref g ix loc proc)
     236(define (with-ref g loc ix proc)
    238237  (cond ((or (string? g) (symbol? g))
    239238          (let ((p (%make-global (->val g))))
    240             (%make-ref p ix)
     239            (%make-ref p (map ->val ix))
    241240            (let ((result (proc p)))
    242241              (%free p)
    243242              result)))
    244243        ((global? g)
    245           (make-ref g ix)
    246           (proc (global-ptr g)))       
    247         (else
    248           (let ((g (global-object g)))
    249             (make-ref g ix)
    250             (proc (global-ptr g))))))
     244          (proc (make-ref (make-global-reference g (map ->val ix)))))
     245        (else (error loc "not a global or valid global name" g))))
    251246
    252247(define ^
    253248  (getter-with-setter
    254249    (lambda (name . ix)
    255       (with-ref name ix 'global-ref %get))
     250      (with-ref name '^ ix %get))
    256251    (lambda (name . rest)
    257252      (let ((c (split-rest rest)))
    258         (with-ref name (car c) 'global-set!
     253        (with-ref name '^ (car c)
    259254          (lambda (p) (%set p (->val (cdr c)))))))))
    260255
    261256(define (^next name . ix)
    262   (with-ref name ix '^name (cut %order <> 1)))
     257  (with-ref name '^next ix (cut %order <> 1)))
    263258
    264259(define (^previous name . ix)
    265   (with-ref name ix '^previous (cut %order <> -1)))
     260  (with-ref name '^previous ix (cut %order <> -1)))
    266261
    267262(define (^data name . ix)
    268   (with-ref name ix '^data
     263  (with-ref name '^data ix
    269264    (lambda (p) (data-name (%data p)))))
    270265
    271266(define (^count name . ix)
    272   (with-ref name ix '^count %count))
     267  (with-ref name '^count ix %count))
    273268
    274269(define (^kill name . ix)
    275   (with-ref name ix '^kill %kill))
     270  (with-ref name '^kill ix %kill))
    276271
    277272(define flush-globals
  • release/5/mdh/tags/0.1/tests/a.scm

    r40083 r40086  
    1212(define g1 (global "g1"))
    1313(define go1 (global-object g1))
     14(define ga1 (g1 1 2 3))
     15(test "global-reference" #t (global-reference? ga1))
     16(test "global-object" go1 (global-object ga1))
     17(test "global-object 2" go1 (global-object g1))
    1418(test "idempotent global-object" go1 (global-object go1))
    1519(test "global undefined" "" (global-ref go1))
     
    1822(test "global get" "one" (global-ref go1))
    1923(test "predicate" #t (global? go1))
    20 (set! (g1) "two")
    21 (test "global get with setter" "two" (g1))
    22 (global-set! go1 99 1 2 3)
    23 (set! (g1 1 2 4) 100)
    24 (test "global get indexed" "99" (global-ref go1 1 2 3))
    25 (test "global get indexed 2" "99" (g1 1 2 3))
    26 (test "global get indexed 3" "100" (global-ref go1 1 2 4))
     24(global-set! g1 "two")
     25(test "global set" "two" (global-ref (g1)))
     26(global-set! ga1 99)
     27(global-set! (g1 1 2 4) 100)
     28(test "global get indexed" "99" (global-ref ga1))
     29(test "global get indexed 2" "99" (global-ref (g1 1 2 3)))
     30(test "global get indexed 3" "100" (global-ref (g1 1 2 4)))
    2731(test "data (undefined)" #f (^data "none"))
    28 (test "data (leaf)" 'leaf (global-data go1 1 2 3))
     32(test "data (leaf)" 'leaf (global-data ga1))
    2933(test "data (leaf) 2" 'leaf (^data 'g1 1 2 3))
    30 (test "data (leaf) 3" 'leaf (^data g1 1 2 3))
    31 (test "data (empty)" 'empty (global-data go1 1 2))
    32 (global-set! go1 'x 1)
    33 (test "data (branch)" 'branch (global-data go1 1))
     34(test "data (empty)" 'empty (global-data (g1 1 2)))
     35(global-set! (g1 1) 'x)
     36(test "data (branch)" 'branch (global-data (g1 1)))
    3437(test "order 1" "1" (global-next go1))
    35 (test "order 2" "4" (global-next go1 1 2 3))
    36 (test "order 3" "" (global-next go1 1))
    37 (test "order 3.5" "2" (global-next go1 1 ""))
    38 (test "order 4" "3" (global-previous go1 1 2 4))
     38(test "order 2" "4" (global-next ga1))
     39(test "order 3" "" (global-next (g1 1)))
     40(test "order 3.5" "2" (global-next (g1 1 "")))
     41(test "order 4" "3" (global-previous (g1 1 2 4)))
    3942(test "order 5" "1" (^next 'g1))
    4043(test "order 6" "4" (^next 'g1 1 2 3))
    4144(test "order 7" "3" (^previous 'g1 1 2 4))
    4245(define g2 (global "g2"))
    43 (global-set! (global-object g2) 'end 2 3)
    44 (global-merge go1 '(2) (global-object g2) '())
    45 (test "merged" "end" (global-ref go1 2 2 3))
    46 (global-kill go1 1)
    47 (test "kill" #f (global-data go1 1 2 3))
     46(global-set! (g2 2 3) 'end)
     47(global-merge (g1 2) g2)
     48(test "merged" "end" (global-ref (g1 2 2 3)))
     49(global-kill (g1 1))
     50(test "kill" #f (global-data ga1))
    4851
    49 ;; further tests by cobax:
     52;; further tests, suggested by "kluk":
    5053;; tests ported from mdh manual section 9.1.3.16 Order()
    5154;; https://www.cs.uni.edu/~okane/source/MUMPS-MDH/MDH.pdf page 31
     
    5861
    5962;; Then Order() will return the following values:
    60 (set! go (global-object (global "o")))
    61 (test "order ex 1" "1" (global-next go ""))       ; test().Order(1)         yields "1"
    62 (test "order ex 2" "10" (global-next go 1 "")) ; test("1","").Order(1)   yields "10"
    63 (test "order ex 3" "20" (global-next go 1 10)) ; test("1","10").Order(1) yields 20
    64 (test "order ex 4" "" (global-next go 1 20))   ; test("1","20").Order(1) yields "" (empty string)
    65 (test "order ex 5" "5" (global-next go 1))     ; test("1").Order(1)      yields "5"
    66 (test "order ex 6" "1" (global-next go 5 ""))  ; test("5","").Order(1)   yields "1"
    67 (test "order ex 7" "2" (global-next go 5 1))   ; test("5","1").Order(1)  yields "2"
    68 (test "order ex 8" "" (global-next go 5 2))    ; test("5","2").Order(1)  yields "" (empty string)
    69 (test "order ex 9" "" (global-next go 5))      ; test("5").Order(1)      yields "" (empty string)
    70 
    71 (set! (^ "o" 1 10) 2)
    72 (test "indirect get/set" "2" (^ (global "o") 1 10))
     63(set! go (global "o"))
     64(test "order ex 1" "1" (global-next (go "")))       ; test().Order(1)         yields "1"
     65(test "order ex 2" "10" (global-next (go 1 ""))) ; test("1","").Order(1)   yields "10"
     66(test "order ex 3" "20" (global-next (go 1 10))) ; test("1","10").Order(1) yields 20
     67(test "order ex 4" "" (global-next (go 1 20)))   ; test("1","20").Order(1) yields "" (empty string)
     68(test "order ex 5" "5" (global-next (go 1)))     ; test("1").Order(1)      yields "5"
     69(test "order ex 6" "1" (global-next (go 5 "")))  ; test("5","").Order(1)   yields "1"
     70(test "order ex 7" "2" (global-next (go 5 1)))   ; test("5","1").Order(1)  yields "2"
     71(test "order ex 8" "" (global-next (go 5 2)))    ; test("5","2").Order(1)  yields "" (empty string)
     72(test "order ex 9" "" (global-next (go 5)))      ; test("5").Order(1)      yields "" (empty string)
    7373
    7474(global-free g2)
    75 (test-error "use after free" (g2))
     75(test-error "use after free" (global-ref (g2)))
    7676
    7777(close-globals)
    78 (test-error "access after close" (g1))
     78(test-error "access after close" (global-ref (g1)))
    7979
    8080(test-end)
  • release/5/mdh/tags/0.1/tests/b.scm

    r40082 r40086  
    99(test "^ get indexed " "hello" (^ "array" 1 2 3))
    1010(define g1 (global "g1"))
    11 (test "global get" "two" (global-ref (global-object g1)))
     11(test "global get" "two" (global-ref (g1)))
    1212(define g2 (global "g2"))
    13 (test "merged" "end" (global-ref (global-object g1) 2 2 3))
     13(test "merged" "end" (global-ref (g1 2 2 3)))
    1414
    1515(test-end)
  • release/5/mdh/trunk/mdh.egg

    r40068 r40086  
    22 (category db)
    33 (license "GPL")
    4  (version "0.1")
    54 (author "Kevin O'Kane")
    65 (maintainer "felix")
     
    98 (component-options
    109   (csc-options "-C" "-w" "-C" "-DNATIVE_SHARED" "-C" "-I."
    11                 "-C" "-D_FILE_OFFSET_BITS=64" "-C" "-D_LARGEFILE_SOURCE"
    12                 "-C" "-I/usr/local/include")) ; for libpcre on OpenBSD
     10                "-C" "-D_FILE_OFFSET_BITS=64" "-C" "-D_LARGEFILE_SOURCE"))
     11 (cond-expand
     12   (openbsd (component-options (csc-options "-C" "-I/usr/local/include"))) ; for libpcre
     13   (else))
    1314 (components
    1415   (c-object arith (source "arith.cpp") (csc-options "-c++"))
     
    3132       strmanip sym sysfunc bmgsubs)
    3233     (csc-options "-c++" "-C" "-D_MDH_")
    33      (link-options "-L" "-L/usr/local/lib" "-L" "-lpcre"))))
     34     (cond-expand
     35       (openbsd (link-options "-L" "-L/usr/local/lib" "-L" "-lpcre"))
     36       (else (link-options "-L" "-lpcre"))))))
  • release/5/mdh/trunk/mdh.scm

    r40083 r40086  
    22
    33
    4 (module mdh (^ ^next ^previous ^data ^count ^kill global?
     4(module mdh (^ ^next ^previous ^data ^count ^kill global? global-reference?
    55             global global-name global-free global-kill global-object
    6              global-count global-merge flush-globals
     6             global-count global-merge flush-globals global-reference-name
    77             global-ref global-set! global-next global-previous global-data
    88             close-globals global-name)
     
    4343        (else (error "expected string, symbol or numeric value" x))))
    4444
    45 (define (make-ref g args)
    46   (let ((p (check-ptr g)))
    47     (%make-ref p args)))
     45(define (make-ref g)
     46  (let* ((gr (->gref g))
     47         (p (check-ptr (global-reference-global gr)))
     48         (args (global-reference-indices gr)))
     49    (%make-ref p args)
     50    p))
     51
     52(define (->gref g)
     53  (cond ((global-reference? g) g)
     54        (else (make-global-reference (global-object g) '()))))
    4855
    4956(define (%make-ref p args)
    50   (let ((len (length args))
    51          (args (map ->val args)))
     57  (let ((len (length args)))
    5258    (case len
    5359      ((0) ((foreign-lambda* void (((c-pointer "global") p))
     
    98104
    99105(define-record global name ptr)
     106(define-record global-reference global indices)
     107
     108(define (global-reference-name gr)
     109  (global-name (global-reference-global gr)))
    100110
    101111(define-record-printer (global g out)
    102112  (fprintf out "<global ~s>" (global-name g)))
     113
     114(define-record-printer (global-reference g out)
     115  (fprintf out "<global-reference ~s ~s>"
     116    (global-reference-name g)
     117    (global-reference-indices g)))
    103118
    104119(define STR_MAX (foreign-value "STR_MAX" int))
     
    110125        y)))
    111126
    112 (define (->global x loc)
    113   (if (global? x)
    114       x
    115       (global-object x)))
    116 
    117127(define (global-object x)
    118128  (cond ((global? x) x)
     129        ((global-reference? x) (global-reference-global x))
    119130        ((and (procedure? x) (procedure-data x))
    120131          => (lambda (g)
     
    135146(define (wrap g)
    136147  (extend-procedure
    137     (getter-with-setter
    138       (lambda ix
    139         (make-ref g ix)
    140         (%get (global-ptr g)))
    141       (lambda rest
    142         (let ((c (split-rest rest)))
    143           (make-ref g (car c))
    144           (%set (global-ptr g) (->val (cdr c))))))
     148    (lambda ix
     149      (make-global-reference g (map ->val ix)))
    145150    g))
    146151
     
    159164(define (global-free g)
    160165  (let ((g (global-object g)))
    161     (%free (global-ptr g))
    162     (global-ptr-set! g #f)))
     166    (and-let* ((ptr (global-ptr g)))
     167      (%free ptr)
     168      (global-ptr-set! g #f))))
    163169
    164170(define %free
     
    166172    "delete g;"))
    167173
    168 (define (global-count g . ix)
    169   (make-ref g ix)
    170   (%count (global-ptr g)))
     174(define (global-count g)
     175  (%count (make-ref g)))
    171176
    172177(define %count
     
    174179    "return(g->Count());"))
    175180
    176 (define (global-kill g . ix)
    177   (make-ref g ix)
    178   (%kill (global-ptr g)))
     181(define (global-kill g)
     182  (%kill (make-ref g)))
    179183
    180184(define %kill
     
    182186    "g->Kill();"))
    183187
    184 (define (global-ref g . ix)
    185   (make-ref g ix)
    186   (%get (check-ptr g)))
     188(define (global-ref g)
     189  (%get (make-ref g)))
    187190
    188191(define %get
     
    191194     return(buf);"))
    192195
    193 (define (global-set! g val . ix)
    194   (make-ref g ix)
    195   (%set (global-ptr g) (->val val)))
     196(define (global-set! g val)
     197  (%set (make-ref g) (->val val)))
    196198
    197199(define %set
     
    199201    "set_global(g->ref, val);"))
    200202
    201 (define (global-next g . ix)
    202   (make-ref g ix)
    203   (%order (global-ptr g) 1))
    204 
    205 (define (global-previous g . ix)
    206   (make-ref g ix)
    207   (%order (global-ptr g) -1))
     203(define (global-next g)
     204  (%order (make-ref g) 1))
     205
     206(define (global-previous g)
     207  (%order (make-ref g) -1))
    208208
    209209(define %order
     
    211211    "return(g->C_Order(dir));"))
    212212
    213 (define (global-merge g1 ix1 g2 ix2)
    214   (make-ref g1 ix1)
    215   (make-ref g2 ix2)
    216   (%merge (global-ptr g1) (global-ptr g2)))
     213(define (global-merge g1 g2)
     214  (let ((p1 (make-ref g1))
     215        (p2 (make-ref g2)))
     216    (%merge p1 p2)))
    217217
    218218(define %merge
     
    220220    "g1->Merge(*g2);"))
    221221
    222 (define (global-data g . ix)
    223   (make-ref g ix)
    224   (data-name (%data (global-ptr g))))
     222(define (global-data g)
     223  (data-name (%data (make-ref g))))
    225224
    226225(define (data-name d)
     
    235234    "return(g->Data());"))
    236235
    237 (define (with-ref g ix loc proc)
     236(define (with-ref g loc ix proc)
    238237  (cond ((or (string? g) (symbol? g))
    239238          (let ((p (%make-global (->val g))))
    240             (%make-ref p ix)
     239            (%make-ref p (map ->val ix))
    241240            (let ((result (proc p)))
    242241              (%free p)
    243242              result)))
    244243        ((global? g)
    245           (make-ref g ix)
    246           (proc (global-ptr g)))       
    247         (else
    248           (let ((g (global-object g)))
    249             (make-ref g ix)
    250             (proc (global-ptr g))))))
     244          (proc (make-ref (make-global-reference g (map ->val ix)))))
     245        (else (error loc "not a global or valid global name" g))))
    251246
    252247(define ^
    253248  (getter-with-setter
    254249    (lambda (name . ix)
    255       (with-ref name ix 'global-ref %get))
     250      (with-ref name '^ ix %get))
    256251    (lambda (name . rest)
    257252      (let ((c (split-rest rest)))
    258         (with-ref name (car c) 'global-set!
     253        (with-ref name '^ (car c)
    259254          (lambda (p) (%set p (->val (cdr c)))))))))
    260255
    261256(define (^next name . ix)
    262   (with-ref name ix '^name (cut %order <> 1)))
     257  (with-ref name '^next ix (cut %order <> 1)))
    263258
    264259(define (^previous name . ix)
    265   (with-ref name ix '^previous (cut %order <> -1)))
     260  (with-ref name '^previous ix (cut %order <> -1)))
    266261
    267262(define (^data name . ix)
    268   (with-ref name ix '^data
     263  (with-ref name '^data ix
    269264    (lambda (p) (data-name (%data p)))))
    270265
    271266(define (^count name . ix)
    272   (with-ref name ix '^count %count))
     267  (with-ref name '^count ix %count))
    273268
    274269(define (^kill name . ix)
    275   (with-ref name ix '^kill %kill))
     270  (with-ref name '^kill ix %kill))
    276271
    277272(define flush-globals
  • release/5/mdh/trunk/tests/a.scm

    r40083 r40086  
    1212(define g1 (global "g1"))
    1313(define go1 (global-object g1))
     14(define ga1 (g1 1 2 3))
     15(test "global-reference" #t (global-reference? ga1))
     16(test "global-object" go1 (global-object ga1))
     17(test "global-object 2" go1 (global-object g1))
    1418(test "idempotent global-object" go1 (global-object go1))
    1519(test "global undefined" "" (global-ref go1))
     
    1822(test "global get" "one" (global-ref go1))
    1923(test "predicate" #t (global? go1))
    20 (set! (g1) "two")
    21 (test "global get with setter" "two" (g1))
    22 (global-set! go1 99 1 2 3)
    23 (set! (g1 1 2 4) 100)
    24 (test "global get indexed" "99" (global-ref go1 1 2 3))
    25 (test "global get indexed 2" "99" (g1 1 2 3))
    26 (test "global get indexed 3" "100" (global-ref go1 1 2 4))
     24(global-set! g1 "two")
     25(test "global set" "two" (global-ref (g1)))
     26(global-set! ga1 99)
     27(global-set! (g1 1 2 4) 100)
     28(test "global get indexed" "99" (global-ref ga1))
     29(test "global get indexed 2" "99" (global-ref (g1 1 2 3)))
     30(test "global get indexed 3" "100" (global-ref (g1 1 2 4)))
    2731(test "data (undefined)" #f (^data "none"))
    28 (test "data (leaf)" 'leaf (global-data go1 1 2 3))
     32(test "data (leaf)" 'leaf (global-data ga1))
    2933(test "data (leaf) 2" 'leaf (^data 'g1 1 2 3))
    30 (test "data (leaf) 3" 'leaf (^data g1 1 2 3))
    31 (test "data (empty)" 'empty (global-data go1 1 2))
    32 (global-set! go1 'x 1)
    33 (test "data (branch)" 'branch (global-data go1 1))
     34(test "data (empty)" 'empty (global-data (g1 1 2)))
     35(global-set! (g1 1) 'x)
     36(test "data (branch)" 'branch (global-data (g1 1)))
    3437(test "order 1" "1" (global-next go1))
    35 (test "order 2" "4" (global-next go1 1 2 3))
    36 (test "order 3" "" (global-next go1 1))
    37 (test "order 3.5" "2" (global-next go1 1 ""))
    38 (test "order 4" "3" (global-previous go1 1 2 4))
     38(test "order 2" "4" (global-next ga1))
     39(test "order 3" "" (global-next (g1 1)))
     40(test "order 3.5" "2" (global-next (g1 1 "")))
     41(test "order 4" "3" (global-previous (g1 1 2 4)))
    3942(test "order 5" "1" (^next 'g1))
    4043(test "order 6" "4" (^next 'g1 1 2 3))
    4144(test "order 7" "3" (^previous 'g1 1 2 4))
    4245(define g2 (global "g2"))
    43 (global-set! (global-object g2) 'end 2 3)
    44 (global-merge go1 '(2) (global-object g2) '())
    45 (test "merged" "end" (global-ref go1 2 2 3))
    46 (global-kill go1 1)
    47 (test "kill" #f (global-data go1 1 2 3))
     46(global-set! (g2 2 3) 'end)
     47(global-merge (g1 2) g2)
     48(test "merged" "end" (global-ref (g1 2 2 3)))
     49(global-kill (g1 1))
     50(test "kill" #f (global-data ga1))
    4851
    49 ;; further tests by cobax:
     52;; further tests, suggested by "kluk":
    5053;; tests ported from mdh manual section 9.1.3.16 Order()
    5154;; https://www.cs.uni.edu/~okane/source/MUMPS-MDH/MDH.pdf page 31
     
    5861
    5962;; Then Order() will return the following values:
    60 (set! go (global-object (global "o")))
    61 (test "order ex 1" "1" (global-next go ""))       ; test().Order(1)         yields "1"
    62 (test "order ex 2" "10" (global-next go 1 "")) ; test("1","").Order(1)   yields "10"
    63 (test "order ex 3" "20" (global-next go 1 10)) ; test("1","10").Order(1) yields 20
    64 (test "order ex 4" "" (global-next go 1 20))   ; test("1","20").Order(1) yields "" (empty string)
    65 (test "order ex 5" "5" (global-next go 1))     ; test("1").Order(1)      yields "5"
    66 (test "order ex 6" "1" (global-next go 5 ""))  ; test("5","").Order(1)   yields "1"
    67 (test "order ex 7" "2" (global-next go 5 1))   ; test("5","1").Order(1)  yields "2"
    68 (test "order ex 8" "" (global-next go 5 2))    ; test("5","2").Order(1)  yields "" (empty string)
    69 (test "order ex 9" "" (global-next go 5))      ; test("5").Order(1)      yields "" (empty string)
    70 
    71 (set! (^ "o" 1 10) 2)
    72 (test "indirect get/set" "2" (^ (global "o") 1 10))
     63(set! go (global "o"))
     64(test "order ex 1" "1" (global-next (go "")))       ; test().Order(1)         yields "1"
     65(test "order ex 2" "10" (global-next (go 1 ""))) ; test("1","").Order(1)   yields "10"
     66(test "order ex 3" "20" (global-next (go 1 10))) ; test("1","10").Order(1) yields 20
     67(test "order ex 4" "" (global-next (go 1 20)))   ; test("1","20").Order(1) yields "" (empty string)
     68(test "order ex 5" "5" (global-next (go 1)))     ; test("1").Order(1)      yields "5"
     69(test "order ex 6" "1" (global-next (go 5 "")))  ; test("5","").Order(1)   yields "1"
     70(test "order ex 7" "2" (global-next (go 5 1)))   ; test("5","1").Order(1)  yields "2"
     71(test "order ex 8" "" (global-next (go 5 2)))    ; test("5","2").Order(1)  yields "" (empty string)
     72(test "order ex 9" "" (global-next (go 5)))      ; test("5").Order(1)      yields "" (empty string)
    7373
    7474(global-free g2)
    75 (test-error "use after free" (g2))
     75(test-error "use after free" (global-ref (g2)))
    7676
    7777(close-globals)
    78 (test-error "access after close" (g1))
     78(test-error "access after close" (global-ref (g1)))
    7979
    8080(test-end)
  • release/5/mdh/trunk/tests/b.scm

    r40082 r40086  
    99(test "^ get indexed " "hello" (^ "array" 1 2 3))
    1010(define g1 (global "g1"))
    11 (test "global get" "two" (global-ref (global-object g1)))
     11(test "global get" "two" (global-ref (g1)))
    1212(define g2 (global "g2"))
    13 (test "merged" "end" (global-ref (global-object g1) 2 2 3))
     13(test "merged" "end" (global-ref (g1 2 2 3)))
    1414
    1515(test-end)
Note: See TracChangeset for help on using the changeset viewer.