feat: 9.5.9
This commit is contained in:
tmtt
parent
cb1753732b
commit
35f43a7909
1084 changed files with 558985 additions and 0 deletions
325
nanopass/tests/helpers.ss
Normal file
325
nanopass/tests/helpers.ss
Normal file
|
|
@ -0,0 +1,325 @@
|
|||
;;; 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)])))))
|
||||
Reference in a new issue