;;; mockery.scm
;;;
;;; s7.html says that this file implements "openlets masquerading as various data
;;; types". The original idea was to test the generic function support in s7 by
;;; creating objects that act as if they were (say) vectors or strings. Each such
;;; object is a let (openlet) inheriting its methods (functions like vector-length)
;;; from the outer let (mock-vector-class etc), and within the object itself there
;;; are a 'value field and a 'mock-type field. Each class (a let) has an associated
;;; make function (make-mock-vector or mock-vector etc). The class functions give
;;; you an object that acts everywhere in scheme like (say) a vector, but you can
;;; specialize it by either adding more functions, or changing the ones given, or
;;; adding other fields to carry around arbitrary information with the object.
;;;
;;; To make a mock-vector call (*mock-vector* 'make-mock-vector) or
;;; (*mock-vector* 'mock-vector):
;;;
;;; ((*mock-vector* 'mock-vector) 1 2 3) -> #(1 2 3)
;;;
;;; This prints as #(1 2 3) but it's actually one of these mock objects:
;;;
;;; (let? ((*mock-vector* 'mock-vector) 1 2 3)) -> #t
;;;
;;; There are examples scattered around this file, and a lot more
;;; in s7test.scm.
;;;
;;; currently it is possible to (set! ((*mock-vector* 'mock-vector-class) 'write) hash-table-set!) [or (set! (v 'write) hash-table-set!) I think]
;;; should we call the s7.html vars-immutable (and immutable!) on this internal let?
;;; to create an immutable mock datum, call immutable! on its value:
;;; (define-constant L (let ((tmp ((*mock-pair* 'mock-pair) 1 2))) (immutable! (tmp 'value)) tmp))
;;;
;;; also we omit a variety of built-in functions that can work on the underlying value.
;;; given (define v #(0 1)) and (define mv ((*mock-vector* 'mock-vector) 0 1))
;;; (arity v): '(1 . 536870912), (arity mv): '(1 . 1)
;;; (signature v): '(#t vector? . #1=(integer? . #1#)), (signature mv): '(#t let? . #1=(symbol? . #1#))
;;; object->let but this needs to be omitted for debugging
;;; and many where the error message is different (should pretty-print know about these?)
(provide 'mockery.scm)
;;; the exported mock data classes
(define *mock-vector* #f)
(define *mock-pair* #f)
(define *mock-string* #f)
(define *mock-hash-table* #f)
(define *mock-symbol* #f)
(define *mock-c-pointer* #f)
(define *mock-random-state* #f)
(define *mock-char* #f)
(define *mock-number* #f)
(define *mock-iterator* #f)
(define *mock-port* #f)
(let () ; rest of file is in this let
(define (->value obj)
(if (and (let? obj)
(symbol? (obj 'mock-type)))
(obj 'value)
obj))
(define (mock? obj)
(and (let? obj)
(symbol? (obj 'mock-type))))
(define (with-mock-wrapper func)
(lambda (obj)
(cond ((mock? obj)
(let-temporarily (((*s7* 'openlets) #f))
(func (let-ref obj 'value))))
((not (openlet? obj))
(func obj))
((procedure? obj) ; TODO: and c-pointer? c-object?
(let-temporarily (((*s7* 'openlets) #f))
(func obj)))
(else
(let ((func-name (string->symbol (object->string func))))
(if (procedure? (obj func-name))
((obj func-name) obj)
(func obj)))))))
(define (with-mock-wrapper* func)
(lambda args
;(format *stderr* "with-mock-wrapper ~S~%" args)
(let ((unknown-openlets #f)
(new-args ())
(got-mock #f))
(for-each (lambda (arg) ; not map here because (values) should not be ignored: (+ (mock-number 4/3) (values))
(set! new-args
(cons (if (mock? arg)
(begin
(set! got-mock #t)
(arg 'value))
(begin
(if (and (openlet? arg)
(not (procedure? arg))
(not (macro? arg))
(not (c-pointer? arg)))
(set! unknown-openlets #t))
arg))
new-args)))
args)
(if (and unknown-openlets got-mock)
(apply func (reverse! new-args))
(let-temporarily (((*s7* 'openlets) #f))
(apply func (reverse! new-args)))))))
(define (append-wrapper . args)
;; append is odd -- if 0 args -> (), 1 arg -> arg, 2 args and first is (), return arg2(etc), else (apply #_append args-via-values)?
;; we can get here with 0 args via: (with-let (*mock-vector* 'mock-vector-class) (append)) !
(if (null? args)
()
(if (null? (cdr args))
(car args) ; presumably a mock object
(if (and (null? (car args)) ; etc...
(null? (cddr args)))
(cadr args)
(apply (with-mock-wrapper* #_append) args)))))
;; one tricky thing here is that a mock object can be the let of with-let: (with-let (mock-port ...) ...)
;; so a mock object's method can be called even when no argument is a mock object. Even trickier
;; (display (openlet (with-let (mock-c-pointer 0) (lambda () 1))))
;; --------------------------------------------------------------------------------
(set! *mock-vector*
(let* ((mock-vector? #f)
(mock-vector-class
(inlet 'local-set! (lambda (obj i val) ; reactive-vector uses this as a hook into vector-set!
(if (mock-vector? i)
(error 'wrong-type-arg "stray mock-vector? ~S" i))
(#_vector-set! (->value obj) i val))
'vector-set! (lambda (obj i val) ((let-ref obj 'local-set!) obj i val) val)
'let-set-fallback (lambda (obj i val)
(if (and (integer? i)
(defined? 'value obj))
(begin
((let-ref obj 'local-set!) obj i val)
val)
(error 'out-of-range "unknown field: ~S" i)))
'let-ref-fallback (lambda (obj i)
(if (and (integer? i)
(defined? 'value obj))
(#_vector-ref (obj 'value) i) ; the implicit case
(error 'out-of-range "unknown field: ~S" i)))
'equivalent? (with-mock-wrapper* #_equivalent?)
'vector-ref (with-mock-wrapper* #_vector-ref)
'vector-length (if (provided? 'pure-s7)
(lambda (vect)
(if (vector? vect)
(length vect)
(error 'wrong-type-arg "vector-length argument should be a vector: ~A" vect)))
(with-mock-wrapper #_vector-length))
'reverse (with-mock-wrapper #_reverse)
'sort! (with-mock-wrapper* #_sort!)
'make-iterator (with-mock-wrapper #_make-iterator)
'arity (with-mock-wrapper #_arity)
'object->string (with-mock-wrapper* #_object->string)
'format (with-mock-wrapper* #_format)
'write (with-mock-wrapper* #_write)
'display (with-mock-wrapper* #_display)
'vector-dimension (with-mock-wrapper #_vector-dimension)
'vector-dimensions (with-mock-wrapper #_vector-dimensions)
'vector-rank (with-mock-wrapper #_vector-rank)
'fill! (with-mock-wrapper* #_fill!)
'vector-fill! (with-mock-wrapper* #_vector-fill!)
'vector->list (with-mock-wrapper* #_vector->list)
'subvector (with-mock-wrapper* #_subvector)
'copy (with-mock-wrapper* #_copy)
'vector? (with-mock-wrapper #_vector?)
'int-vector? (with-mock-wrapper #_int-vector?)
'byte-vector? (with-mock-wrapper #_byte-vector?)
'float-vector? (with-mock-wrapper #_float-vector?)
'complex-vector? (with-mock-wrapper #_complex-vector?)
'length (with-mock-wrapper #_length)
'vector-append (if (provided? 'pure-s7)
(lambda args
(if (null? args)
#()
(if (vector? (car args))
(apply append args)
(error 'wrong-type-arg "vector-append arguments should be vectors: ~A" args))))
(with-mock-wrapper* #_vector-append))
'append append-wrapper ;(with-mock-vector #_append)
'vector-typer (with-mock-wrapper #_vector-typer)
'class-name '*mock-vector*)))
(define (make-mock-vector len . rest)
(openlet
(sublet mock-vector-class
'value (apply #_make-vector len rest)
'mock-type 'mock-vector?)))
(define (mock-vector . args)
(openlet
(sublet mock-vector-class
'value (apply #_vector args)
'mock-type 'mock-vector?)))
(set! mock-vector? (lambda (obj)
(and (let? obj)
(defined? 'mock-type obj #t)
(eq? (obj 'mock-type) 'mock-vector?))))
(curlet)))
;;; perhaps mock-float-vector etc?
#|
;; vector that grows to accommodate vector-set!
(define (stretchable-vector)
(let ((local-ref (lambda (obj index)
(if (>= index (length (obj 'value)))
(obj 'initial-element)
(#_vector-ref (obj 'value) index))))
(local-set! (lambda (obj index val)
(if (>= index (length (obj 'value)))
(set! (obj 'value) (copy (obj 'value) (make-vector (+ index 8) (obj 'initial-element)))))
(#_vector-set! (obj 'value) index val))))
(openlet
(sublet (*mock-vector* 'mock-vector-class)
'value (vector)
'mock-type 'mock-vector?
'initial-element #f
'vector-ref local-ref
'let-ref-fallback local-ref
'vector-set! local-set!
'let-set-fallback local-set!))))
;; vector with data (mimicking Clojure):
(define (meta-vector v data)
(openlet
(sublet (*mock-vector* 'mock-vector-class)
'value v
'mock-type 'mock-vector?
'meta-data data)))
(define v (meta-vector #(0 1 2) "hiho"))
(v 1): 1
(v 'meta-data): "hiho"
v: #(0 1 2)
(vector? v): #t
|#
;; --------------------------------------------------------------------------------
(set! *mock-hash-table*
(let* ((mock-hash-table? #f)
(mock-hash-table-class
(inlet 'let-ref-fallback (lambda (obj key)
(if (defined? 'value obj)
(#_hash-table-ref (obj 'value) key)))
'let-set-fallback (lambda (obj key val)
(if (defined? 'value obj)
(#_hash-table-set! (obj 'value) key val)))
;; the fallbacks are needed because hash-tables and lets use exactly the same syntax in implicit indexing:
;; (x 'y) but s7 can't tell that in this one case, we actually want the 'y to be a key not a field.
;; So, to avoid infinite recursion in let-ref (implicit index), if let-ref can't find the let field,
;; and the let has 'let-ref|set!-fallback, let-ref|set! passes the argument to that function rather than
;; return #.
;;
;; (round (openlet (inlet 'round (lambda (obj) (#_round (obj 'value))) 'let-ref-fallback (lambda args 3)))) -> 3
'hash-table-ref (with-mock-wrapper* #_hash-table-ref)
'hash-table-set! (with-mock-wrapper* #_hash-table-set!)
'equivalent? (with-mock-wrapper* #_equivalent?)
'hash-table-entries (with-mock-wrapper #_hash-table-entries)
'make-iterator (with-mock-wrapper #_make-iterator)
'fill! (with-mock-wrapper* #_fill!)
'object->string (with-mock-wrapper* #_object->string)
'format (with-mock-wrapper* #_format)
'write (with-mock-wrapper* #_write)
'display (with-mock-wrapper* #_display)
'reverse (with-mock-wrapper #_reverse)
'arity (with-mock-wrapper #_arity)
'copy (with-mock-wrapper* #_copy)
'hash-table? (with-mock-wrapper #_hash-table?)
'length (with-mock-wrapper #_length)
'append append-wrapper ;(with-mock-wrapper* #_append)
'hash-table-key-typer (with-mock-wrapper #_hash-table-key-typer)
'hash-table-value-typer (with-mock-wrapper #_hash-table-value-typer)
'class-name '*mock-hash-table*)))
(define (make-mock-hash-table . rest)
(openlet
(sublet mock-hash-table-class
'value (apply #_make-hash-table rest)
'mock-type 'mock-hash-table?)))
(define (mock-hash-table . args)
(openlet
(sublet mock-hash-table-class
'value (apply #_hash-table args)
'mock-type 'mock-hash-table?)))
(set! mock-hash-table? (lambda (obj)
(and (let? obj)
(defined? 'mock-type obj #t)
(eq? (obj 'mock-type) 'mock-hash-table?))))
(curlet)))
#|
;; hash-table that returns a special identifier when key is not in the table
(define (gloomy-hash-table)
(openlet
(sublet (*mock-hash-table* 'mock-hash-table-class) ; ideally this would be a separate (not copied) gloomy-hash-table-class
'value #f
'mock-type 'mock-hash-table?
'false (gensym)
'not-a-key #f
'hash-table-ref (lambda (obj key)
(let ((val (#_hash-table-ref (obj 'value) key)))
(if (eq? val (obj 'false))
#f
(or val (obj 'not-a-key)))))
'hash-table-key? (lambda (obj key)
(#_hash-table-ref (obj 'value) key)))))
(define (hash-table-key? obj key)
((let-ref obj 'hash-table-key?) obj key))
(define* (make-gloomy-hash-table (len 511) not-a-key)
(let ((ht (gloomy-hash-table)))
(set! (ht 'value) (make-hash-table len))
(set! (ht 'not-a-key) not-a-key)
ht))
|#
;; --------------------------------------------------------------------------------
(set! *mock-string*
(let* ((mock-string? #f)
(mock-string-class
(inlet 'equivalent? (with-mock-wrapper* #_equivalent?)
'reverse (with-mock-wrapper #_reverse)
'arity (with-mock-wrapper #_arity)
'make-iterator (with-mock-wrapper* #_make-iterator)
'let-ref-fallback (lambda (obj i)
(if (and (integer? i)
(defined? 'value obj))
(#_string-ref (obj 'value) i) ; these are the implicit cases
(error 'out-of-range "unknown field: ~S" i)))
'let-set-fallback (lambda (obj i val)
(if (and (integer? i)
(defined? 'value obj))
(#_string-set! (obj 'value) i val)
(error 'out-of-range "unknown field: ~S" i)))
'string-length (if (provided? 'pure-s7)
(lambda (str)
(if (string? str)
(length str)
(error 'wrong-type-arg "string-length argument should be a string: ~A" str)))
(with-mock-wrapper #_length))
'string-append (with-mock-wrapper* #_string-append)
'string-copy (with-mock-wrapper* #_string-copy)
'string=? (with-mock-wrapper* #_string=?)
'string? (with-mock-wrapper* #_string>?)
'string<=? (with-mock-wrapper* #_string<=?)
'string>=? (with-mock-wrapper* #_string>=?)
'string-downcase (with-mock-wrapper #_string-downcase)
'string-upcase (with-mock-wrapper #_string-upcase)
'string->symbol (with-mock-wrapper #_string->symbol)
'symbol (with-mock-wrapper* #_symbol)
'string->keyword (with-mock-wrapper #_string->keyword)
'open-input-string (with-mock-wrapper #_open-input-string)
'directory? (with-mock-wrapper #_directory?)
'file-exists? (with-mock-wrapper #_file-exists?)
'getenv (with-mock-wrapper #_getenv)
'delete-file (with-mock-wrapper #_delete-file)
'string->byte-vector (with-mock-wrapper #_string->byte-vector)
'object->string (with-mock-wrapper* #_object->string)
'format (with-mock-wrapper* #_format)
'write (with-mock-wrapper* #_write)
'display (with-mock-wrapper* #_display)
'char-position (with-mock-wrapper* #_char-position)
'string-fill! (with-mock-wrapper* #_string-fill!)
'gensym (with-mock-wrapper* #_gensym)
'call-with-input-string (with-mock-wrapper* #_call-with-input-string)
'with-input-from-string (with-mock-wrapper* #_with-input-from-string)
'system (with-mock-wrapper* #_system)
'load (with-mock-wrapper* #_load)
'eval-string (with-mock-wrapper* #_eval-string)
'string->list (with-mock-wrapper* #_string->list)
'bignum (with-mock-wrapper* #_bignum)
'fill! (with-mock-wrapper* #_fill!)
'write-string (with-mock-wrapper* #_write-string)
'copy (with-mock-wrapper* #_copy)
'substring (with-mock-wrapper* #_substring)
'string->number (with-mock-wrapper* #_string->number)
'string-position (with-mock-wrapper* #_string-position)
'string-ref (with-mock-wrapper* #_string-ref)
'string-set! (with-mock-wrapper* #_string-set!)
'string-ci=? (with-mock-wrapper* #_string-ci=?)
'string-ci? (with-mock-wrapper* #_string-ci>?)
'string-ci<=? (with-mock-wrapper* #_string-ci<=?)
'string-ci>=? (with-mock-wrapper* #_string-ci>=?)
'string? (with-mock-wrapper #_string?)
'length (with-mock-wrapper (if (provided? 'pure-s7) #_length #_string-length))
'append append-wrapper ;(with-mock-wrapper* #_append)
'class-name '*mock-string*)))
(define* (make-mock-string len (init #\null))
(openlet
(sublet mock-string-class
'value (#_make-string len init)
'mock-type 'mock-string?)))
(define (mock-string . args)
(let ((v (make-mock-string 0)))
(set! (v 'value)
(if (string? (car args))
(car args)
(apply #_string args)))
v))
(set! mock-string? (lambda (obj)
(and (let? obj)
(defined? 'mock-type obj #t)
(eq? (obj 'mock-type) 'mock-string?))))
(curlet)))
#|
;; string that is always the current time of day
(require libc.scm)
(define time-string
(let ((daytime (lambda args
(with-let (sublet *libc*)
(let ((timestr (make-string 64)))
(let ((len (strftime timestr 64 "%a %d-%b-%Y %H:%M %Z"
(localtime
(time.make (time (c-pointer 0)))))))
(substring timestr 0 len)))))))
(openlet
(sublet (*mock-string* 'mock-string-class) ; the mock-string isn't really needed here
'let-ref-fallback daytime
'object->string daytime))))
;; similarly ("JIT data"):
(define ? (openlet
(inlet 'object->string (lambda (obj . args)
(apply #_object->string (owlet) args)))))
|#
;; --------------------------------------------------------------------------------
(set! *mock-char*
(let* ((mock-char? #f)
(mock-char-class
(inlet 'equivalent? (with-mock-wrapper* #_equivalent?)
'char-upcase (with-mock-wrapper #_char-upcase)
'char-downcase (with-mock-wrapper #_char-downcase)
'char->integer (with-mock-wrapper #_char->integer)
'char-upper-case? (with-mock-wrapper #_char-upper-case?)
'char-lower-case? (with-mock-wrapper #_char-lower-case?)
'char-alphabetic? (with-mock-wrapper #_char-alphabetic?)
'char-numeric? (with-mock-wrapper #_char-numeric?)
'char-whitespace? (with-mock-wrapper #_char-whitespace?)
'char=? (with-mock-wrapper* #_char=?)
'char? (with-mock-wrapper* #_char>?)
'char<=? (with-mock-wrapper* #_char<=?)
'char>=? (with-mock-wrapper* #_char>=?)
'char-ci=? (with-mock-wrapper* #_char-ci=?)
'char-ci? (with-mock-wrapper* #_char-ci>?)
'char-ci<=? (with-mock-wrapper* #_char-ci<=?)
'char-ci>=? (with-mock-wrapper* #_char-ci>=?)
'string (with-mock-wrapper* #_string)
'string-fill! (with-mock-wrapper* #_string-fill!)
'fill! (with-mock-wrapper* #_fill!)
'object->string (with-mock-wrapper* #_object->string)
'format (with-mock-wrapper* #_format)
'write (with-mock-wrapper* #_write)
'display (with-mock-wrapper* #_display)
'arity (with-mock-wrapper #_arity)
'make-string (with-mock-wrapper* #_make-string)
'char-position (with-mock-wrapper* #_char-position)
'write-char (with-mock-wrapper* #_write-char)
'string-set! (with-mock-wrapper* #_string-set!)
'copy (with-mock-wrapper* #_copy)
'char? (with-mock-wrapper #_char?)
'class-name '*mock-char*
'length (lambda (obj) #f))))
(define (mock-char c)
(if (and (char? c)
(not (let? c)))
(immutable!
(openlet
(sublet (*mock-char* 'mock-char-class)
'value c
'mock-type 'mock-char?)))
(error 'wrong-type-arg "mock-char argument ~S is not a char" c)))
(set! mock-char? (lambda (obj)
(and (let? obj)
(defined? 'mock-type obj #t)
(eq? (obj 'mock-type) 'mock-char?))))
(curlet)))
;; eventually I'll conjure up unichars like (define lambda (byte-vector #xce #xbb)) via mock-char,
;; then combine those into unistring via mock-string
;;
;; (string-length obj)->g_utf8_strlen etc
;; (g_unichar_isalpha (g_utf8_get_char (byte-vector #xce #xbb))) -> #t
;; (g_utf8_strlen (byte-vector #xce #xbb #xce #xba) 10) -> 2
;; (g_utf8_normalize (byte-vector #xce #xbb #xce #xba) 4 G_NORMALIZE_DEFAULT)
;; but the ones that return gunichar (toupper) currently don't return a byte-vector or a string
;; maybe gunichar->byte-vector?
;; need glib.scm, or unicode.scm to load the stuff
;; --------------------------------------------------------------------------------
(set! *mock-number*
(let* ((mock-number? #f)
(mock-number-class
(inlet
'equivalent? (with-mock-wrapper* #_equivalent?)
'arity (with-mock-wrapper #_arity)
'real-part (with-mock-wrapper #_real-part)
'imag-part (with-mock-wrapper #_imag-part)
'numerator (with-mock-wrapper #_numerator)
'denominator (with-mock-wrapper #_denominator)
'even? (with-mock-wrapper #_even?)
'odd? (with-mock-wrapper #_odd?)
'zero? (with-mock-wrapper #_zero?)
'positive? (with-mock-wrapper #_positive?)
'negative? (with-mock-wrapper #_negative?)
'infinite? (with-mock-wrapper #_infinite?)
'nan? (with-mock-wrapper #_nan?)
;'append append-wrapper ; (with-mock-wrapper* #_append) ;?? (append ... 3 ...) is an error
'magnitude (with-mock-wrapper #_magnitude)
'angle (with-mock-wrapper #_angle)
'rationalize (with-mock-wrapper* #_rationalize)
'abs (with-mock-wrapper #_abs)
'exp (with-mock-wrapper #_exp)
'log (with-mock-wrapper* #_log)
'sin (with-mock-wrapper #_sin)
'cos (with-mock-wrapper #_cos)
'tan (with-mock-wrapper #_tan)
'asin (with-mock-wrapper #_asin)
'acos (with-mock-wrapper #_acos)
'atan (with-mock-wrapper* #_atan)
'sinh (with-mock-wrapper #_sinh)
'cosh (with-mock-wrapper #_cosh)
'tanh (with-mock-wrapper #_tanh)
'asinh (with-mock-wrapper #_asinh)
'acosh (with-mock-wrapper #_acosh)
'atanh (with-mock-wrapper #_atanh)
'sqrt (with-mock-wrapper #_sqrt)
'expt (with-mock-wrapper* #_expt)
'floor (with-mock-wrapper #_floor)
'ceiling (with-mock-wrapper #_ceiling)
'truncate (with-mock-wrapper #_truncate)
'round (with-mock-wrapper #_round)
'integer->char (with-mock-wrapper #_integer->char)
'inexact->exact (with-mock-wrapper #_inexact->exact)
'exact->inexact (with-mock-wrapper #_exact->inexact)
'integer-length (with-mock-wrapper #_integer-length)
'integer-decode-float (with-mock-wrapper #_integer-decode-float)
'number? (with-mock-wrapper #_number?)
'integer? (with-mock-wrapper #_integer?)
'real? (with-mock-wrapper #_real?)
'complex? (with-mock-wrapper #_complex?)
'rational? (with-mock-wrapper #_rational?)
'byte? (with-mock-wrapper #_byte?)
'float? (with-mock-wrapper #_float?)
'exact? (with-mock-wrapper #_exact?)
'inexact? (with-mock-wrapper #_inexact?)
'lognot (with-mock-wrapper #_lognot)
'logior (with-mock-wrapper* #_logior)
'logxor (with-mock-wrapper* #_logxor)
'logand (with-mock-wrapper* #_logand)
'number->string (with-mock-wrapper* #_number->string)
'lcm (with-mock-wrapper* #_lcm)
'gcd (with-mock-wrapper* #_gcd)
'+ (with-mock-wrapper* #_+)
'- (with-mock-wrapper* #_-)
'* (with-mock-wrapper* #_*)
'/ (with-mock-wrapper* #_/)
'max (with-mock-wrapper* #_max)
'min (with-mock-wrapper* #_min)
'= (with-mock-wrapper* #_=)
'< (with-mock-wrapper* #_<)
'> (with-mock-wrapper* #_>)
'<= (with-mock-wrapper* #_<=)
'>= (with-mock-wrapper* #_>=)
'make-polar (if (provided? 'pure-s7)
(lambda (mag ang) (#_complex (* mag (cos ang)) (* mag (sin ang))))
(lambda (mag ang) (#_make-polar (->value mag) (->value ang))))
'make-rectangular (with-mock-wrapper* #_complex)
'complex (with-mock-wrapper* #_complex)
'bignum (with-mock-wrapper* #_bignum)
'random-state (with-mock-wrapper* #_random-state)
'ash (with-mock-wrapper* #_ash)
'logbit? (with-mock-wrapper* #_logbit?)
'quotient (with-mock-wrapper* #_quotient)
'remainder (with-mock-wrapper* #_remainder)
'modulo (with-mock-wrapper* #_modulo)
'random (with-mock-wrapper* #_random)
'write-byte (with-mock-wrapper* #_write-byte)
'make-list (with-mock-wrapper* #_make-list)
'make-vector (with-mock-wrapper* #_make-vector)
'make-complex-vector (with-mock-wrapper* #_make-complex-vector)
'make-float-vector (with-mock-wrapper* #_make-float-vector)
'make-int-vector (with-mock-wrapper* #_make-int-vector)
'make-byte-vector (with-mock-wrapper* #_make-byte-vector)
'make-hash-table (with-mock-wrapper* #_make-hash-table)
'object->string (with-mock-wrapper* #_object->string)
'format (with-mock-wrapper* #_format)
'write (with-mock-wrapper* #_write)
'display (with-mock-wrapper* #_display)
'string-fill! (with-mock-wrapper* #_string-fill!)
'copy (with-mock-wrapper* #_copy)
'vector->list (with-mock-wrapper* #_vector->list)
'string->list (with-mock-wrapper* #_string->list)
'substring (with-mock-wrapper* #_substring)
'vector-fill! (with-mock-wrapper* #_vector-fill!)
'fill! (with-mock-wrapper* #_fill!)
'make-string (with-mock-wrapper* #_make-string)
'string-ref (with-mock-wrapper* #_string-ref)
'string-set! (with-mock-wrapper* #_string-set!)
'string->number (with-mock-wrapper* #_string->number)
'list-ref (with-mock-wrapper* #_list-ref)
'list-set! (with-mock-wrapper* #_list-set!)
'list-tail (with-mock-wrapper* #_list-tail)
'vector-ref (with-mock-wrapper* #_vector-ref)
'complex-vector-ref (with-mock-wrapper* #_complex-vector-ref)
'float-vector-ref (with-mock-wrapper* #_float-vector-ref)
'int-vector-ref (with-mock-wrapper* #_int-vector-ref)
'byte-vector-ref (with-mock-wrapper* #_byte-vector-ref)
'vector-set! (with-mock-wrapper* #_vector-set!)
'complex-vector-set! (with-mock-wrapper* #_complex-vector-set!)
'float-vector-set! (with-mock-wrapper* #_float-vector-set!)
'int-vector-set! (with-mock-wrapper* #_int-vector-set!)
'byte-vector-set! (with-mock-wrapper* #_byte-vector-set!)
'complex-vector (with-mock-wrapper* #_complex-vector)
'float-vector (with-mock-wrapper* #_float-vector)
'int-vector (with-mock-wrapper* #_int-vector)
'byte-vector (with-mock-wrapper* #_byte-vector)
'subvector (with-mock-wrapper* #_subvector)
'read-string (with-mock-wrapper* #_read-string)
'length (with-mock-wrapper #_length)
'c-pointer (with-mock-wrapper #_c-pointer)
'class-name '*mock-number*)))
(define (mock-number x)
(if (and (number? x)
(not (let? x)))
(immutable!
(openlet
(sublet (*mock-number* 'mock-number-class)
'value x
'mock-type 'mock-number?)))
(error 'wrong-type-arg "mock-number ~S is not a number" x)))
(set! mock-number? (lambda (obj)
(and (let? obj)
(defined? 'mock-type obj #t)
(eq? (obj 'mock-type) 'mock-number?))))
(curlet)))
#|
;; fuzzy number
(define fuzzy-number
(let ((fuzz (lambda (fx)
(#_* fx (#_- 1.05 (#_random .1))))))
(lambda (fx)
(openlet
(sublet
(*mock-number* 'mock-number-class)
'let-ref-fallback (lambda (obj sym) (fuzz fx))
'object->string (lambda (obj . args) (#_number->string (fuzz fx))))))))
;; interval arithmetic
;;
;; from Wikipedia:
;; x + y = [a+c, b+d]
;; x - y = [a-d, b-c]
;; x / y = [min(a/c, a/d, b/c, b/d), max(a/c, a/d, b/c, b/d)]
(define *interval*
(let* ((make-interval #f)
(low (lambda (z) (z 'low)))
(high (lambda (z) (z 'high)))
(interval-class
(openlet (sublet (*mock-number* 'mock-number-class)
'+ (lambda args
(let ((lo 0)
(hi 0))
(for-each
(lambda (z)
(if (let? z)
(begin
(set! lo (+ lo (low z)))
(set! hi (+ hi (high z))))
(begin
(set! lo (+ lo z))
(set! hi (+ hi z)))))
args)
(make-interval lo hi)))
'* (lambda args
(let ((lo 1)
(hi 1))
(for-each
(lambda (z)
(let ((zlo (if (let? z) (low z) z))
(zhi (if (let? z) (high z) z)))
(let ((ac (* lo zlo))
(ad (* lo zhi))
(bc (* hi zlo))
(bd (* hi zhi)))
(set! lo (min ac ad bc bd))
(set! hi (max ac ad bc bd)))))
args)
(make-interval lo hi)))
'- (lambda args
(let ((z (car args)))
(if (null? (cdr args)) ; negate (must be let? else how did we get here?)
(make-interval (- (high z)) (- (low z)))
(let ((lo (low z))
(hi (high z)))
(for-each
(lambda (z)
(if (let? z)
(begin
(set! lo (- lo (high z)))
(set! hi (- hi (low z))))
(begin
(set! lo (- lo z))
(set! hi (- hi z)))))
(cdr args))
(make-interval lo hi)))))
'/ (lambda args
(let ((z (car args)))
(if (null? (cdr args)) ; invert
(make-interval (/ (high z)) (/ (low z)))
(let ((lo (low z))
(hi (high z)))
(for-each
(lambda (z)
(let ((zlo (if (let? z) (low z) z))
(zhi (if (let? z) (high z) z)))
(let ((ac (/ lo zlo))
(ad (/ lo zhi))
(bc (/ hi zlo))
(bd (/ hi zhi)))
(set! lo (min ac ad bc bd))
(set! hi (max ac ad bc bd)))))
(cdr args))
(make-interval lo hi)))))
'abs (lambda (z)
(if (positive? (low z))
(make-interval (low z) (high z))
(if (negative? (high z))
(make-interval (abs (high z)) (abs (low z)))
(make-interval 0 (max (abs (low z)) (abs (high z)))))))
'object->string (lambda (obj . args)
(format #f "#" (low obj) (high obj)))
))))
(set! make-interval (lambda (low high)
(if (> low high) (format *stderr* "~A ~A~%" low high))
(openlet (sublet interval-class 'low low 'high high))))
(curlet)))
(define x ((*interval* 'make-interval) 3.0 4.0))
|#
;; --------------------------------------------------------------------------------
(set! *mock-pair*
(let* ((mock-pair? #f)
(mock-pair-class
(inlet 'equivalent? (with-mock-wrapper* #_equivalent?)
'pair-line-number (with-mock-wrapper #_pair-line-number)
'list->string (with-mock-wrapper #_list->string)
'object->string (with-mock-wrapper* #_object->string)
'format (with-mock-wrapper* #_format)
'write (with-mock-wrapper* #_write)
'display (with-mock-wrapper* #_display)
'list? (with-mock-wrapper #_list?)
'car (with-mock-wrapper #_car)
'cdr (with-mock-wrapper #_cdr)
'set-car! (with-mock-wrapper* #_set-car!)
'set-cdr! (with-mock-wrapper* #_set-cdr!)
'caar (with-mock-wrapper #_caar)
'cadr (with-mock-wrapper #_cadr)
'cdar (with-mock-wrapper #_cdar)
'cddr (with-mock-wrapper #_cddr)
'caaar (with-mock-wrapper #_caaar)
'caadr (with-mock-wrapper #_caadr)
'cadar (with-mock-wrapper #_cadar)
'cdaar (with-mock-wrapper #_cdaar)
'caddr (with-mock-wrapper #_caddr)
'cdddr (with-mock-wrapper #_cdddr)
'cdadr (with-mock-wrapper #_cdadr)
'cddar (with-mock-wrapper #_cddar)
'caaaar (with-mock-wrapper #_caaaar)
'caaadr (with-mock-wrapper #_caaadr)
'caadar (with-mock-wrapper #_caadar)
'cadaar (with-mock-wrapper #_cadaar)
'caaddr (with-mock-wrapper #_caaddr)
'cadddr (with-mock-wrapper #_cadddr)
'cadadr (with-mock-wrapper #_cadadr)
'caddar (with-mock-wrapper #_caddar)
'cdaaar (with-mock-wrapper #_cdaaar)
'cdaadr (with-mock-wrapper #_cdaadr)
'cdadar (with-mock-wrapper #_cdadar)
'cddaar (with-mock-wrapper #_cddaar)
'cdaddr (with-mock-wrapper #_cdaddr)
'cddddr (with-mock-wrapper #_cddddr)
'cddadr (with-mock-wrapper #_cddadr)
'cdddar (with-mock-wrapper #_cdddar)
'assoc (with-mock-wrapper* #_assoc)
'assq (with-mock-wrapper* #_assq)
'assv (with-mock-wrapper* #_assv)
'member (with-mock-wrapper* #_member)
'memq (with-mock-wrapper* #_memq)
'memv (with-mock-wrapper* #_memv)
'let-ref-fallback (lambda (obj ind)
(if (eq? ind 'value)
#
(if (integer? ind)
(let ((val (begin
(coverlet obj)
(#_list-ref (obj 'value) ind))))
(openlet obj)
val)
(error 'wrong-type-arg "let-ref mock-pair index is not an integer: ~S" ind))))
'let-set-fallback (lambda (obj ind val)
(if (eq? ind 'value)
#
(if (integer? ind)
(let ((val (begin
(coverlet obj)
(#_list-set! (obj 'value) ind val))))
(openlet obj)
val)
(error 'wrong-type-arg "let-set! mock-pair index is not an integer: ~S" ind))))
'reverse! (lambda (obj)
(if (mock-pair? obj)
(set! (obj 'value) (#_reverse (obj 'value)))
(#_reverse! obj)))
'list-tail (with-mock-wrapper* #_list-tail)
'sort! (with-mock-wrapper* #_sort!)
'reverse (with-mock-wrapper #_reverse)
'arity (with-mock-wrapper #_arity)
'make-iterator (with-mock-wrapper #_make-iterator)
'eval (with-mock-wrapper #_eval)
'list->vector (with-mock-wrapper #_list->vector)
'fill! (with-mock-wrapper* #_fill!)
'copy (with-mock-wrapper* #_copy)
'subvector (with-mock-wrapper* #_subvector)
'make-vector (with-mock-wrapper* #_make-vector)
'list-ref (with-mock-wrapper* #_list-ref)
'list-set! (with-mock-wrapper* #_list-set!)
'pair? (with-mock-wrapper #_pair?)
'length (with-mock-wrapper #_length)
'append append-wrapper ;(with-mock-wrapper* #_append)
'class-name '*mock-pair*)))
(define (mock-pair . args)
(openlet
(sublet (*mock-pair* 'mock-pair-class)
'value (copy args) ; i.e. like list not cons
'mock-type 'mock-pair?)))
(set! mock-pair? (lambda (obj)
(and (let? obj)
(defined? 'mock-type obj #t)
(eq? (obj 'mock-type) 'mock-pair?))))
(curlet)))
#|
(let ((immutable-list-class
(sublet (*mock-pair* 'mock-pair-class)
'let-set-fallback (lambda (obj i val)
(set! (obj 'value) (append (copy (obj 'value) (make-list (+ i 1))) (list-tail (obj 'value) (+ i 1))))
(list-set! (obj 'value) i val))
'list-set! (lambda (obj i val)
(set! (obj 'value) (append (copy (obj 'value) (make-list (+ i 1))) (list-tail (obj 'value) (+ i 1))))
(list-set! (obj 'value) i val))
'set-car! (lambda (obj val)
(set! (obj 'value) (cons val (cdr (obj 'value)))))
'set-cdr! (lambda (obj val)
(set! (obj 'value) (cons (car (obj 'value)) val)))
'fill! (lambda (obj val)
(set! (obj 'value) (fill! (copy (obj 'value)) val)))
'reverse! (lambda (obj)
(set! (obj 'value) (reverse (obj 'value))))
'sort! (lambda (obj func)
(set! (obj 'value) (sort! (copy (obj 'value)) func))))))
(define (immutable-list lst)
(openlet
(sublet immutable-list-class
'value lst
'mock-type 'mock-pair?)))
|#
;; since a mock-pair prints itself as if a list, you can get some strange printout results:
;; (cons 'a ((*mock-pair* 'mock-pair) 'b 'c)) -> '(a . (b c))
;; --------------------------------------------------------------------------------
(set! *mock-symbol*
(let* ((mock-symbol? #f)
(mock-symbol-class
(inlet 'equivalent? (with-mock-wrapper* #_equivalent?)
'gensym? (with-mock-wrapper #_gensym?)
;'append (with-mock-wrapper* #_append) ;? (append ... 'a ...) is an error
'fill! (with-mock-wrapper* #_fill!)
'symbol->string (with-mock-wrapper #_symbol->string)
'symbol->value (with-mock-wrapper* #_symbol->value)
'symbol->dynamic-value (with-mock-wrapper #_symbol->dynamic-value)
'setter (with-mock-wrapper* #_setter)
'provided? (with-mock-wrapper #_provided?)
'provide (with-mock-wrapper #_provide)
'defined? (with-mock-wrapper* #_defined?)
'symbol->keyword (with-mock-wrapper #_symbol->keyword)
'keyword? (with-mock-wrapper #_keyword?)
'keyword->symbol (with-mock-wrapper #_keyword->symbol)
'object->string (with-mock-wrapper* #_object->string)
'format (with-mock-wrapper* #_format)
'write (with-mock-wrapper* #_write)
'display (with-mock-wrapper* #_display)
'symbol? (with-mock-wrapper #_symbol?)
'class-name '*mock-symbol*
)))
(define (mock-symbol s)
(if (symbol? s)
(immutable!
(openlet
(sublet (*mock-symbol* 'mock-symbol-class)
'value s
'mock-type 'mock-symbol?)))
(error 'wrong-type-arg "mock-symbol ~S is not a symbol" s)))
(set! mock-symbol? (lambda (obj)
(and (let? obj)
(defined? 'mock-type obj #t)
(eq? (obj 'mock-type) 'mock-symbol?))))
(curlet)))
;; --------------------------------------------------------------------------------
(set! *mock-c-pointer*
(let* ((mock-c-pointer? #f)
(mock-c-pointer-class
(inlet 'c-pointer? (with-mock-wrapper #_c-pointer?)
'c-pointer-type (with-mock-wrapper #_c-pointer-type)
'c-pointer-info (with-mock-wrapper #_c-pointer-info)
'c-pointer-weak1 (with-mock-wrapper #_c-pointer-weak1)
'c-pointer-weak2 (with-mock-wrapper #_c-pointer-weak2)
'c-pointer->list (with-mock-wrapper #_c-pointer->list)
'object->string (with-mock-wrapper* #_object->string)
'format (with-mock-wrapper* #_format)
'write (with-mock-wrapper* #_write)
'display (with-mock-wrapper* #_display)
'fill! (with-mock-wrapper* #_fill!)
'class-name '*mock-c-pointer*
)))
(define* (mock-c-pointer (int 0) type info weak1 weak2)
(immutable!
(openlet
(sublet (*mock-c-pointer* 'mock-c-pointer-class)
'value (#_c-pointer (->value int) (->value type) (->value info) (->value weak1) (->value weak2))
'mock-type 'mock-c-pointer?))))
(set! mock-c-pointer?
(lambda (obj)
(and (let? obj)
(defined? 'mock-type obj #t)
(eq? (obj 'mock-type) 'mock-c-pointer?))))
(curlet)))
;; --------------------------------------------------------------------------------
(set! *mock-random-state*
(let* ((mock-random-state? #f)
(mock-random-state-class
(inlet 'random-state? (with-mock-wrapper #_random-state?)
'random-state->list (with-mock-wrapper #_random-state->list)
'random (with-mock-wrapper* #_random)
'object->string (with-mock-wrapper* #_object->string)
'format (with-mock-wrapper* #_format)
'write (with-mock-wrapper* #_write)
'display (with-mock-wrapper* #_display)
'class-name '*mock-random-state*
)))
(define* (mock-random-state seed (carry 1675393560))
(immutable!
(openlet
(sublet (*mock-random-state* 'mock-random-state-class)
'value (if (provided? 'gmp) (#_random-state seed) (#_random-state seed carry))
'mock-type 'mock-random-state?))))
(set! mock-random-state?
(lambda (obj)
(and (let? obj)
(defined? 'mock-type obj #t)
(eq? (obj 'mock-type) 'mock-random-state?))))
(curlet)))
;; --------------------------------------------------------------------------------
(set! *mock-iterator*
(let* ((mock-iterator? #f)
(mock-iterator-class
(inlet 'iterator? (with-mock-wrapper #_iterator?)
'iterate (with-mock-wrapper #_iterate)
'iterator-at-end? (with-mock-wrapper #_iterator-at-end?)
'iterator-sequence (with-mock-wrapper #_iterator-sequence)
'object->string (with-mock-wrapper* #_object->string)
'format (with-mock-wrapper* #_format)
'write (with-mock-wrapper* #_write)
'display (with-mock-wrapper* #_display)
'class-name '*mock-iterator*
)))
(define (make-mock-iterator . args)
(immutable!
(openlet
(sublet (*mock-iterator* 'mock-iterator-class)
'value (apply #_make-iterator args)
'mock-type 'mock-iterator?))))
(set! mock-iterator?
(lambda (obj)
(and (let? obj)
(defined? 'mock-type obj #t)
(eq? (obj 'mock-type) 'mock-iterator?))))
(curlet)))
;; --------------------------------------------------------------------------------
(set! *mock-port*
(let* ((mock-port? #f)
(mock-port-class
(inlet 'input-port? (with-mock-wrapper #_input-port?)
'output-port? (with-mock-wrapper #_output-port?)
'port-closed? (with-mock-wrapper #_port-closed?)
'equivalent? (with-mock-wrapper* #_equivalent?)
;'append (with-mock-wrapper* #_append) ; ?? (append (open-input-string "asdf") ...) is an error
'set-current-output-port (with-mock-wrapper #_set-current-output-port)
'set-current-input-port (with-mock-wrapper #_set-current-input-port)
'set-current-error-port (with-mock-wrapper #_set-current-error-port)
'close-input-port (with-mock-wrapper #_close-input-port)
'close-output-port (with-mock-wrapper #_close-output-port)
'flush-output-port (with-mock-wrapper* #_flush-output-port)
'get-output-string (with-mock-wrapper* #_get-output-string)
'newline (with-mock-wrapper* #_newline)
'read-char (with-mock-wrapper* #_read-char)
'peek-char (with-mock-wrapper* #_peek-char)
'read-byte (with-mock-wrapper* #_read-byte)
'read-line (with-mock-wrapper* #_read-line)
'read (with-mock-wrapper* #_read)
'char-ready? (with-mock-wrapper* #_char-ready?)
'port-line-number (with-mock-wrapper* #_port-line-number)
'port-filename (with-mock-wrapper* #_port-filename)
'object->string (with-mock-wrapper* #_object->string)
'display (with-mock-wrapper* #_display)
'write (with-mock-wrapper* #_write)
'format (with-mock-wrapper* #_format)
'write-char (with-mock-wrapper* #_write-char)
'write-string (with-mock-wrapper* #_write-string)
'write-byte (with-mock-wrapper* #_write-byte)
'read-string (with-mock-wrapper* #_read-string)
'class-name '*mock-port*
)))
(define (mock-port port)
(if (and (or (input-port? port)
(output-port? port))
(not (let? port)))
(openlet
(sublet (*mock-port* 'mock-port-class)
'value port
'mock-type 'mock-port?))
(error 'wrong-type-arg "mock-port ~S is not a port" port)))
(set! mock-port? (lambda (obj)
(and (let? obj)
(defined? 'mock-type obj #t)
(eq? (obj 'mock-type) 'mock-port?))))
(curlet)))
;; sublet of any of these needs to include the value field or a let-ref-fallback
#|
(require libc.scm)
(define *input-file*
(let ((file-write-date (lambda (file)
(with-let (sublet *libc* :file file)
(let ((buf (stat.make)))
(stat file buf)
(let ((date (stat.st_mtime buf)))
(free buf)
date)))))
(file-size (lambda (file)
(with-let (sublet *libc* :file file)
(let ((buf (stat.make)))
(stat file buf)
(let ((size (stat.st_size buf)))
(free buf)
size)))))
(file-owner (lambda (file)
(with-let (sublet *libc* :file file)
(let ((buf (stat.make)))
(stat file buf)
(let ((uid (stat.st_uid buf)))
(free buf)
(let ((pwd (getpwuid uid)))
(passwd.pw_name pwd))))))))
(openlet
(sublet (*mock-port* 'mock-port-class)
'value #f
'mock-type 'mock-port?
'length (lambda (obj) (file-size (obj 'file-name)))
'owner (lambda (obj) (file-owner (obj 'file-name)))
'write-date (lambda (obj) (file-write-date (obj 'file-name)))))))
(define (open-a-file file)
(let ((p (openlet
(sublet *input-file*
'file-name file))))
(set! (p 'value) (open-input-file file))
p))
(define p (open-a-file "oboe.snd"))
(length p) -> 101684
((p 'owner) p) -> "bil"
|#
#f) ; end of outer let