1(provide 'mockery.scm) 2 3;;; the exported mock data classes 4(define *mock-vector* #f) 5(define *mock-pair* #f) 6(define *mock-string* #f) 7(define *mock-hash-table* #f) 8(define *mock-symbol* #f) 9(define *mock-c-pointer* #f) 10(define *mock-random-state* #f) 11(define *mock-char* #f) 12(define *mock-number* #f) 13(define *mock-iterator* #f) 14(define *mock-port* #f) 15 16 17(let () ; rest of file is in this let 18 19 (define (->value obj) 20 (if (and (let? obj) 21 (symbol? (obj 'mock-type))) 22 (obj 'value) 23 obj)) 24 25 (define (mock? obj) 26 (and (let? obj) 27 (symbol? (obj 'mock-type)))) 28 29 (define (with-mock-wrapper func) 30 (lambda (obj) 31 (cond ((mock? obj) 32 (let-temporarily (((*s7* 'openlets) #f)) 33 (func (obj 'value)))) 34 35 ((not (openlet? obj)) 36 (func obj)) 37 38 ((procedure? obj) ; TODO: and c-pointer? c-object? 39 (let-temporarily (((*s7* 'openlets) #f)) 40 (func obj))) 41 42 (else 43 (let ((func-name (string->symbol (object->string func)))) 44 (if (procedure? (obj func-name)) 45 ((obj func-name) obj) 46 (func obj))))))) 47 48 (define (with-mock-wrapper* func) 49 (lambda args 50 (let ((unknown-openlets #f) 51 (new-args ())) 52 (for-each (lambda (arg) ; not map here because (values) should not be ignored: (+ (mock-number 4/3) (values)) 53 (set! new-args 54 (cons (if (mock? arg) 55 (arg 'value) 56 (begin 57 (if (and (openlet? arg) 58 (not (procedure? arg)) 59 (not (macro? arg)) 60 (not (c-pointer? arg))) 61 (set! unknown-openlets #t)) 62 arg)) 63 new-args))) 64 args) 65 (if unknown-openlets 66 (apply func (reverse! new-args)) 67 (let-temporarily (((*s7* 'openlets) #f)) 68 (apply func (reverse! new-args))))))) 69 70 ;; one tricky thing here is that a mock object can be the let of with-let: (with-let (mock-port ...) ...) 71 ;; so a mock object's method can be called even when no argument is a mock object. Even trickier 72 ;; (display (openlet (with-let (mock-c-pointer 0) (lambda () 1)))) 73 ;; -------------------------------------------------------------------------------- 74 75 (set! *mock-vector* 76 (let* ((mock-vector? #f) 77 (mock-vector-class 78 (inlet 'local-set! (lambda (obj i val) ; reactive-vector uses this as a hook into vector-set! 79 (if (mock-vector? i) 80 (error 'wrong-type-arg "stray mock-vector? ~S" i)) 81 (#_vector-set! (->value obj) i val)) 82 83 'vector-set! (lambda (obj i val) ((obj 'local-set!) obj i val) val) 84 85 'let-set-fallback (lambda (obj i val) 86 (if (and (integer? i) 87 (defined? 'value obj)) 88 (begin 89 ((obj 'local-set!) obj i val) 90 val) 91 (error 'out-of-range "unknown field: ~S" i))) 92 93 'let-ref-fallback (lambda (obj i) 94 (if (and (integer? i) 95 (defined? 'value obj)) 96 (#_vector-ref (obj 'value) i) ; the implicit case 97 (error 'out-of-range "unknown field: ~S" i))) 98 99 'equivalent? (with-mock-wrapper* #_equivalent?) 100 'vector-ref (with-mock-wrapper* #_vector-ref) 101 'vector-length (if (provided? 'pure-s7) 102 (lambda (vect) 103 (if (vector? vect) 104 (length vect) 105 (error 'wrong-type-arg "vector-length argument should be a vector: ~A" vect))) 106 (with-mock-wrapper #_vector-length)) 107 'reverse (with-mock-wrapper #_reverse) 108 'sort! (with-mock-wrapper* #_sort!) 109 'make-iterator (with-mock-wrapper #_make-iterator) 110 'arity (with-mock-wrapper #_arity) 111 'object->string (with-mock-wrapper* #_object->string) 112 'format (with-mock-wrapper* #_format) 113 'write (with-mock-wrapper* #_write) 114 'display (with-mock-wrapper* #_display) 115 'vector-dimensions (with-mock-wrapper #_vector-dimensions) 116 'fill! (with-mock-wrapper* #_fill!) 117 'vector-fill! (with-mock-wrapper* #_vector-fill!) 118 'vector->list (with-mock-wrapper* #_vector->list) 119 'subvector (with-mock-wrapper* #_subvector) 120 'copy (with-mock-wrapper* #_copy) 121 'vector? (with-mock-wrapper #_vector?) 122 'int-vector? (with-mock-wrapper #_int-vector?) 123 'byte-vector? (with-mock-wrapper #_byte-vector?) 124 'float-vector? (with-mock-wrapper #_float-vector?) 125 'length (with-mock-wrapper #_length) 126 'vector-append (with-mock-wrapper* #_vector-append) 127 'append (with-mock-wrapper* #_append) 128 'class-name '*mock-vector*))) 129 130 (define (make-mock-vector len . rest) 131 (openlet 132 (sublet mock-vector-class 133 'value (apply #_make-vector len rest) 134 'mock-type 'mock-vector?))) 135 136 (define (mock-vector . args) 137 (openlet 138 (sublet mock-vector-class 139 'value (apply #_vector args) 140 'mock-type 'mock-vector?))) 141 142 (set! mock-vector? (lambda (obj) 143 (and (let? obj) 144 (defined? 'mock-type obj #t) 145 (eq? (obj 'mock-type) 'mock-vector?)))) 146 147 (curlet))) 148 149 150#| 151 ;; vector that grows to accommodate vector-set! 152 (define (stretchable-vector) 153 (let ((local-ref (lambda (obj index) 154 (if (>= index (length (obj 'value))) 155 (obj 'initial-element) 156 (#_vector-ref (obj 'value) index)))) 157 (local-set! (lambda (obj index val) 158 (if (>= index (length (obj 'value))) 159 (set! (obj 'value) (copy (obj 'value) (make-vector (+ index 8) (obj 'initial-element))))) 160 (#_vector-set! (obj 'value) index val)))) 161 (openlet 162 (sublet (*mock-vector* 'mock-vector-class) 163 'value (vector) 164 'mock-type 'mock-vector? 165 'initial-element #f 166 'vector-ref local-ref 167 'let-ref-fallback local-ref 168 'vector-set! local-set! 169 'let-set-fallback local-set!)))) 170|# 171 172 173 ;; -------------------------------------------------------------------------------- 174 175 (set! *mock-hash-table* 176 (let* ((mock-hash-table? #f) 177 (mock-hash-table-class 178 (inlet 'let-ref-fallback (lambda (obj key) 179 (if (defined? 'value obj) 180 (#_hash-table-ref (obj 'value) key))) 181 182 'let-set-fallback (lambda (obj key val) 183 (if (defined? 'value obj) 184 (#_hash-table-set! (obj 'value) key val))) 185 186 ;; the fallbacks are needed because hash-tables and lets use exactly the same syntax in implicit indexing: 187 ;; (x 'y) but s7 can't tell that in this one case, we actually want the 'y to be a key not a field. 188 ;; So, to avoid infinite recursion in let-ref (implicit index), if let-ref can't find the let field, 189 ;; and the let has 'let-ref|set!-fallback, let-ref|set! passes the argument to that function rather than 190 ;; return #<undefined>. 191 ;; 192 ;; (round (openlet (inlet 'round (lambda (obj) (#_round (obj 'value))) 'let-ref-fallback (lambda args 3)))) -> 3 193 194 'hash-table-ref (with-mock-wrapper* #_hash-table-ref) 195 'hash-table-set! (with-mock-wrapper* #_hash-table-set!) 196 'equivalent? (with-mock-wrapper* #_equivalent?) 197 'hash-table-entries (with-mock-wrapper #_hash-table-entries) 198 'make-iterator (with-mock-wrapper #_make-iterator) 199 'fill! (with-mock-wrapper* #_fill!) 200 'object->string (with-mock-wrapper* #_object->string) 201 'format (with-mock-wrapper* #_format) 202 'write (with-mock-wrapper* #_write) 203 'display (with-mock-wrapper* #_display) 204 'reverse (with-mock-wrapper #_reverse) 205 'arity (with-mock-wrapper #_arity) 206 'copy (with-mock-wrapper* #_copy) 207 'hash-table? (with-mock-wrapper #_hash-table?) 208 'length (with-mock-wrapper #_length) 209 'append (with-mock-wrapper* #_append) 210 'class-name '*mock-hash-table*))) 211 212 (define (make-mock-hash-table . rest) 213 (openlet 214 (sublet mock-hash-table-class 215 'value (apply #_make-hash-table rest) 216 'mock-type 'mock-hash-table?))) 217 218 (define (mock-hash-table . args) 219 (openlet 220 (sublet mock-hash-table-class 221 'value (apply #_hash-table args) 222 'mock-type 'mock-hash-table?))) 223 224 (set! mock-hash-table? (lambda (obj) 225 (and (let? obj) 226 (defined? 'mock-type obj #t) 227 (eq? (obj 'mock-type) 'mock-hash-table?)))) 228 229 (curlet))) 230 231 232#| 233 ;; hash-table that returns a special identifier when key is not in the table 234 235 (define (gloomy-hash-table) 236 (openlet 237 (sublet (*mock-hash-table* 'mock-hash-table-class) ; ideally this would be a separate (not copied) gloomy-hash-table-class 238 'value #f 239 'mock-type 'mock-hash-table? 240 'false (gensym) 241 'not-a-key #f 242 'hash-table-ref (lambda (obj key) 243 (let ((val (#_hash-table-ref (obj 'value) key))) 244 (if (eq? val (obj 'false)) 245 #f 246 (or val (obj 'not-a-key))))) 247 'hash-table-key? (lambda (obj key) 248 (#_hash-table-ref (obj 'value) key))))) 249 250 (define (hash-table-key? obj key) 251 ((obj 'hash-table-key?) obj key)) 252 253 (define* (make-gloomy-hash-table (len 511) not-a-key) 254 (let ((ht (gloomy-hash-table))) 255 (set! (ht 'value) (make-hash-table len)) 256 (set! (ht 'not-a-key) not-a-key) 257 ht)) 258|# 259 260 261 ;; -------------------------------------------------------------------------------- 262 263 (set! *mock-string* 264 (let* ((mock-string? #f) 265 (mock-string-class 266 (inlet 'equivalent? (with-mock-wrapper* #_equivalent?) 267 'reverse (with-mock-wrapper #_reverse) 268 'arity (with-mock-wrapper #_arity) 269 'make-iterator (with-mock-wrapper* #_make-iterator) 270 271 'let-ref-fallback (lambda (obj i) 272 (if (and (integer? i) 273 (defined? 'value obj)) 274 (#_string-ref (obj 'value) i) ; these are the implicit cases 275 (error 'out-of-range "unknown field: ~S" i))) 276 277 'let-set-fallback (lambda (obj i val) 278 (if (and (integer? i) 279 (defined? 'value obj)) 280 (#_string-set! (obj 'value) i val) 281 (error 'out-of-range "unknown field: ~S" i))) 282 283 'string-length (if (provided? 'pure-s7) 284 (lambda (str) 285 (if (string? str) 286 (length str) 287 (error 'wrong-type-arg "string-length argument should be a string: ~A" str))) 288 (with-mock-wrapper #_string-length)) 289 290 'string-append (with-mock-wrapper* #_string-append) 291 'string-copy (with-mock-wrapper #_copy) ; new form -> with-mock-wrapper* ? 292 293 'string=? (with-mock-wrapper* #_string=?) 294 'string<? (with-mock-wrapper* #_string<?) 295 'string>? (with-mock-wrapper* #_string>?) 296 'string<=? (with-mock-wrapper* #_string<=?) 297 'string>=? (with-mock-wrapper* #_string>=?) 298 299 'string-downcase (with-mock-wrapper #_string-downcase) 300 'string-upcase (with-mock-wrapper #_string-upcase) 301 'string->symbol (with-mock-wrapper #_string->symbol) 302 'symbol (with-mock-wrapper #_symbol) 303 'string->keyword (with-mock-wrapper #_string->keyword) 304 'open-input-string (with-mock-wrapper #_open-input-string) 305 'directory? (with-mock-wrapper #_directory?) 306 'file-exists? (with-mock-wrapper #_file-exists?) 307 'getenv (with-mock-wrapper #_getenv) 308 'delete-file (with-mock-wrapper #_delete-file) 309 'string->byte-vector (with-mock-wrapper #_string->byte-vector) 310 'object->string (with-mock-wrapper* #_object->string) 311 'format (with-mock-wrapper* #_format) 312 'write (with-mock-wrapper* #_write) 313 'display (with-mock-wrapper* #_display) 314 'char-position (with-mock-wrapper* #_char-position) 315 'string-fill! (with-mock-wrapper* #_string-fill!) 316 'gensym (with-mock-wrapper* #_gensym) 317 'call-with-input-string (with-mock-wrapper* #_call-with-input-string) 318 'with-input-from-string (with-mock-wrapper* #_with-input-from-string) 319 'system (with-mock-wrapper* #_system) 320 'load (with-mock-wrapper* #_load) 321 'eval-string (with-mock-wrapper* #_eval-string) 322 'string->list (with-mock-wrapper* #_string->list) 323 'bignum (with-mock-wrapper #_bignum) 324 'fill! (with-mock-wrapper* #_fill!) 325 'write-string (with-mock-wrapper* #_write-string) 326 'copy (with-mock-wrapper* #_copy) 327 'substring (with-mock-wrapper* #_substring) 328 'string->number (with-mock-wrapper* #_string->number) 329 'string-position (with-mock-wrapper* #_string-position) 330 'string-ref (with-mock-wrapper* #_string-ref) 331 'string-set! (with-mock-wrapper* #_string-set!) 332 'string-ci=? (with-mock-wrapper* #_string-ci=?) 333 'string-ci<? (with-mock-wrapper* #_string-ci<?) 334 'string-ci>? (with-mock-wrapper* #_string-ci>?) 335 'string-ci<=? (with-mock-wrapper* #_string-ci<=?) 336 'string-ci>=? (with-mock-wrapper* #_string-ci>=?) 337 'string? (with-mock-wrapper #_string?) 338 'length (with-mock-wrapper #_string-length) 339 'append (with-mock-wrapper* #_append) 340 'class-name '*mock-string*))) 341 342 (define* (make-mock-string len (init #\null)) 343 (openlet 344 (sublet mock-string-class 345 'value (#_make-string len init) 346 'mock-type 'mock-string?))) 347 348 (define (mock-string . args) 349 (let ((v (make-mock-string 0))) 350 (set! (v 'value) 351 (if (string? (car args)) 352 (car args) 353 (apply #_string args))) 354 v)) 355 356 (set! mock-string? (lambda (obj) 357 (and (let? obj) 358 (defined? 'mock-type obj #t) 359 (eq? (obj 'mock-type) 'mock-string?)))) 360 361 (curlet))) 362 363#| 364 ;; string that is always the current time of day 365 (require libc.scm) 366 367 (define time-string 368 (let ((daytime (lambda args 369 (with-let (sublet *libc*) 370 (let ((timestr (make-string 64))) 371 (let ((len (strftime timestr 64 "%a %d-%b-%Y %H:%M %Z" 372 (localtime 373 (time.make (time (c-pointer 0))))))) 374 (substring timestr 0 len))))))) 375 (openlet 376 (sublet (*mock-string* 'mock-string-class) ; the mock-string isn't really needed here 377 'let-ref-fallback daytime 378 'object->string daytime)))) 379 380 ;; similarly ("JIT data"): 381 (define ? (openlet 382 (inlet 'object->string (lambda (obj . args) 383 (apply #_object->string (owlet) args))))) 384|# 385 386 387 ;; -------------------------------------------------------------------------------- 388 389 (set! *mock-char* 390 (let* ((mock-char? #f) 391 (mock-char-class 392 (inlet 'equivalent? (with-mock-wrapper* #_equivalent?) 393 'char-upcase (with-mock-wrapper #_char-upcase) 394 'char-downcase (with-mock-wrapper #_char-downcase) 395 'char->integer (with-mock-wrapper #_char->integer) 396 'char-upper-case? (with-mock-wrapper #_char-upper-case?) 397 'char-lower-case? (with-mock-wrapper #_char-lower-case?) 398 'char-alphabetic? (with-mock-wrapper #_char-alphabetic?) 399 'char-numeric? (with-mock-wrapper #_char-numeric?) 400 'char-whitespace? (with-mock-wrapper #_char-whitespace?) 401 'char=? (with-mock-wrapper* #_char=?) 402 'char<? (with-mock-wrapper* #_char<?) 403 'char>? (with-mock-wrapper* #_char>?) 404 'char<=? (with-mock-wrapper* #_char<=?) 405 'char>=? (with-mock-wrapper* #_char>=?) 406 'char-ci=? (with-mock-wrapper* #_char-ci=?) 407 'char-ci<? (with-mock-wrapper* #_char-ci<?) 408 'char-ci>? (with-mock-wrapper* #_char-ci>?) 409 'char-ci<=? (with-mock-wrapper* #_char-ci<=?) 410 'char-ci>=? (with-mock-wrapper* #_char-ci>=?) 411 'string (with-mock-wrapper* #_string) 412 'string-fill! (with-mock-wrapper* #_string-fill!) 413 'fill! (with-mock-wrapper* #_fill!) 414 'object->string (with-mock-wrapper* #_object->string) 415 'format (with-mock-wrapper* #_format) 416 'write (with-mock-wrapper* #_write) 417 'display (with-mock-wrapper* #_display) 418 'arity (with-mock-wrapper #_arity) 419 'make-string (with-mock-wrapper* #_make-string) 420 'char-position (with-mock-wrapper* #_char-position) 421 'write-char (with-mock-wrapper* #_write-char) 422 'string-set! (with-mock-wrapper* #_string-set!) 423 'copy (with-mock-wrapper* #_copy) 424 'char? (with-mock-wrapper #_char?) 425 'class-name '*mock-char* 426 'length (lambda (obj) #f)))) 427 428 (define (mock-char c) 429 (if (and (char? c) 430 (not (let? c))) 431 (immutable! 432 (openlet 433 (sublet (*mock-char* 'mock-char-class) 434 'value c 435 'mock-type 'mock-char?))) 436 (error 'wrong-type-arg "mock-char arg ~S is not a char" c))) 437 438 (set! mock-char? (lambda (obj) 439 (and (let? obj) 440 (defined? 'mock-type obj #t) 441 (eq? (obj 'mock-type) 'mock-char?)))) 442 443 (curlet))) 444 445 ;; eventually I'll conjure up unichars like (define lambda (byte-vector #xce #xbb)) via mock-char, 446 ;; then combine those into unistring via mock-string 447 ;; 448 ;; (string-length obj)->g_utf8_strlen etc 449 ;; (g_unichar_isalpha (g_utf8_get_char (byte-vector #xce #xbb))) -> #t 450 ;; (g_utf8_strlen (byte-vector #xce #xbb #xce #xba) 10) -> 2 451 ;; (g_utf8_normalize (byte-vector #xce #xbb #xce #xba) 4 G_NORMALIZE_DEFAULT) 452 ;; but the ones that return gunichar (toupper) currently don't return a byte-vector or a string 453 ;; maybe gunichar->byte-vector? 454 ;; need glib.scm, or unicode.scm to load the stuff 455 456 457 458 ;; -------------------------------------------------------------------------------- 459 460 (set! *mock-number* 461 (let* ((mock-number? #f) 462 (mock-number-class 463 (inlet 464 'equivalent? (with-mock-wrapper* #_equivalent?) 465 'arity (with-mock-wrapper #_arity) 466 'real-part (with-mock-wrapper #_real-part) 467 'imag-part (with-mock-wrapper #_imag-part) 468 'numerator (with-mock-wrapper #_numerator) 469 'denominator (with-mock-wrapper #_denominator) 470 'even? (with-mock-wrapper #_even?) 471 'odd? (with-mock-wrapper #_odd?) 472 'zero? (with-mock-wrapper #_zero?) 473 'positive? (with-mock-wrapper #_positive?) 474 'negative? (with-mock-wrapper #_negative?) 475 'infinite? (with-mock-wrapper #_infinite?) 476 'nan? (with-mock-wrapper #_nan?) 477 ;'append (with-mock-wrapper* #_append) ;?? (append ... 3 ...) is an error 478 'magnitude (with-mock-wrapper #_magnitude) 479 'angle (with-mock-wrapper #_angle) 480 'rationalize (with-mock-wrapper* #_rationalize) 481 'abs (with-mock-wrapper #_abs) 482 'exp (with-mock-wrapper #_exp) 483 'log (with-mock-wrapper* #_log) 484 'sin (with-mock-wrapper #_sin) 485 'cos (with-mock-wrapper #_cos) 486 'tan (with-mock-wrapper #_tan) 487 'asin (with-mock-wrapper #_asin) 488 'acos (with-mock-wrapper #_acos) 489 'atan (with-mock-wrapper* #_atan) 490 'sinh (with-mock-wrapper #_sinh) 491 'cosh (with-mock-wrapper #_cosh) 492 'tanh (with-mock-wrapper #_tanh) 493 'asinh (with-mock-wrapper #_asinh) 494 'acosh (with-mock-wrapper #_acosh) 495 'atanh (with-mock-wrapper #_atanh) 496 'sqrt (with-mock-wrapper #_sqrt) 497 'expt (with-mock-wrapper* #_expt) 498 'floor (with-mock-wrapper #_floor) 499 'ceiling (with-mock-wrapper #_ceiling) 500 'truncate (with-mock-wrapper #_truncate) 501 'round (with-mock-wrapper #_round) 502 'integer->char (with-mock-wrapper #_integer->char) 503 'inexact->exact (with-mock-wrapper #_inexact->exact) 504 'exact->inexact (with-mock-wrapper #_exact->inexact) 505 'integer-length (with-mock-wrapper #_integer-length) 506 'integer-decode-float (with-mock-wrapper #_integer-decode-float) 507 'number? (with-mock-wrapper #_number?) 508 'integer? (with-mock-wrapper #_integer?) 509 'real? (with-mock-wrapper #_real?) 510 'complex? (with-mock-wrapper #_complex?) 511 'rational? (with-mock-wrapper #_rational?) 512 'exact? (with-mock-wrapper #_exact?) 513 'inexact? (with-mock-wrapper #_inexact?) 514 'lognot (with-mock-wrapper #_lognot) 515 'logior (with-mock-wrapper* #_logior) 516 'logxor (with-mock-wrapper* #_logxor) 517 'logand (with-mock-wrapper* #_logand) 518 'number->string (with-mock-wrapper* #_number->string) 519 'lcm (with-mock-wrapper* #_lcm) 520 'gcd (with-mock-wrapper* #_gcd) 521 '+ (with-mock-wrapper* #_+) 522 '- (with-mock-wrapper* #_-) 523 '* (with-mock-wrapper* #_*) 524 '/ (with-mock-wrapper* #_/) 525 'max (with-mock-wrapper* #_max) 526 'min (with-mock-wrapper* #_min) 527 '= (with-mock-wrapper* #_=) 528 '< (with-mock-wrapper* #_<) 529 '> (with-mock-wrapper* #_>) 530 '<= (with-mock-wrapper* #_<=) 531 '>= (with-mock-wrapper* #_>=) 532 533 'make-polar (if (provided? 'pure-s7) 534 (lambda (mag ang) (#_complex (* mag (cos ang)) (* mag (sin ang)))) 535 (lambda (mag ang) (#_make-polar (->value mag) (->value arg)))) 536 537 'make-rectangular (with-mock-wrapper* #_complex) 538 'complex (with-mock-wrapper* #_complex) 539 'random-state (with-mock-wrapper* #_random-state) 540 'ash (with-mock-wrapper* #_ash) 541 'logbit? (with-mock-wrapper* #_logbit?) 542 'quotient (with-mock-wrapper* #_quotient) 543 'remainder (with-mock-wrapper* #_remainder) 544 'modulo (with-mock-wrapper* #_modulo) 545 'random (with-mock-wrapper* #_random) 546 'write-byte (with-mock-wrapper* #_write-byte) 547 'make-list (with-mock-wrapper* #_make-list) 548 'make-vector (with-mock-wrapper* #_make-vector) 549 'make-float-vector (with-mock-wrapper* #_make-float-vector) 550 'make-int-vector (with-mock-wrapper* #_make-int-vector) 551 'make-byte-vector (with-mock-wrapper* #_make-byte-vector) 552 'make-hash-table (with-mock-wrapper* #_make-hash-table) 553 'object->string (with-mock-wrapper* #_object->string) 554 'format (with-mock-wrapper* #_format) 555 'write (with-mock-wrapper* #_write) 556 'display (with-mock-wrapper* #_display) 557 'string-fill! (with-mock-wrapper* #_string-fill!) 558 'copy (with-mock-wrapper* #_copy) 559 'vector->list (with-mock-wrapper* #_vector->list) 560 'string->list (with-mock-wrapper* #_string->list) 561 'substring (with-mock-wrapper* #_substring) 562 'vector-fill! (with-mock-wrapper* #_vector-fill!) 563 'fill! (with-mock-wrapper* #_fill!) 564 'make-string (with-mock-wrapper* #_make-string) 565 'string-ref (with-mock-wrapper* #_string-ref) 566 'string-set! (with-mock-wrapper* #_string-set!) 567 'string->number (with-mock-wrapper* #_string->number) 568 'list-ref (with-mock-wrapper* #_list-ref) 569 'list-set! (with-mock-wrapper* #_list-set!) 570 'list-tail (with-mock-wrapper* #_list-tail) 571 'vector-ref (with-mock-wrapper* #_vector-ref) 572 'float-vector-ref (with-mock-wrapper* #_float-vector-ref) 573 'int-vector-ref (with-mock-wrapper* #_int-vector-ref) 574 'byte-vector-ref (with-mock-wrapper* #_byte-vector-ref) 575 'vector-set! (with-mock-wrapper* #_vector-set!) 576 'float-vector-set! (with-mock-wrapper* #_float-vector-set!) 577 'int-vector-set! (with-mock-wrapper* #_int-vector-set!) 578 'byte-vector-set! (with-mock-wrapper* #_byte-vector-set!) 579 'float-vector (with-mock-wrapper* #_float-vector) 580 'int-vector (with-mock-wrapper* #_int-vector) 581 'byte-vector (with-mock-wrapper* #_byte-vector) 582 'subvector (with-mock-wrapper* #_subvector) 583 'read-string (with-mock-wrapper* #_read-string) 584 'length (with-mock-wrapper #_length) 585 'number? (with-mock-wrapper #_number?) 586 'class-name '*mock-number*))) 587 588 (define (mock-number x) 589 (if (and (number? x) 590 (not (let? x))) 591 (immutable! 592 (openlet 593 (sublet (*mock-number* 'mock-number-class) 594 'value x 595 'mock-type 'mock-number?))) 596 (error 'wrong-type-arg "mock-number ~S is not a number" x))) 597 598 (set! mock-number? (lambda (obj) 599 (and (let? obj) 600 (defined? 'mock-type obj #t) 601 (eq? (obj 'mock-type) 'mock-number?)))) 602 (curlet))) 603 604#| 605;; fuzzy number 606 607 (define fuzzy-number 608 (let ((fuzz (lambda (fx) 609 (#_* fx (#_- 1.05 (#_random .1)))))) 610 (lambda (fx) 611 (openlet 612 (sublet 613 (*mock-number* 'mock-number-class) 614 'let-ref-fallback (lambda (obj sym) (fuzz fx)) 615 'object->string (lambda (obj . args) (#_number->string (fuzz fx)))))))) 616 617 618 ;; interval arithmetic 619 ;; 620 ;; from Wikipedia: 621 ;; x + y = [a+c, b+d] 622 ;; x - y = [a-d, b-c] 623 ;; x / y = [min(a/c, a/d, b/c, b/d), max(a/c, a/d, b/c, b/d)] 624 625 (define *interval* 626 (let* ((make-interval #f) 627 (low (lambda (z) (z 'low))) 628 (high (lambda (z) (z 'high))) 629 (interval-class 630 (openlet (sublet (*mock-number* 'mock-number-class) 631 632 '+ (lambda args 633 (let ((lo 0) 634 (hi 0)) 635 (for-each 636 (lambda (z) 637 (if (let? z) 638 (begin 639 (set! lo (+ lo (low z))) 640 (set! hi (+ hi (high z)))) 641 (begin 642 (set! lo (+ lo z)) 643 (set! hi (+ hi z))))) 644 args) 645 (make-interval lo hi))) 646 647 '* (lambda args 648 (let ((lo 1) 649 (hi 1)) 650 (for-each 651 (lambda (z) 652 (let ((zlo (if (let? z) (low z) z)) 653 (zhi (if (let? z) (high z) z))) 654 (let ((ac (* lo zlo)) 655 (ad (* lo zhi)) 656 (bc (* hi zlo)) 657 (bd (* hi zhi))) 658 (set! lo (min ac ad bc bd)) 659 (set! hi (max ac ad bc bd))))) 660 args) 661 (make-interval lo hi))) 662 663 '- (lambda args 664 (let ((z (car args))) 665 (if (null? (cdr args)) ; negate (must be let? else how did we get here?) 666 (make-interval (- (high z)) (- (low z))) 667 (let ((lo (low z)) 668 (hi (high z))) 669 (for-each 670 (lambda (z) 671 (if (let? z) 672 (begin 673 (set! lo (- lo (high z))) 674 (set! hi (- hi (low z)))) 675 (begin 676 (set! lo (- lo z)) 677 (set! hi (- hi z))))) 678 (cdr args)) 679 (make-interval lo hi))))) 680 681 '/ (lambda args 682 (let ((z (car args))) 683 (if (null? (cdr args)) ; invert 684 (make-interval (/ (high z)) (/ (low z))) 685 (let ((lo (low z)) 686 (hi (high z))) 687 (for-each 688 (lambda (z) 689 (let ((zlo (if (let? z) (low z) z)) 690 (zhi (if (let? z) (high z) z))) 691 (let ((ac (/ lo zlo)) 692 (ad (/ lo zhi)) 693 (bc (/ hi zlo)) 694 (bd (/ hi zhi))) 695 (set! lo (min ac ad bc bd)) 696 (set! hi (max ac ad bc bd))))) 697 (cdr args)) 698 (make-interval lo hi))))) 699 700 'abs (lambda (z) 701 (if (positive? (low z)) 702 (make-interval (low z) (high z)) 703 (if (negative? (high z)) 704 (make-interval (abs (high z)) (abs (low z))) 705 (make-interval 0 (max (abs (low z)) (abs (high z))))))) 706 707 'object->string (lambda (obj . args) 708 (format #f "#<interval: ~S ~S>" (low obj) (high obj))) 709 )))) 710 711 (set! make-interval (lambda (low high) 712 (if (> low high) (format *stderr* "~A ~A~%" low high)) 713 (openlet (sublet interval-class 'low low 'high high)))) 714 715 (curlet))) 716 717 (define x ((*interval* 'make-interval) 3.0 4.0)) 718|# 719 720 721 722 ;; -------------------------------------------------------------------------------- 723 724 (set! *mock-pair* 725 (let* ((mock-pair? #f) 726 (mock-pair-class 727 (inlet 'equivalent? (with-mock-wrapper* #_equivalent?) 728 'pair-line-number (with-mock-wrapper #_pair-line-number) 729 'list->string (with-mock-wrapper #_list->string) 730 'object->string (with-mock-wrapper* #_object->string) 731 'format (with-mock-wrapper* #_format) 732 'write (with-mock-wrapper* #_write) 733 'display (with-mock-wrapper* #_display) 734 'list? (with-mock-wrapper #_list?) 735 'car (with-mock-wrapper #_car) 736 'cdr (with-mock-wrapper #_cdr) 737 'set-car! (with-mock-wrapper* #_set-car!) 738 'set-cdr! (with-mock-wrapper* #_set-cdr!) 739 'caar (with-mock-wrapper #_caar) 740 'cadr (with-mock-wrapper #_cadr) 741 'cdar (with-mock-wrapper #_cdar) 742 'cddr (with-mock-wrapper #_cddr) 743 'caaar (with-mock-wrapper #_caaar) 744 'caadr (with-mock-wrapper #_caadr) 745 'cadar (with-mock-wrapper #_cadar) 746 'cdaar (with-mock-wrapper #_cdaar) 747 'caddr (with-mock-wrapper #_caddr) 748 'cdddr (with-mock-wrapper #_cdddr) 749 'cdadr (with-mock-wrapper #_cdadr) 750 'cddar (with-mock-wrapper #_cddar) 751 'caaaar (with-mock-wrapper #_caaaar) 752 'caaadr (with-mock-wrapper #_caaadr) 753 'caadar (with-mock-wrapper #_caadar) 754 'cadaar (with-mock-wrapper #_cadaar) 755 'caaddr (with-mock-wrapper #_caaddr) 756 'cadddr (with-mock-wrapper #_cadddr) 757 'cadadr (with-mock-wrapper #_cadadr) 758 'caddar (with-mock-wrapper #_caddar) 759 'cdaaar (with-mock-wrapper #_cdaaar) 760 'cdaadr (with-mock-wrapper #_cdaadr) 761 'cdadar (with-mock-wrapper #_cdadar) 762 'cddaar (with-mock-wrapper #_cddaar) 763 'cdaddr (with-mock-wrapper #_cdaddr) 764 'cddddr (with-mock-wrapper #_cddddr) 765 'cddadr (with-mock-wrapper #_cddadr) 766 'cdddar (with-mock-wrapper #_cdddar) 767 'assoc (with-mock-wrapper* #_assoc) 768 'assq (with-mock-wrapper* #_assq) 769 'assv (with-mock-wrapper* #_assv) 770 'member (with-mock-wrapper* #_member) 771 'memq (with-mock-wrapper* #_memq) 772 'memv (with-mock-wrapper* #_memv) 773 774 'let-ref-fallback (lambda (obj ind) 775 (if (eq? ind 'value) 776 #<undefined> 777 (if (integer? ind) 778 (let ((val (begin 779 (coverlet obj) 780 (#_list-ref (obj 'value) ind)))) 781 (openlet obj) 782 val) 783 (error "let-ref mock-pair index is not an integer: ~S" ind)))) 784 'let-set-fallback (lambda (obj ind val) 785 (if (eq? ind 'value) 786 #<undefined> 787 (if (integer? ind) 788 (let ((val (begin 789 (coverlet obj) 790 (#_list-set! (obj 'value) ind val)))) 791 (openlet obj) 792 val) 793 (error "let-set! mock-pair index is not an integer: ~S" ind)))) 794 795 'reverse! (lambda (obj) 796 (if (mock-pair? obj) 797 (set! (obj 'value) (#_reverse (obj 'value))) 798 (#_reverse! obj))) 799 800 'list-tail (with-mock-wrapper* #_list-tail) 801 'sort! (with-mock-wrapper* #_sort!) 802 'reverse (with-mock-wrapper #_reverse) 803 'arity (with-mock-wrapper #_arity) 804 'make-iterator (with-mock-wrapper #_make-iterator) 805 'eval (with-mock-wrapper #_eval) 806 'list->vector (with-mock-wrapper #_list->vector) 807 'fill! (with-mock-wrapper* #_fill!) 808 'copy (with-mock-wrapper* #_copy) 809 'subvector (with-mock-wrapper* #_subvector) 810 'make-vector (with-mock-wrapper* #_make-vector) 811 'list-ref (with-mock-wrapper* #_list-ref) 812 'list-set! (with-mock-wrapper* #_list-set!) 813 'pair? (with-mock-wrapper #_pair?) 814 'length (with-mock-wrapper #_length) 815 'append (with-mock-wrapper* #_append) 816 'class-name '*mock-pair*))) 817 818 (define (mock-pair . args) 819 (openlet 820 (sublet (*mock-pair* 'mock-pair-class) 821 'value (copy args) 822 'mock-type 'mock-pair?))) 823 824 (set! mock-pair? (lambda (obj) 825 (and (let? obj) 826 (defined? 'mock-type obj #t) 827 (eq? (obj 'mock-type) 'mock-pair?)))) 828 829 (curlet))) 830 831#| 832 (let ((immutable-list-class 833 (sublet (*mock-pair* 'mock-pair-class) 834 'let-set-fallback (lambda (obj i val) 835 (set! (obj 'value) (append (copy (obj 'value) (make-list (+ i 1))) (list-tail (obj 'value) (+ i 1)))) 836 (list-set! (obj 'value) i val)) 837 'list-set! (lambda (obj i val) 838 (set! (obj 'value) (append (copy (obj 'value) (make-list (+ i 1))) (list-tail (obj 'value) (+ i 1)))) 839 (list-set! (obj 'value) i val)) 840 'set-car! (lambda (obj val) 841 (set! (obj 'value) (cons val (cdr (obj 'value))))) 842 'set-cdr! (lambda (obj val) 843 (set! (obj 'value) (cons (car (obj 'value)) val))) 844 'fill! (lambda (obj val) 845 (set! (obj 'value) (fill! (copy (obj 'value)) val))) 846 'reverse! (lambda (obj) 847 (set! (obj 'value) (reverse (obj 'value)))) 848 'sort! (lambda (obj func) 849 (set! (obj 'value) (sort! (copy (obj 'value)) func)))))) 850 851 (define (immutable-list lst) 852 (openlet 853 (sublet immutable-list-class 854 'value lst 855 'mock-type 'mock-pair?))) 856|# 857 858;; since a mock-pair prints itself as if a list, you can get some strange printout results: 859;; (cons 'a ((*mock-pair* 'mock-pair) 'b 'c)) -> '(a . (b c)) 860 861 862 863 ;; -------------------------------------------------------------------------------- 864 865 (set! *mock-symbol* 866 (let* ((mock-symbol? #f) 867 (mock-symbol-class 868 (inlet 'equivalent? (with-mock-wrapper* #_equivalent?) 869 'gensym? (with-mock-wrapper #_gensym?) 870 ;'append (with-mock-wrapper* #_append) ;? (append ... 'a ...) is an error 871 'fill! (with-mock-wrapper* #_fill!) 872 'symbol->string (with-mock-wrapper #_symbol->string) 873 'symbol->value (with-mock-wrapper* #_symbol->value) 874 'symbol->dynamic-value (with-mock-wrapper #_symbol->dynamic-value) 875 'setter (with-mock-wrapper #_setter) 876 'provided? (with-mock-wrapper #_provided?) 877 'provide (with-mock-wrapper #_provide) 878 'defined? (with-mock-wrapper #_defined?) 879 'symbol->keyword (with-mock-wrapper #_symbol->keyword) 880 'keyword? (with-mock-wrapper #_keyword?) 881 'keyword->symbol (with-mock-wrapper #_keyword->symbol) 882 'object->string (with-mock-wrapper* #_object->string) 883 'format (with-mock-wrapper* #_format) 884 'write (with-mock-wrapper* #_write) 885 'display (with-mock-wrapper* #_display) 886 'symbol? (with-mock-wrapper #_symbol?) 887 'class-name '*mock-symbol* 888 ))) 889 890 (define (mock-symbol s) 891 (if (symbol? s) 892 (immutable! 893 (openlet 894 (sublet (*mock-symbol* 'mock-symbol-class) 895 'value s 896 'mock-type 'mock-symbol?))) 897 (error 'wrong-type-arg "mock-symbol ~S is not a symbol" s))) 898 899 (set! mock-symbol? (lambda (obj) 900 (and (let? obj) 901 (defined? 'mock-type obj #t) 902 (eq? (obj 'mock-type) 'mock-symbol?)))) 903 904 (curlet))) 905 906 907 ;; -------------------------------------------------------------------------------- 908 909 (set! *mock-c-pointer* 910 (let* ((mock-c-pointer? #f) 911 (mock-c-pointer-class 912 (inlet 'c-pointer? (with-mock-wrapper #_c-pointer?) 913 'c-pointer-type (with-mock-wrapper #_c-pointer-type) 914 'c-pointer-info (with-mock-wrapper #_c-pointer-info) 915 'c-pointer-weak1 (with-mock-wrapper #_c-pointer-weak1) 916 'c-pointer-weak2 (with-mock-wrapper #_c-pointer-weak2) 917 'c-pointer->list (with-mock-wrapper #_c-pointer->list) 918 'object->string (with-mock-wrapper* #_object->string) 919 'format (with-mock-wrapper* #_format) 920 'write (with-mock-wrapper* #_write) 921 'display (with-mock-wrapper* #_display) 922 'fill! (with-mock-wrapper* #_fill!) 923 ))) 924 925 (define* (mock-c-pointer (int 0) type info weak1 weak2) 926 (immutable! 927 (openlet 928 (sublet (*mock-c-pointer* 'mock-c-pointer-class) 929 'value (#_c-pointer (->value int) (->value type) (->value info) (->value weak1) (->value weak2)) 930 'mock-type 'mock-c-pointer?)))) 931 932 (set! mock-c-pointer? 933 (lambda (obj) 934 (and (let? obj) 935 (defined? 'mock-type obj #t) 936 (eq? (obj 'mock-type) 'mock-c-pointer?)))) 937 938 (curlet))) 939 940 941 ;; -------------------------------------------------------------------------------- 942 943 (set! *mock-random-state* 944 (let* ((mock-random-state? #f) 945 (mock-random-state-class 946 (inlet 'random-state? (with-mock-wrapper #_random-state?) 947 'random-state->list (with-mock-wrapper #_random-state->list) 948 'random (with-mock-wrapper* #_random) 949 'object->string (with-mock-wrapper* #_object->string) 950 'format (with-mock-wrapper* #_format) 951 'write (with-mock-wrapper* #_write) 952 'display (with-mock-wrapper* #_display) 953 ))) 954 955 (define* (mock-random-state seed (carry 1675393560)) 956 (immutable! 957 (openlet 958 (sublet (*mock-random-state* 'mock-random-state-class) 959 'value (#_random-state seed carry) 960 'mock-type 'mock-random-state?)))) 961 962 (set! mock-random-state? 963 (lambda (obj) 964 (and (let? obj) 965 (defined? 'mock-type obj #t) 966 (eq? (obj 'mock-type) 'mock-random-state?)))) 967 968 (curlet))) 969 970 971 ;; -------------------------------------------------------------------------------- 972 973 (set! *mock-iterator* 974 (let* ((mock-iterator? #f) 975 (mock-iterator-class 976 (inlet 'iterator? (with-mock-wrapper #_iterator?) 977 'iterate (with-mock-wrapper #_iterate) 978 'iterator-at-end? (with-mock-wrapper #_iterator-at-end?) 979 'iterator-sequence (with-mock-wrapper #_iterator-sequence) 980 'object->string (with-mock-wrapper* #_object->string) 981 'format (with-mock-wrapper* #_format) 982 'write (with-mock-wrapper* #_write) 983 'display (with-mock-wrapper* #_display) 984 ))) 985 986 (define (make-mock-iterator . args) 987 (immutable! 988 (openlet 989 (sublet (*mock-iterator* 'mock-iterator-class) 990 'value (apply #_make-iterator args) 991 'mock-type 'mock-iterator?)))) 992 993 (set! mock-iterator? 994 (lambda (obj) 995 (and (let? obj) 996 (defined? 'mock-type obj #t) 997 (eq? (obj 'mock-type) 'mock-iterator?)))) 998 999 (curlet))) 1000 1001 1002 ;; -------------------------------------------------------------------------------- 1003 1004 (set! *mock-port* 1005 (let* ((mock-port? #f) 1006 (mock-port-class 1007 (inlet 'input-port? (with-mock-wrapper #_input-port?) 1008 'output-port? (with-mock-wrapper #_output-port?) 1009 'port-closed? (with-mock-wrapper #_port-closed?) 1010 'equivalent? (with-mock-wrapper* #_equivalent?) 1011 ;'append (with-mock-wrapper* #_append) ; ?? (append (open-input-string "asdf")...) is an error 1012 'set-current-output-port (with-mock-wrapper #_set-current-output-port) 1013 'set-current-input-port (with-mock-wrapper #_set-current-input-port) 1014 'set-current-error-port (with-mock-wrapper #_set-current-error-port) 1015 'close-input-port (with-mock-wrapper #_close-input-port) 1016 'close-output-port (with-mock-wrapper #_close-output-port) 1017 'flush-output-port (with-mock-wrapper* #_flush-output-port) 1018 'get-output-string (with-mock-wrapper* #_get-output-string) 1019 'newline (with-mock-wrapper* #_newline) 1020 'read-char (with-mock-wrapper* #_read-char) 1021 'peek-char (with-mock-wrapper* #_peek-char) 1022 'read-byte (with-mock-wrapper* #_read-byte) 1023 'read-line (with-mock-wrapper* #_read-line) 1024 'read (with-mock-wrapper* #_read) 1025 'char-ready? (with-mock-wrapper* #_char-ready?) 1026 'port-line-number (with-mock-wrapper* #_port-line-number) 1027 'port-filename (with-mock-wrapper* #_port-filename) 1028 'object->string (with-mock-wrapper* #_object->string) 1029 'display (with-mock-wrapper* #_display) 1030 'write (with-mock-wrapper* #_write) 1031 'format (with-mock-wrapper* #_format) 1032 'write-char (with-mock-wrapper* #_write-char) 1033 'write-string (with-mock-wrapper* #_write-string) 1034 'write-byte (with-mock-wrapper* #_write-byte) 1035 'read-string (with-mock-wrapper* #_read-string) 1036 'class-name '*mock-port* 1037 ))) 1038 1039 (define (mock-port port) 1040 (if (and (or (input-port? port) 1041 (output-port? port)) 1042 (not (let? port))) 1043 (openlet 1044 (sublet (*mock-port* 'mock-port-class) 1045 'value port 1046 'mock-type 'mock-port?)) 1047 (error 'wrong-type-arg "mock-port ~S is not a port" port))) 1048 1049 (set! mock-port? (lambda (obj) 1050 (and (let? obj) 1051 (defined? 'mock-type obj #t) 1052 (eq? (obj 'mock-type) 'mock-port?)))) 1053 1054 (curlet))) 1055 1056 ;; sublet of any of these needs to include the value field or a let-ref-fallback 1057 1058#| 1059 (require libc.scm) 1060 1061 (define *input-file* 1062 (let ((file-write-date (lambda (file) 1063 (with-let (sublet *libc* :file file) 1064 (let ((buf (stat.make))) 1065 (stat file buf) 1066 (let ((date (stat.st_mtime buf))) 1067 (free buf) 1068 date))))) 1069 (file-size (lambda (file) 1070 (with-let (sublet *libc* :file file) 1071 (let ((buf (stat.make))) 1072 (stat file buf) 1073 (let ((size (stat.st_size buf))) 1074 (free buf) 1075 size))))) 1076 (file-owner (lambda (file) 1077 (with-let (sublet *libc* :file file) 1078 (let ((buf (stat.make))) 1079 (stat file buf) 1080 (let ((uid (stat.st_uid buf))) 1081 (free buf) 1082 (let ((pwd (getpwuid uid))) 1083 (passwd.pw_name pwd)))))))) 1084 (openlet 1085 (sublet (*mock-port* 'mock-port-class) 1086 'value #f 1087 'mock-type 'mock-port? 1088 'length (lambda (obj) (file-size (obj 'file-name))) 1089 'owner (lambda (obj) (file-owner (obj 'file-name))) 1090 'write-date (lambda (obj) (file-write-date (obj 'file-name))))))) 1091 1092 (define (open-a-file file) 1093 (let ((p (openlet 1094 (sublet *input-file* 1095 'file-name file)))) 1096 (set! (p 'value) (open-input-file file)) 1097 p)) 1098 1099 (define p (open-a-file "oboe.snd")) 1100 (length p) -> 101684 1101 ((p 'owner) p) -> "bil" 1102|# 1103 1104 #f) ; end of outer let 1105