1;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell 2;;; See the accompanying file Copyright for details 3 4(library (tests helpers) 5 (export compose disjoin any every choose reverse-filter fold reduce 6 constant? keyword? list-of-user-primitives list-of-system-primitives 7 user-primitive? system-primitive? primitive? predicate-primitive? 8 value-primitive? effect-primitive? effect-free-primitive? gen-label 9 reset-seed gen-symbol set? iota with-values 10 empty-set singleton-set 11 add-element member? empty? union intersection difference 12 variable? datum? list-index primapp sys-primapp app const-datum const 13 var quoted-const time printf system interpret pretty-print format set-cons 14 define-who) 15 (import (rnrs) 16 (tests implementation-helpers) 17 (nanopass helpers)) 18 19 (define-syntax primapp 20 (syntax-rules () 21 [(_ expr expr* ...) (expr expr* ...)])) 22 23 (define-syntax sys-primapp 24 (syntax-rules () 25 [(_ expr expr* ...) (expr expr* ...)])) 26 27 (define-syntax app 28 (syntax-rules () 29 [(_ expr expr* ...) (expr expr* ...)])) 30 31 (define-syntax const-datum 32 (syntax-rules () 33 [(_ expr) (quote expr)])) 34 35 (define-syntax const 36 (syntax-rules () 37 [(_ expr) expr])) 38 39 (define-syntax var 40 (syntax-rules () 41 [(_ expr) expr])) 42 43 (define-syntax quoted-const 44 (syntax-rules () 45 [(_ expr) (quote expr)])) 46 47 (define compose 48 (case-lambda 49 [() (lambda (x) x)] 50 [(f) f] 51 [(f . g*) (lambda (x) (f ((apply compose g*) x)))])) 52 53 (define disjoin 54 (case-lambda 55 [() (lambda (x) #f)] 56 [(p?) p?] 57 [(p? . q?*) (lambda (x) 58 (or (p? x) ((apply disjoin q?*) x)))])) 59 60 (define any 61 (lambda (pred? ls) 62 (let loop ([ls ls]) 63 (cond 64 [(null? ls) #f] 65 [(pred? (car ls)) #t] 66 [else (loop (cdr ls))])))) 67 68 (define every 69 (lambda (pred? ls) 70 (let loop ([ls ls]) 71 (cond 72 [(null? ls) #t] 73 [(pred? (car ls)) (loop (cdr ls))] 74 [else #f])))) 75 76 (define choose 77 (lambda (pred? ls) 78 (fold (lambda (elt tail) 79 (if (pred? elt) 80 (cons elt tail) 81 tail)) 82 '() 83 ls))) 84 85 (define reverse-filter 86 (lambda (pred? ls) 87 (fold (lambda (elt tail) 88 (if (pred? elt) 89 tail 90 (cons elt tail))) 91 '() 92 ls))) 93 94 ;; fold op base (cons a (cons b (cons c '()))) = 95 ;; (op a (op b (op c base))) 96 (define fold 97 (lambda (op base ls) 98 (let recur ([ls ls]) 99 (if (null? ls) 100 base 101 (op (car ls) (recur (cdr ls))))))) 102 103 ;; reduce op base (cons a (cons b (cons c '()))) 104 ;; (op c (op b (op a base))) 105 (define reduce 106 (lambda (op base ls) 107 (let loop ([ls ls] [ans base]) 108 (if (null? ls) 109 ans 110 (loop (cdr ls) (op (car ls) ans)))))) 111 112 ;;; General Scheme helpers for the compiler 113 (define constant? 114 (disjoin null? number? char? boolean? string?)) 115 116 (define keyword? 117 (lambda (x) 118 (and (memq x '(quote set! if begin let letrec lambda)) #t))) 119 120 (define datum? 121 (lambda (x) 122 (or (constant? x) 123 (null? x) 124 (if (pair? x) 125 (and (datum? (car x)) (datum? (cdr x))) 126 (and (vector? x) (for-all datum? (vector->list x))))))) 127 128 (define variable? symbol?) 129 130 (define list-of-user-primitives 131 '(; not is a special case 132 (not 1 not) 133 134 ; predicates 135 (< 2 test) 136 (<= 2 test) 137 (= 2 test) 138 (boolean? 1 test) 139 (char? 1 test) 140 (eq? 2 test) 141 (integer? 1 test) 142 (null? 1 test) 143 (pair? 1 test) 144 (procedure? 1 test) 145 146 (vector? 1 test) 147 (zero? 1 test) 148 149 ; value-producing 150 (* 2 value) 151 (+ 2 value) 152 (- 2 value) 153 (add1 1 value) 154 (car 1 value) 155 (cdr 1 value) 156 (char->integer 1 value) 157 (cons 2 value) 158 159 (make-vector 1 value) 160 (quotient 2 value) 161 (remainder 2 value) 162 163 (sub1 1 value) 164 165 (vector -1 value) 166 (vector-length 1 value) 167 (vector-ref 2 value) 168 (void 0 value) 169 170 ; side-effecting 171 (set-car! 2 effect) 172 (set-cdr! 2 effect) 173 174 (vector-set! 3 effect))) 175 176 (define list-of-system-primitives ; these are introduced later by the compiler 177 '(; value-producing 178 (closure-ref 2 value) 179 (make-closure 2 value) 180 (procedure-code 1 value) 181 182 ; side-effecting 183 (closure-set! 3 effect) 184 185 (fref 1 value) 186 (fset! 2 effect) 187 (fincr! 1 effect) 188 (fdecr! 1 effect) 189 (href 2 value) 190 (hset! 3 effect) 191 (logand 2 value) 192 (sll 2 value) 193 (sra 2 value))) 194 195 (define user-primitive? 196 (lambda (x) 197 (and (assq x list-of-user-primitives) #t))) 198 199 (define system-primitive? 200 (lambda (x) 201 (and (assq x list-of-system-primitives) #t))) 202 203 (define primitive? 204 (lambda (x) 205 (or (user-primitive? x) (system-primitive? x)))) 206 207 (define predicate-primitive? 208 (lambda (x) 209 (cond 210 [(or (assq x list-of-user-primitives) 211 (assq x list-of-system-primitives)) => 212 (lambda (a) (eq? (caddr a) 'test))] 213 [else #f]))) 214 215 (define value-primitive? 216 (lambda (x) 217 (cond 218 [(or (assq x list-of-user-primitives) 219 (assq x list-of-system-primitives)) => 220 (lambda (a) (eq? (caddr a) 'value))] 221 [else #f]))) 222 223 (define effect-primitive? 224 (lambda (x) 225 (cond 226 [(or (assq x list-of-user-primitives) 227 (assq x list-of-system-primitives)) => 228 (lambda (a) (eq? (caddr a) 'effect))] 229 [else #f]))) 230 231 (define effect-free-primitive? 232 (lambda (x) 233 (not (effect-primitive? x)))) 234 235 (define gen-label 236 ; at some point, gen-label should be redefined to emit 237 ; assembler-friendly labels 238 (lambda (sym) 239 (string->symbol (format "~a%" sym)))) 240 241 (define gen-symbol-seed 0) 242 243 (define reset-seed 244 (lambda () 245 (set! gen-symbol-seed 0))) 246 247 (define gen-symbol 248 (lambda (sym) 249 (set! gen-symbol-seed (+ gen-symbol-seed 1)) 250 (string->symbol (format "~a_~s" sym gen-symbol-seed)))) 251 252 (define set? 253 (lambda (ls) 254 (or (null? ls) 255 (and (not (memq (car ls) (cdr ls))) (set? (cdr ls)))))) 256 257 ;;; ==================== 258 ;;; Extra syntax and helpers for multiple values 259 260 ;;; Set abstraction 261 (define empty-set (lambda () '())) 262 263 (define singleton-set (lambda (elt) (list elt))) 264 265 (define add-element 266 (lambda (elt set) 267 (if (member? elt set) 268 set 269 (cons elt set)))) 270 271 (define member? memq) 272 273 (define empty? null?) 274 275 (define set-cons 276 (lambda (a set) 277 (if (memq a set) set (cons a set)))) 278 279 (define union 280 (case-lambda 281 [() (empty-set)] 282 [(set1 set2) 283 (cond 284 [(empty? set1) set2] 285 [(empty? set2) set1] 286 [(eq? set1 set2) set1] 287 [else (reduce (lambda (elt set) 288 (if (member? elt set2) set (cons elt set))) 289 set2 290 set1)])] 291 [(set1 . sets) 292 (if (null? sets) 293 set1 294 (union set1 (reduce union (empty-set) sets)))])) 295 296 (define intersection 297 (lambda (set1 . sets) 298 (cond 299 [(null? sets) set1] 300 [(any empty? sets) (empty-set)] 301 [else (choose 302 (lambda (elt) 303 (every (lambda (set) (member? elt set)) sets)) set1)]))) 304 305 (define list-index 306 (lambda (a ls) 307 (cond 308 [(null? ls) -1] 309 [(eq? (car ls) a) 0] 310 [else (maybe-add1 (list-index a (cdr ls)))]))) 311 312 (define maybe-add1 313 (lambda (n) 314 (if (= n -1) -1 (+ n 1)))) 315 316 (define difference 317 (lambda (set1 . sets) 318 (let ((sets (reverse-filter empty? sets))) 319 (cond 320 [(null? sets) set1] 321 [else (reverse-filter (lambda (elt) 322 (any (lambda (set) 323 (member? elt set)) 324 sets)) 325 set1)]))))) 326