chez-openbsd/nanopass/tests/helpers.ss

;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details

(library (tests helpers)
  (export compose disjoin any every choose reverse-filter fold reduce
          constant? keyword? list-of-user-primitives list-of-system-primitives
          user-primitive? system-primitive? primitive? predicate-primitive?
          value-primitive? effect-primitive? effect-free-primitive? gen-label
          reset-seed gen-symbol set? iota with-values
          empty-set singleton-set
          add-element member? empty? union intersection difference
          variable? datum? list-index primapp sys-primapp app const-datum const
          var quoted-const time printf system interpret pretty-print format set-cons
          define-who)
  (import (rnrs) 
          (tests implementation-helpers) 
          (nanopass helpers)) 
  
  (define-syntax primapp
    (syntax-rules ()
      [(_ expr expr* ...) (expr expr* ...)])) 
  
  (define-syntax sys-primapp
    (syntax-rules ()
      [(_ expr expr* ...) (expr expr* ...)])) 
  
  (define-syntax app
    (syntax-rules ()
      [(_ expr expr* ...) (expr expr* ...)])) 
  
  (define-syntax const-datum
    (syntax-rules ()
      [(_ expr) (quote expr)])) 
  
  (define-syntax const
    (syntax-rules ()
      [(_ expr) expr])) 
  
  (define-syntax var
    (syntax-rules ()
      [(_ expr) expr])) 
  
  (define-syntax quoted-const
    (syntax-rules ()
      [(_ expr) (quote expr)])) 

  (define compose
    (case-lambda
      [() (lambda (x) x)]
      [(f) f]
      [(f . g*) (lambda (x) (f ((apply compose g*) x)))])) 
  
  (define disjoin
    (case-lambda
      [() (lambda (x) #f)]
      [(p?) p?]
      [(p? . q?*) (lambda (x) 
                    (or (p? x) ((apply disjoin q?*) x)))])) 
  
  (define any
    (lambda (pred? ls)
      (let loop ([ls ls])
        (cond
          [(null? ls) #f]
          [(pred? (car ls)) #t]
          [else (loop (cdr ls))])))) 
  
  (define every
    (lambda (pred? ls)
      (let loop ([ls ls])
        (cond
          [(null? ls) #t]
          [(pred? (car ls)) (loop (cdr ls))]
          [else #f])))) 
  
  (define choose
    (lambda (pred? ls)
      (fold (lambda (elt tail)
              (if (pred? elt)
                  (cons elt tail)
                  tail))
            '()
            ls))) 
  
  (define reverse-filter
    (lambda (pred? ls)
      (fold (lambda (elt tail)
              (if (pred? elt)
                  tail
                  (cons elt tail)))
            '()
            ls))) 
  
  ;; fold op base (cons a (cons b (cons c '()))) =
  ;; (op a (op b (op c base)))
  (define fold
    (lambda (op base ls)
      (let recur ([ls ls])
        (if (null? ls)
            base
            (op (car ls) (recur (cdr ls))))))) 
  
  ;; reduce op base (cons a (cons b (cons c '())))
  ;; (op c (op b (op a base)))
  (define reduce 
    (lambda (op base ls)
      (let loop ([ls ls] [ans base])
        (if (null? ls)
            ans
            (loop (cdr ls) (op (car ls) ans)))))) 
  
  ;;; General Scheme helpers for the compiler 
  (define constant?
    (disjoin null? number? char? boolean? string?)) 

  (define keyword?
    (lambda (x)
      (and (memq x '(quote set! if begin let letrec lambda)) #t))) 
  
  (define datum?
    (lambda (x)
      (or (constant? x)
          (null? x)
          (if (pair? x)
            (and (datum? (car x)) (datum? (cdr x)))
            (and (vector? x) (for-all datum? (vector->list x))))))) 
  
  (define variable? symbol?)
  
  (define list-of-user-primitives
    '(; not is a special case
      (not 1 not) 
      
      ; predicates
      (< 2 test)
      (<= 2 test)
      (= 2 test)
      (boolean? 1 test)
      (char? 1 test)
      (eq? 2 test)
      (integer? 1 test)
      (null? 1 test)
      (pair? 1 test)
      (procedure? 1 test)

      (vector? 1 test)
      (zero? 1 test) 
      
      ; value-producing
      (* 2 value)
      (+ 2 value)
      (- 2 value)
      (add1 1 value)
      (car 1 value)
      (cdr 1 value)
      (char->integer 1 value)
      (cons 2 value) 

      (make-vector 1 value)
      (quotient 2 value)
      (remainder 2 value) 
      
      (sub1 1 value) 
      
      (vector -1 value)
      (vector-length 1 value)
      (vector-ref 2 value)
      (void 0 value) 
      
      ; side-effecting
      (set-car! 2 effect)
      (set-cdr! 2 effect) 
      
      (vector-set! 3 effect))) 
  
  (define list-of-system-primitives ; these are introduced later by the compiler
    '(; value-producing
      (closure-ref 2 value)
      (make-closure 2 value)
      (procedure-code 1 value) 
      
      ; side-effecting
      (closure-set! 3 effect) 
      
      (fref 1 value)
      (fset! 2 effect)
      (fincr! 1 effect)
      (fdecr! 1 effect)
      (href 2 value)
      (hset! 3 effect)
      (logand 2 value)
      (sll 2 value)
      (sra 2 value))) 
  
  (define user-primitive?
    (lambda (x)
      (and (assq x list-of-user-primitives) #t))) 
  
  (define system-primitive?
    (lambda (x)
      (and (assq x list-of-system-primitives) #t))) 
  
  (define primitive?
    (lambda (x)
      (or (user-primitive? x) (system-primitive? x)))) 
  
  (define predicate-primitive?
    (lambda (x)
      (cond
        [(or (assq x list-of-user-primitives)
             (assq x list-of-system-primitives)) =>
         (lambda (a) (eq? (caddr a) 'test))]
        [else #f]))) 
  
  (define value-primitive?
    (lambda (x) 
      (cond
        [(or (assq x list-of-user-primitives)
             (assq x list-of-system-primitives)) =>
         (lambda (a) (eq? (caddr a) 'value))]
        [else #f]))) 
  
  (define effect-primitive?
    (lambda (x)
      (cond
        [(or (assq x list-of-user-primitives)
             (assq x list-of-system-primitives)) =>
         (lambda (a) (eq? (caddr a) 'effect))]
        [else #f]))) 
  
  (define effect-free-primitive?
    (lambda (x)
      (not (effect-primitive? x))))

  (define gen-label
    ; at some point, gen-label should be redefined to emit
    ; assembler-friendly labels
    (lambda (sym)
      (string->symbol (format "~a%" sym))))

  (define gen-symbol-seed 0)

  (define reset-seed
    (lambda ()
      (set! gen-symbol-seed 0)))
  
  (define gen-symbol
    (lambda (sym)
      (set! gen-symbol-seed (+ gen-symbol-seed 1))
      (string->symbol (format "~a_~s" sym gen-symbol-seed)))) 
  
  (define set?
    (lambda (ls)
      (or (null? ls)
          (and (not (memq (car ls) (cdr ls))) (set? (cdr ls)))))) 
  
  ;;; ====================
  ;;; Extra syntax and helpers for multiple values 
  
  ;;; Set abstraction
  (define empty-set (lambda () '())) 
  
  (define singleton-set (lambda (elt) (list elt))) 
  
  (define add-element
    (lambda (elt set)
      (if (member? elt set)
          set
          (cons elt set)))) 
 
  (define member? memq)
  
  (define empty? null?) 

  (define set-cons
    (lambda (a set)
      (if (memq a set) set (cons a set))))
  
  (define union
    (case-lambda
      [() (empty-set)]
      [(set1 set2)
       (cond
         [(empty? set1) set2]
         [(empty? set2) set1]
         [(eq? set1 set2) set1]
         [else (reduce (lambda (elt set)
                         (if (member? elt set2) set (cons elt set)))
                       set2
                       set1)])]
      [(set1 . sets)
       (if (null? sets)
           set1
           (union set1 (reduce union (empty-set) sets)))])) 
  
  (define intersection
    (lambda (set1 . sets)
      (cond
        [(null? sets) set1]
        [(any empty? sets) (empty-set)]
        [else (choose
                (lambda (elt)
                  (every (lambda (set) (member? elt set)) sets)) set1)]))) 
  
  (define list-index
    (lambda (a ls)
      (cond
        [(null? ls) -1]
        [(eq? (car ls) a) 0]
        [else (maybe-add1 (list-index a (cdr ls)))])))  

  (define maybe-add1
    (lambda (n)
      (if (= n -1) -1 (+ n 1))))

  (define difference
    (lambda (set1 . sets)
      (let ((sets (reverse-filter empty? sets)))
        (cond
          [(null? sets) set1]
          [else (reverse-filter (lambda (elt)
                                  (any (lambda (set) 
                                         (member? elt set)) 
                                       sets))
                                set1)])))))