klisp

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

test-helpers.k (3632B)

      1 ;;;
      2 ;;; Some helpers used in many modules
      3 ;;; (check.k should be loaded)
      4 ;;;
      5 
      6 ($define! not-eq? ($lambda (x y) (not? (eq? x y))))
      7 ($define! not-equal? ($lambda (x y) (not? (equal? x y))))
      8 ($define! $check-predicate ($vau (x) denv (eval (list $check eq? x #t) denv)))
      9 ($define! $check-not-predicate ($vau (x) denv (eval (list $check eq? x #f) denv)))
     10 ($define! $check-no-error ($vau (x) denv 
     11                             (eval (list $check 
     12                                         ($lambda (#ignore #ignore) #t)
     13                                         x 
     14                                         #inert) 
     15                                   denv)))
     16 
     17 ;; mutable-pair?, immutable-pair?, mutable-string? & immutable-string?
     18 ;; were added to the ground environment
     19 #|
     20 ($define! mutable-pair?
     21   ($lambda (obj)
     22     ($and? (pair? obj)
     23            (guard-dynamic-extent
     24             ()
     25             ($lambda ()
     26               (set-car! obj (car obj))
     27               #t)
     28             ;; As per the report (section 4.7.1) setting the car of an 
     29             ;; immutable pair (even if the value is the same) should 
     30             ;; signal an error.
     31             (list (list error-continuation
     32                         ($lambda (#ignore divert)
     33                           (apply divert #f))))))))
     34 
     35 ($define! immutable-pair?
     36   ($lambda (obj) ($and? (pair? obj) (not? (mutable-pair? obj)))))
     37 
     38 ($define! nonempty-mutable-string?
     39   ($lambda (obj)
     40     ($and?
     41      (string? obj)
     42      (>? (string-length obj) 0)
     43      (guard-dynamic-extent
     44       ()
     45       ($lambda () (string-fill! obj #\x) #t)
     46       (list
     47        (list error-continuation
     48              ($lambda (#ignore divert) (apply divert #f))))))))
     49 
     50 ($define! immutable-string?
     51   ($lambda (obj) ($and? (string? obj) (not? (nonempty-mutable-string? obj)))))
     52 |#
     53 
     54 ($define! nonempty-mutable-string? mutable-string?)
     55 
     56 ;; XXX/TODO Some of these could be removed if we had eager comprehension in
     57 ;; check.k (which would also complete the srfi-78 implementation). The problem
     58 ;; is that the design adaptation from macros to operatives should be taken
     59 ;; with some care. I intended to do it before the remaining tests, but since
     60 ;; Oto Havle went ahead and wrote the tests without it, they have lost some
     61 ;; priority. Andres Navarro 
     62 
     63 ;; ($false-for-all? P XS) evaluates to #t iff (P X) evaluates
     64 ;; to #f for all members X of the list XS.
     65 ;;
     66 ($define! $false-for-all?
     67   ($vau (p . xs) denv
     68     (apply and?
     69            (map ($lambda (x) (not? (eval (list p x) denv))) xs))))
     70 
     71 ;; (cartesian-product XS YS) returns list of all pairs (X Y),
     72 ;; where X is a member of the list XS and Y is a member of list YS.
     73 ;;
     74 ;; for example
     75 ;;  (cartesian-product (1 2) (3 4)) ===> ((1 3) (1 4) (2 3) (2 4))
     76 ;;
     77 ($define! cartesian-product
     78   ($lambda (xs ys)
     79     (apply append
     80            (map ($lambda (x) (map ($lambda (y) (list x y)) ys)) xs))))
     81 
     82 ;; ($true-for-all-combinations? BIN (X1 X2...) (Y1 Y1...))
     83 ;; evaluates to #t, iff (BIN X Y) evaluates to #t for all X and Y.
     84 ;;
     85 ($define! $true-for-all-combinations?
     86   ($vau (p xs ys) denv
     87     (apply and?
     88            (map ($lambda ((x y)) (eval (list p x y) denv))
     89                 (cartesian-product xs ys)))))
     90 
     91 ;; ($false-for-all-combinations? BIN (X1 X2...) (Y1 Y2...))
     92 ;; evaluates to #t, iff (BIN X Y) evaluates to #f for all X and Y.
     93 ;;
     94 ($define! $false-for-all-combinations?
     95   ($vau (p xs ys) denv
     96     (apply and?
     97            (map ($lambda ((x y)) (not? (eval (list p x y) denv)))
     98                 (cartesian-product xs ys)))))
     99 
    100 ;; ($quote V) evaluates to V. The value V itself is not evaluated.
    101 ;; See section 5.5.1, page 67 of the Kernel Report.
    102 ($define! $quote ($vau (x) #ignore x))