klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

combiners.k (16876B)

      1 ;; check.k & test-helpers.k should be loaded
      2 
      3 ;;;
      4 ;;; Basic Functionality
      5 ;;;
      6 
      7 ;; operative?, applicative? & combiner?
      8 ($check-predicate (applicative? operative?))
      9 ($check-predicate (applicative? applicative?))
     10 ($check-predicate (applicative? combiner?))
     11 
     12 ($check-predicate (operative?))
     13 ($check-predicate (operative? $if $vau $lambda))
     14 ($check-predicate (operative? $cond . #0=($sequence . #0#)))
     15 
     16 ($check-predicate (applicative?))
     17 ($check-predicate (applicative? applicative? operative? combiner?))
     18 ($check-predicate (applicative? wrap . #0=(unwrap . #0#)))
     19 
     20 ($check-predicate (combiner?))
     21 ($check-predicate (combiner? $if $vau $lambda))
     22 ($check-predicate (combiner? $cond . #0=($sequence . #0#)))
     23 ($check-predicate (combiner?))
     24 ($check-predicate (combiner? applicative? operative? combiner?))
     25 ($check-predicate (combiner? wrap . #0=(unwrap . #0#)))
     26 
     27 ($check-not-predicate (operative? #t))
     28 ($check-not-predicate (operative? #f))
     29 ($check-not-predicate (operative? ((unwrap list) . symbol)))
     30 ($check-not-predicate (operative? ()))
     31 ($check-not-predicate (operative? (cons () ())))
     32 ($check-not-predicate (operative? #ignore))
     33 ($check-not-predicate (operative? (make-environment)))
     34 ($check-not-predicate (operative? #inert))
     35 ($check-not-predicate (operative? wrap))
     36 ($check-not-predicate (operative? (call/cc ($lambda (c) c))))
     37 ($check-not-predicate (operative? ($let (((enc . #ignore) 
     38                                           (make-encapsulation-type)))
     39                                     (enc #inert))))
     40 ($check-not-predicate (operative? (memoize #inert)))
     41 ($check-not-predicate (operative? 1))
     42 ($check-not-predicate (operative? 1.0))
     43 ($check-not-predicate (operative? #e+infinity))
     44 ($check-not-predicate (operative? #i+infinity))
     45 ($check-not-predicate (operative? #undefined))
     46 ($check-not-predicate (operative? #real))
     47 ($check-not-predicate (operative? "string"))
     48 ($check-not-predicate (operative? #\a))
     49 ($check-not-predicate (operative? (get-current-input-port)))
     50 
     51 ($check-not-predicate (applicative? #t))
     52 ($check-not-predicate (applicative? #f))
     53 ($check-not-predicate (applicative? ((unwrap list) . symbol)))
     54 ($check-not-predicate (applicative? ()))
     55 ($check-not-predicate (applicative? (cons () ())))
     56 ($check-not-predicate (applicative? #ignore))
     57 ($check-not-predicate (applicative? (make-environment)))
     58 ($check-not-predicate (applicative? #inert))
     59 ($check-not-predicate (applicative? $vau))
     60 ($check-not-predicate (applicative? (call/cc ($lambda (c) c))))
     61 ($check-not-predicate (applicative? ($let (((enc . #ignore) 
     62                                             (make-encapsulation-type)))
     63                                       (enc #inert))))
     64 ($check-not-predicate (applicative? (memoize #inert)))
     65 ($check-not-predicate (applicative? 1))
     66 ($check-not-predicate (applicative? 1.0))
     67 ($check-not-predicate (applicative? #e+infinity))
     68 ($check-not-predicate (applicative? #i+infinity))
     69 ($check-not-predicate (applicative? #undefined))
     70 ($check-not-predicate (applicative? #real))
     71 ($check-not-predicate (applicative? "string"))
     72 ($check-not-predicate (applicative? #\a))
     73 ($check-not-predicate (applicative? (get-current-input-port)))
     74 
     75 ($check-not-predicate (combiner? #t))
     76 ($check-not-predicate (combiner? #f))
     77 ($check-not-predicate (combiner? ((unwrap list) . symbol)))
     78 ($check-not-predicate (combiner? ()))
     79 ($check-not-predicate (combiner? (cons () ())))
     80 ($check-not-predicate (combiner? #ignore))
     81 ($check-not-predicate (combiner? (make-environment)))
     82 ($check-not-predicate (combiner? #inert))
     83 ($check-not-predicate (combiner? (call/cc ($lambda (c) c))))
     84 ($check-not-predicate (combiner? ($let (((enc . #ignore) 
     85                                          (make-encapsulation-type)))
     86                                    (enc #inert))))
     87 ($check-not-predicate (combiner? (memoize #inert)))
     88 ($check-not-predicate (combiner? 1))
     89 ($check-not-predicate (combiner? 1.0))
     90 ($check-not-predicate (combiner? #e+infinity))
     91 ($check-not-predicate (combiner? #i+infinity))
     92 ($check-not-predicate (combiner? #undefined))
     93 ($check-not-predicate (combiner? #real))
     94 ($check-not-predicate (combiner? "string"))
     95 ($check-not-predicate (combiner? #\a))
     96 ($check-not-predicate (combiner? (get-current-input-port)))
     97 
     98 ;; $vau
     99 ($check-predicate (operative? ($vau #ignore #ignore #inert)))
    100 ($check eq? (($vau #ignore #ignore)) #inert)
    101 ($check eq? (($vau #ignore #ignore 1)) 1)
    102 ($check equal? (($vau ls #ignore ls) 1 2) (list 1 2))
    103 ($check equal? (($vau #ignore env env)) (get-current-environment))
    104 ($check equal? (($vau (x y) #ignore (list y x)) 1 2) (list 2 1))
    105 ;; parameter trees (generalized parameter lists)
    106 ($check equal? (($vau ((x . y) (z)) #ignore (list z y x)) (1 . 2) (3)) (list 3 2 1))
    107 ($check equal? (($vau ((x y z)) #ignore (list z y x)) (1 2 3)) (list 3 2 1))
    108 ($check equal? (($vau ((x y . z)) #ignore (finite-list? z)) 
    109                 #0=(1 2 3 . #0#)) #f)
    110 
    111 ;; test static scope of $vau, define an "inverted" $if and use it in the body
    112 ($let (($if ($vau (test a b) denv
    113               (eval (list $if test b a)
    114                     denv))))
    115   ($check eq? 
    116           (($vau () #ignore 
    117              ($if #t 1 2))) 
    118           2))
    119 
    120 ;; shared structure in ptree (but no shared symbols and no cycles)
    121 ($check equal?
    122         (($vau ((x . #0=(#ignore)) (y . #0#)) #ignore (list x y)) (1 4) (2 5))
    123         (list 1 2))
    124 
    125 ;; wrap
    126 ($check-predicate (applicative? wrap))
    127 ($check-predicate (applicative? (wrap ($vau #ignore #ignore #inert))))
    128 ($check-predicate (applicative? (wrap (wrap ($vau #ignore #ignore #inert)))))
    129 ($check-predicate (applicative? (wrap $if)))
    130 
    131 ;; unwrap
    132 ($check-predicate (applicative? unwrap))
    133 ($check-predicate (operative? 
    134                    (unwrap (wrap ($vau #ignore #ignore #inert)))))
    135 ($check-predicate (applicative? 
    136                    (unwrap (wrap (wrap ($vau #ignore #ignore #inert))))))
    137 ($check-predicate (operative? 
    138                    (unwrap list)))
    139 ($check-predicate (applicative? 
    140                    (unwrap (wrap list))))
    141 
    142 ;; $lambda
    143 ($check-predicate (applicative? ($lambda #ignore #inert)))
    144 ($check eq? (($lambda #ignore)) #inert)
    145 ($check eq? (($lambda #ignore 1)) 1)
    146 ($check equal? (($lambda ls ls) 1 2) (list 1 2))
    147 ($check equal? (($lambda (x y) (list y x)) 1 2) (list 2 1))
    148 ;; arguments should be eval'ed in the current environment
    149 ($check eq? 
    150         (($lambda (x) x) (get-current-environment)) 
    151         (get-current-environment))
    152 ;; parameter trees (generalized parameter lists)
    153 ($check equal? (($lambda ((x . y) (z)) (list z y x)) 
    154                 (cons 1 2) (list 3)) (list 3 2 1))
    155 ($check equal? (($lambda ((x y z)) (list z y x)) (list 1 2 3)) (list 3 2 1))
    156 ($check equal? (($lambda ((x y . z)) (finite-list? z)) 
    157                 (list . #0=(1 2 3 . #0#))) #f)
    158 
    159 ;; test static scope of $lambda, define an "inverted" $if and use it in the body
    160 ($let (($if ($vau (test a b) denv
    161               (eval (list $if test b a)
    162                     denv))))
    163   ($check eq? 
    164           (($lambda ()
    165              ($if #t 1 2)))
    166           2))
    167 ;; shared structure in ptree (but no shared symbols and no cycles)
    168 ($check equal?
    169         (($lambda ((x . #0=(#ignore)) (y . #0#)) (list x y)) 
    170          (list 1 4) (list 2 5))
    171         (list 1 2))
    172 
    173 ;; apply
    174 ($check-predicate (applicative? apply))
    175 ($check equal? (apply cons (list 1 2)) (cons 1 2))
    176 ;; the underlying operative of list always returns its operand tree
    177 ;; so this is correct in kernel
    178 ($check eq? (apply list 3) 3)
    179 ;; the two argument case uses an empty environment
    180 ($check eq? (apply (wrap ($vau #ignore env ($binds? env $vau))) 
    181                    #inert) 
    182         #f)
    183 
    184 ($let ((empty-env (make-environment)))
    185   ($check eq? 
    186           (apply (wrap ($vau #ignore env env)) #inert empty-env)
    187           empty-env))
    188 
    189 ;; map
    190 ($check-predicate (applicative? map))
    191 ($check equal? (map + (list 1 2 3 4)) (list 1 2 3 4))
    192 ($check equal? (map cons (list 1 2 3 4) (list 10 20 30 40)) 
    193         (list (cons 1 10) (cons 2 20) (cons 3 30) (cons 4 40)))
    194 
    195 ($let ((p (cons () ())))
    196   ($check eq?
    197           ($sequence (map (wrap ($vau #ignore env
    198                                   (set-car! p env)))
    199                           (list 1))
    200                      (car p))
    201           (get-current-environment)))
    202 
    203 ($let ((p (cons 0 ())))
    204   ($check eq?
    205           ($sequence (map ($lambda (x)
    206                             (set-car! p (+ (car p) x)))
    207                           (list 1 2 3 4))
    208                      (car p))
    209           10))
    210 
    211 
    212 ($check equal?
    213         (map ($lambda (x)
    214                (- 0 x))
    215              (list 1 . #0=(2 3 4 . #0#)))
    216         (list -1 . #1=(-2 -3 -4 . #1#)))
    217 
    218 ($check equal?
    219         (map ($lambda ls
    220                (finite-list? ls))
    221              . #0=((list 1 2 3 4)
    222                    (list 10 20 30 40)
    223                    . #0#))
    224         (list #f #f #f #f))
    225 
    226 ;; string-map
    227 ($check-predicate (applicative? string-map))
    228 ($check equal? (string-map char-downcase "") "")
    229 ($check equal? (string-map char-upcase "abc") "ABC")
    230 ($let ((char-max ($lambda chars 
    231                    (integer->char 
    232                     (apply max
    233                            (map char->integer chars))))))
    234   ($check equal? (string-map char-max "abc" "ABC" "xyz" "XYZ")
    235           "xyz")
    236   ($check equal? (string-map char-max "abc" "ABC" . #0=("xyz" "XYZ". #0#))
    237           "xyz"))
    238 
    239 ($let ((p (cons () ())))
    240   ($check eq?
    241           ($sequence (string-map (wrap ($vau #ignore env
    242                                          (set-car! p env)
    243                                          #\a))
    244                                  "a")
    245                      (car p))
    246           (get-current-environment)))
    247 
    248 ($let ((p (cons 0 ())))
    249   ($check eq?
    250           ($sequence (string-map ($lambda (x)
    251                                    (set-car! p (+ (car p) (char->integer x)))
    252                                    #\a)
    253                                  "abcd")
    254                      (car p))
    255           (apply + (map char->integer (string->list "abcd")))))
    256 
    257 ;; vector-map
    258 ($check-predicate (applicative? vector-map))
    259 ($check equal? (vector-map inert? (vector #inert #ignore #inert))
    260         (vector #t #f #t))
    261 ($check equal? (vector-map inert? (vector)) (vector))
    262 ($check equal? (vector-map max (vector 1 2) . 
    263                            #0=((vector 3 4) (vector 5 6). #0#))
    264         (vector 5 6))
    265 
    266 ($let ((p (cons () ())))
    267   ($check eq?
    268           ($sequence (vector-map (wrap ($vau #ignore env
    269                                          (set-car! p env)))
    270                                  (vector 1))
    271                      (car p))
    272           (get-current-environment)))
    273 
    274 ($let ((p (cons 0 ())))
    275   ($check eq?
    276           ($sequence (vector-map ($lambda (x)
    277                                    (set-car! p (+ (car p) x)))
    278                                  (vector 1 2 3 4))
    279                      (car p))
    280           10))
    281 
    282 ;; bytevector-map
    283 ($check-predicate (applicative? bytevector-map))
    284 ($check equal? (bytevector-map + (bytevector)) (bytevector))
    285 ($check equal? (bytevector-map ($lambda (x) (+ x 1)) (bytevector 1 2 3)) 
    286         (bytevector 2 3 4))
    287 ($check equal? (bytevector-map max (bytevector 1 2) (bytevector 3 4) 
    288                                (bytevector 5 6))
    289         (bytevector 5 6))
    290 ($check equal? (bytevector-map max (bytevector 1 2) . #0=((bytevector 3 4) 
    291                                                           (bytevector 5 6) . #0#))
    292         (bytevector 5 6))
    293 
    294 ($let ((p (cons () ())))
    295   ($check eq?
    296           ($sequence (bytevector-map (wrap ($vau #ignore env
    297                                              (set-car! p env)
    298                                              1))
    299                                      (bytevector 1))
    300                      (car p))
    301           (get-current-environment)))
    302 
    303 ($let ((p (cons 0 ())))
    304   ($check eq?
    305           ($sequence (bytevector-map ($lambda (x)
    306                                        (set-car! p (+ (car p) x))
    307                                        1)
    308                                      (bytevector 1 2 3 4))
    309                      (car p))
    310           10))
    311 
    312 ;;;
    313 ;;; Error Checking and Robustness
    314 ;;;
    315 
    316 ;; operative?, applicative? & combiner?
    317 ($check-error (operative? $vau . $cond))
    318 ($check-error (applicative? wrap . unwrap))
    319 ($check-error (combiner? $vau . wrap))
    320 
    321 ;; $vau
    322 ($check-error ($vau))
    323 ($check-error ($vau #ignore))
    324 ($check-error ($vau #ignore #ignore . #inert))
    325 
    326 ;; repeated symbols aren't allowed
    327 ($check-error ($vau (x x) #ignore x))
    328 ;; same symbol in ptree and env aren't allowed either
    329 ($check-error ($vau (x) x x))
    330 ;; this counts as repeating symbols
    331 ($check-error ($vau ((x . #0=(z)) (y . #0#)) #ignore (list x y z)))
    332 ;; cycles aren't allowed either (containing symbols or not)
    333 ($check-error ($vau (x . #0=(#ignore . #0#)) #ignore x))
    334 
    335 ($check-error ($vau #ignore #t #inert))
    336 ($check-error ($vau #f #ignore #inert))
    337 ($check-error ($vau #inert #inert #inert))
    338 
    339 ;; wrap
    340 ($check-error (wrap))
    341 ($check-error (wrap $vau $vau))
    342 ($check-error (wrap . #0=($vau . #0#)))
    343 
    344 ($check-error (wrap 1))
    345 ($check-error (wrap #t))
    346 ($check-error (wrap #inert))
    347 ($check-error (wrap #ignore))
    348 ($check-error (wrap ()))
    349 ($check-error ($let/cc cont (wrap cont)))
    350 ($check-error (wrap (memoize #inert)))
    351 
    352 ;; unwrap
    353 ($check-error (unwrap))
    354 ($check-error (unwrap list list))
    355 ($check-error (unwrap . #0=(list . #0#)))
    356 
    357 ($check-error (unwrap 1))
    358 ($check-error (unwrap #t))
    359 ($check-error (unwrap #inert))
    360 ($check-error (unwrap #ignore))
    361 ($check-error ($let/cc cont (unwrap cont)))
    362 ($check-error (unwrap (memoize #inert)))
    363 
    364 ;; $lambda
    365 ($check-error ($lambda))
    366 ($check-error ($lambda #ignore . #inert))
    367 
    368 ;; repeated symbols aren't allowed
    369 ($check-error ($lambda (x x) x))
    370 ;; this counts as repeating symbols
    371 ($check-error ($lambda ((x . #0=(z)) (y . #0#)) (list x y z)))
    372 ;; cycles aren't allowed either (containing symbols or not)
    373 ($check-error ($lambda (x . #0=(#ignore . #0#)) x))
    374 
    375 ($check-error ($lambda #t #inert))
    376 ($check-error ($lambda #f #inert))
    377 ($check-error ($lambda #inert #inert))
    378 
    379 ;; apply
    380 ($check-error (apply))
    381 ($check-error (apply list))
    382 ($check-error (apply list 1 (get-current-environment #inert)))
    383 ($check-error (apply . #0=(list 1 (get-current-environment) . #0#)))
    384 
    385 ($check-error (apply (unwrap list) 1))
    386 ($check-error (apply #ignore 1))
    387 ($check-error (apply 1 1))
    388 ($check-error (apply list 1 #inert))
    389 ($check-error (apply list 1 1))
    390 ($check-error (apply cons (list 1)))
    391 
    392 ;; map
    393 ($check-error (map))
    394 ;; the list can't be empty
    395 ($check-error (map list))
    396 
    397 ($check-error (map list (list 1 2) (list 1 2 3)))
    398 ($check-error (map list (list . #0=(1 2 . #0#)) (list 1 2 3)))
    399 
    400 ($check-error (map list #inert))
    401 ($check-error (map #inert (list 1 2)))
    402 ($check-error (map ((unwrap list) #inert) (list 1 2)))
    403 
    404 ($check-error (map list (list 1 2) #inert))
    405 ($check-error (map cons (list 1 2)))
    406 
    407 ;; string-map
    408 ($check-error (string-map)) 
    409 ($check-error (string-map char-upcase)) ; the list can't be empty
    410 ($check-error (string-map ($lambda ls #\a) "abc" "ab"))
    411 ($check-error (string-map ($lambda ls #\a) "abc" . #0=("ab" . #0#)))
    412 
    413 ($check-error (string-map char->number "abc"))
    414 ($check-error (string-map char>=? "abc" "def"))
    415 
    416 ($check-error (string-map char-upcase #\a))
    417 ($check-error (string-map char-upcase (list #\a)))
    418 ($check-error (string-map #inert "abc"))
    419 ($check-error (string-map (unwrap char-upcase) "abc"))
    420 ($check-error (string-map char-upcase "abc" "def"))
    421 ($check-error (string-map char-upcase . #0=("abc". #0#)))
    422 
    423 ;; vector-map
    424 ($check-error (vector-map)) 
    425 ($check-error (vector-map char-upcase)) ; the list can't be empty
    426 ($check-error (vector-map + (vector 1 2 3) (vector 1 2)))
    427 ($check-error (vector-map + (vector 1 2 3) . #0=((vector 1 2) . #0#)))
    428 
    429 ($check-error (vector-map char-upcase #\a))
    430 ($check-error (vector-map char-upcase (list #\a)))
    431 ($check-error (vector-map + (bytevector 1)))
    432 ($check-error (vector-map #inert (vector)))
    433 ($check-error (vector-map (unwrap +) (vector 1 2 3)))
    434 ($check-error (vector-map ($lambda (x) (+ x 1)) 
    435                           (vector 1 2) (vector 1 2)))
    436 ($check-error (vector-map ($lambda (x) (+ x 1)) . 
    437                           #0=((vector 1 2) . #0#)))
    438 
    439 ;; bytevector-map
    440 ($check-error (bytevector-map)) 
    441 ($check-error (bytevector-map +)) ; the list can't be empty
    442 ($check-error (bytevector-map + (bytevector 1 2) (bytevector 1 2 3)))
    443 ($check-error (bytevector-map + (bytevector 1 2) . 
    444                               #0=((bytevector 1 2 3) . #0#)))
    445 
    446 ($check-error (bytevector-map number->char (bytevector 41 42 43)))
    447 ($check-error (bytevector-map + (bytevector 100 200) (bytevector 300 400)))
    448 
    449 ($check-error (bytevector-map + 1))
    450 ($check-error (bytevector-map + (list 1)))
    451 ($check-error (bytevector-map + (vector 1)))
    452 ($check-error (bytevector-map #inert (bytevector 1 2 3)))
    453 ($check-error (bytevector-map (unwrap char-upcase) (bytevector 1 2 3)))
    454 ($check-error (bytevector-map ($lambda (x) (+ x 1)) 
    455                               (bytevector 1 2 3) (bytevector 1 2 3)))
    456 ($check-error (bytevector-map ($lambda (x) (+ x 1)) . 
    457                               #0=((bytevector 1 2 3) . #0#)))