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