1;;; inspect.ss
2;;; Copyright 1984-2017 Cisco Systems, Inc.
3;;;
4;;; Licensed under the Apache License, Version 2.0 (the "License");
5;;; you may not use this file except in compliance with the License.
6;;; You may obtain a copy of the License at
7;;;
8;;; http://www.apache.org/licenses/LICENSE-2.0
9;;;
10;;; Unless required by applicable law or agreed to in writing, software
11;;; distributed under the License is distributed on an "AS IS" BASIS,
12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13;;; See the License for the specific language governing permissions and
14;;; limitations under the License.
15
16;;; todo
17
18; ---be sensitive to system mode
19; ---argument names for code objects
20; ---nesting level numbers for all variables
21;    (sort variable displays by nesting and position)
22; ---add "loop" variable type
23; ---keep track of loop names?
24; ---information about foreign procedures
25; ---distinguish between user and compiler gensym variables?
26;    (right now both are stripped)
27; ---disassembler
28; ---port info should include file descriptor, perhaps provide access
29;    location in file
30
31(begin
32(let ()
33
34(define-syntax make-dispatch-table
35  (lambda (x)
36    (syntax-case x ()
37      [(_ [key message (ids e1 e2 ...) ...] ...)
38       (and (andmap (lambda (x)
39                      (or (string? x)
40                          (and (pair? x) (string? (car x)) (string? (cdr x)))))
41                    (datum (key ...)))
42            (andmap string? (datum (message ...))))
43       #'`([key message
44                ,(case-lambda
45                   (ids e1 e2 ...)
46                   ...
47                   (l (invalid-command)))]
48           ...)])))
49
50(define-record-type sfile
51  (fields (immutable path) (immutable port) (mutable line) (mutable line-valid?))
52  (nongenerative)
53  (sealed #t))
54
55(define-threaded source-files '())
56
57(define find-source-file
58  (lambda (path line)
59    (define path=?
60     ; trivial definition for now
61      (lambda (p1 p2)
62        (string=? p1 p2)))
63    (let f ((ls source-files))
64      (if (null? ls)
65          (guard (c [#t #f])
66            (let ((line (or line 1)))
67              (set! source-files
68                (cons (make-sfile path (open-input-file path)
69                        line
70                        (= line 1))
71                      source-files)))
72            #t)
73          (if (path=? path (sfile-path (car ls)))
74              (let ((sf (car ls)))
75                (when line
76                  (unless (= line (sfile-line sf))
77                    (sfile-line-valid?-set! sf #f)
78                    (sfile-line-set! sf line)))
79                (set! source-files
80                  (cons sf (remq sf source-files)))
81                #t)
82              (f (cdr ls)))))))
83
84(define open-source-file
85  (case-lambda
86    [(path) (open-source-file path #f)]
87    [(path line)
88     (or (if ($fixed-path? path)
89             (find-source-file path line)
90             (let ([dir* (append (source-directories) (map car (library-directories)))])
91               (let pathloop ([path path])
92                 (let dirloop ([dir* dir*])
93                   (if (null? dir*)
94                       (let ([rest (path-rest path)])
95                         (and (not (string=? rest path))
96                              (pathloop rest)))
97                       (or (find-source-file
98                             (let* ((dir (car dir*)) (n (string-length dir)))
99                               (format (if (and (fx> n 0)
100                                                (directory-separator?
101                                                  (string-ref dir (fx- n 1))))
102                                           "~a~a"
103                                           "~a/~a")
104                                 dir path))
105                             line)
106                           (dirloop (cdr dir*))))))))
107         (inspect-error "Cannot open ~a" path))]))
108
109(define open-recorded-source-file
110  (lambda (object)
111    (call-with-values
112      (lambda () (object 'source-path))
113      (case-lambda
114        [() (inspect-error "Source file unknown.")]
115        [(path pos)
116         (inspect-error
117           "Cannot locate (unmodified) source file ~a.~%Try changing source-directories parameter.~%Source is at character ~s."
118           path pos)]
119        [(path line char)
120         (if (find-source-file path
121               (max (- line (quotient lines-to-list 2)) 1))
122             (show "line ~d, character ~d of ~a" line char path)
123             (inspect-error "Cannot open ~a" path))]))))
124
125(define close-source-file
126  (lambda (sf)
127    (close-input-port (sfile-port sf))))
128
129(define lines-to-list 10)
130
131(module (list-source-file)
132(define base10-length
133  (lambda (n)
134    (cond
135      [(fx< n 10) 1]
136      [(fx< n 100) 2]
137      [(fx< n 1000) 3]
138      [(fx< n 10000) 4]
139      [else (+ 4 (base10-length (quotient n 10000)))])))
140
141(define list-source-file
142  (case-lambda
143    [() (list-source-file #f #f)]
144    [(line) (list-source-file line #f)]
145    [(line count)
146     (when (null? source-files)
147       (inspect-error "No source file open."))
148     (let* ((sf (car source-files))
149            (ip (sfile-port sf)))
150       (when line (require (fixnum? line)))
151       (when count (require (and (fixnum? count) (fx> count 0))))
152       (let* ((line (cond [(not line) (sfile-line sf)]
153                          [(fx> line 0) line]
154                          [else (max (+ (sfile-line sf) line (- lines-to-list))
155                                     1)]))
156              (count (if count
157                         (begin (set! lines-to-list count) count)
158                         lines-to-list)))
159         (let f ((new-line
160                  (if (and (sfile-line-valid? sf) (fx>= line (sfile-line sf)))
161                      (begin
162                        (sfile-line-valid?-set! sf #f)
163                        (sfile-line sf))
164                      (begin
165                        (sfile-line-valid?-set! sf #f)
166                        (file-position ip 0)
167                        1))))
168           (unless (fx= new-line line)
169             (let ((c (read-char ip)))
170               (cond
171                 [(eof-object? c)
172                  (inspect-error "Not that many lines in ~a." (sfile-path sf))]
173                 [(char=? c #\newline) (f (fx+ new-line 1))]
174                 [else (f new-line)]))))
175         (let ((line-chars (base10-length (+ line count -1))))
176           (let f ((line line) (count count))
177             (if (fx= count 0)
178                 (begin
179                   (sfile-line-set! sf line)
180                   (sfile-line-valid?-set! sf #t))
181                 (let ((c (read-char ip)))
182                   (if (eof-object? c)
183                       (fprintf (console-output-port) "*** end of file ***~%")
184                       (begin
185                         (do ((n (base10-length line) (fx+ n 1)))
186                             ((fx= n line-chars))
187                           (write-char #\space (console-output-port)))
188                         (fprintf (console-output-port) "~d: " line)
189                         (do ((c c (read-char ip)))
190                             ((or (eof-object? c) (char=? c #\newline))
191                              (newline (console-output-port)))
192                           (write-char c (console-output-port)))
193                         (f (fx+ line 1) (fx- count 1))))))))))]))
194)
195
196(define (waiter-read)
197  (parameterize ([waiter-prompt-string ""])
198    ((waiter-prompt-and-read) 1)))
199
200(define show
201   (lambda (s . args)
202      (apply fprintf (console-output-port) s args)
203      (newline (console-output-port))))
204
205(define inspect-error
206  (lambda (s . args)
207    (apply show s args)
208    (reset)))
209
210(define invalid-command
211  (lambda ()
212    (inspect-error "Invalid command or argument.  Type ? for options.")))
213
214(define invalid-movement
215  (lambda ()
216    (inspect-error "Invalid movement.")))
217
218(define line-indent "  ")
219
220(define prompt-line-limit 65)
221
222(define display-line-limit 80)
223
224(define descrip-limit 25)
225
226(define-threaded marks)
227
228(define-threaded current-state)
229
230(define-record-type state
231  (fields (immutable object) (immutable level) (immutable position) (immutable link) (mutable find-next))
232  (nongenerative)
233  (sealed #t)
234  (protocol
235    (lambda (new)
236      (case-lambda
237        [(object) (new object 0 #f #f #f)]
238        [(object level position link) (new object level position link #f)]))))
239
240(define object (lambda () (state-object current-state)))
241
242(define level (lambda () (state-level current-state)))
243
244(define position (lambda () (state-position current-state)))
245
246(define type?
247   (lambda (flag x)
248      (eq? (x 'type) flag)))
249
250(define default-mark (void))
251
252(define make-mark
253   (lambda (m)
254      (if (string? m)
255          (string->symbol m)
256          m)))
257
258(define put-mark
259   (lambda (m)
260      (let ([a (eq-hashtable-cell marks m #f)])
261         (set-cdr! a current-state))))
262
263(define get-mark
264   (lambda (m)
265      (eq-hashtable-ref marks m #f)))
266
267(define to-mark
268   (lambda (m)
269      (let ([s (get-mark m)])
270         (unless s (invalid-movement))
271         (put-mark default-mark)
272         (set! current-state s))))
273
274(define down
275   (lambda (x pos)
276      (set! current-state
277          (make-state (if (eq? (x 'type) 'variable) (x 'ref) x)
278                      (+ (level) 1)
279                      pos
280                      current-state))))
281
282(define up
283   (lambda ()
284      (set! current-state (state-link current-state))
285      (unless current-state (invalid-movement))))
286
287(define display-links
288   (lambda (n)
289      (let loop ([i 0] [x (object)])
290         (unless (= i n)
291            (when (type? 'continuation x)
292               (label-line-display x i)
293               (loop (+ i 1) (x 'link)))))))
294
295(define display-refs
296   (lambda (n)
297      (let ([x (object)])
298         (let loop ([i 0])
299            (unless (= i n)
300               (label-line-display (x 'ref i) i)
301               (loop (+ i 1)))))))
302
303(define display-variable-refs
304   (lambda (n)
305      (let ([x (object)])
306         (if ((x 'code) 'info)
307             (let loop ([i 0])
308                (unless (= i n)
309                   (variable-line-display (x 'ref i) i)
310                   (loop (+ i 1))))
311             (display-refs n)))))
312
313(define display-list
314  (lambda (n)
315    (let ((x (object)))
316      (if (or (type? 'pair (x 'cdr))
317              (and (type? 'simple (x 'cdr)) (null? ((x 'cdr) 'value))))
318          (let loop ([i 0] [x x])
319            (if (and (< i n) (type? 'pair x))
320                (begin
321                  (label-line-display (x 'car) i)
322                  (loop (+ i 1) (x 'cdr)))
323                (unless (and (type? 'simple x) (null? (x 'value)))
324                  (name-line-display x "tail"))))
325          (begin
326            (name-line-display (x 'car) "car")
327            (name-line-display (x 'cdr) "cdr"))))))
328
329(define charschemecode
330   (lambda (x)
331      (let ([x (format "~s" x)])
332         (format "~a~a" x (spaces (- 11 (string-length x)))))))
333
334(define unicodehexcode
335  (lambda (x)
336    (format "~6,'0x " (char->integer x))))
337
338(define asciihexcode
339  (lambda (x)
340    (let ([n (char->integer x)])
341      (if (>= n 256)
342          "-- "
343          (format "~2,'0x " n)))))
344
345(define display-chars
346   (lambda (n former no/line)
347      (let ([x (object)])
348         (let loop1 ([i 0])
349            (unless (= i n)
350               (let ([label (format "~a~d: " line-indent i)])
351                  (let loop2 ([j 0] [i i] [strings '()])
352                     (if (or (= j no/line) (= i n))
353                         (begin
354                            (show "~a~a~a"
355                                  label
356                                  (spaces (- 6 (string-length label)))
357                                  (apply string-append (reverse strings)))
358                            (loop1 i))
359                         (loop2 (+ j 1)
360                                (+ i 1)
361                                (cons (former ((x 'ref i) 'value))
362                                      strings))))))))))
363
364(define label-line-display
365   (lambda (x n)
366      (let ([label (format "~a~d: " line-indent n)])
367         (show "~a~a"
368               label
369               (form x (string-length label) display-line-limit)))))
370
371(define name-label-line-display
372   (lambda (x name n)
373      (let ([label (format "~a~d. ~a:" line-indent n name)])
374         (let ([label (format "~a~a"
375                         label
376                         (spaces (- descrip-limit (string-length label))))])
377            (show "~a~a"
378                  label
379                  (form x (string-length label) display-line-limit))))))
380
381(define name-line-display
382   (lambda (x name)
383      (let ([label (format "~a~a:" line-indent name)])
384         (let ([label (format "~a~a"
385                         label
386                         (spaces (- descrip-limit (string-length label))))])
387            (show "~a~a"
388                  label
389                  (form x (string-length label) display-line-limit))))))
390
391(define variable-line-display
392   (lambda (x n)
393      (if (x 'name)
394          (name-label-line-display (x 'ref) (x 'name) n)
395          (label-line-display (x 'ref) n))))
396
397(define ref-list
398   (lambda (n)
399      (unless (and (fixnum? n) (>= n 0)) (invalid-movement))
400      (let ref ([i n] [x (object)])
401         (cond
402            [(not (type? 'pair x)) (invalid-movement)]
403            [(= i 0) (down (x 'car) n)]
404            [else (ref (- i 1) (x 'cdr))]))))
405
406(define ref
407  (lambda (n)
408    (unless (and (fixnum? n) (< -1 n ((object) 'length)))
409      (invalid-movement))
410    (down ((object) 'ref n) n)))
411
412(define set
413  (lambda (n v)
414    (unless (and (fixnum? n) (< -1 n ((object) 'length)))
415      (invalid-movement))
416    (let ([x ((object) 'ref n)])
417      (unless (x 'assignable?)
418        (inspect-error "~s is not assignable" (or (x 'name) 'unnamed)))
419      (x 'set! v))))
420
421(module (variable-ref variable-set)
422  (define get-var-obj
423    (lambda (sym)
424      (let ([n ((object) 'length)])
425        (let loop ([i 0])
426          (if (fx= i n)
427              (invalid-movement)
428              (let ([x ((object) 'ref i)])
429                (if (let ([name (x 'name)])
430                      (and (symbol? name)
431                           (string=?
432                             (symbol->string name)
433                             (symbol->string sym))))
434                    (values x i)
435                    (loop (fx+ i 1)))))))))
436  (define variable-ref
437    (lambda (x)
438      (if (symbol? x)
439          (with-values (get-var-obj x) down)
440          (ref x))))
441  (define variable-set
442    (lambda (x val)
443      (if (symbol? x)
444          (with-values (get-var-obj x)
445            (lambda (var-obj i)
446              (unless (var-obj 'assignable?) (inspect-error "~s is not assignable" x))
447              (var-obj 'set! val)))
448          (set x val)))))
449
450(define move
451   (lambda (n)
452      (require (position))
453      (let ([n (+ n (position))])
454         (up)
455         (case ((object) 'type)
456            [(pair) (ref-list n)]
457            [(continuation procedure vector fxvector bytevector string record
458              ftype-struct ftype-union ftype-array ftype-bits)
459             (ref n)]
460            [else (invalid-movement)]))))
461
462(define require
463   (lambda (x)
464      (unless x (invalid-command))))
465
466(define range-check
467   (case-lambda
468      [(n) (require (and (fixnum? n) (fx<= 0 n)))]
469      [(n max) (require (and (fixnum? n) (fx<= 0 n max)))]
470      [(min n max) (require (and (fixnum? n) (fx<= min n max)))]))
471
472(define display-one-option
473   (lambda (key message)
474      (let ([s (if (pair? key) (format "~a(~a)" (car key) (cdr key)) key)])
475         (show "   ~a ~a ~a"
476               s
477               (make-string (max (- 20 (string-length s)) 0) #\.)
478               message))))
479
480(define display-options
481   (lambda (table generic?)
482      (show "")
483      (for-each display-one-option (map car table) (map cadr table))
484      (unless generic? (display-one-option "??" "display more options"))
485      (show "")))
486
487(define select-dispatch-table
488   (lambda ()
489      (case ((object) 'type)
490         [(pair) pair-dispatch-table]
491         [(symbol) (if (eq? (subset-mode) 'system)
492                       system-symbol-dispatch-table
493                       symbol-dispatch-table)]
494         [(vector) vector-dispatch-table]
495         [(fxvector) fxvector-dispatch-table]
496         [(bytevector) bytevector-dispatch-table]
497         [(record) record-dispatch-table]
498         [(string) string-dispatch-table]
499         [(box) box-dispatch-table]
500         [(continuation) continuation-dispatch-table]
501         [(procedure) procedure-dispatch-table]
502         [(code) code-dispatch-table]
503         [(port) port-dispatch-table]
504         [(simple)
505          (let ([x ((object) 'value)])
506             (cond
507                [(char? x) char-dispatch-table]
508                [else empty-dispatch-table]))]
509         [(tlc) tlc-dispatch-table]
510         [(ftype-struct) ftype-struct-dispatch-table]
511         [(ftype-union) ftype-union-dispatch-table]
512         [(ftype-array) ftype-array-dispatch-table]
513         [(ftype-*) ftype-pointer-dispatch-table]
514         [(ftype-bits) ftype-bits-dispatch-table]
515         [(ftype-base) ftype-pointer-dispatch-table]
516         [(ftype-function) ftype-function-dispatch-table]
517         [else empty-dispatch-table])))
518
519(define inspector-read
520   (lambda (ip)
521      (let* ([ip (console-input-port)] [c (read-char ip)])
522         (cond
523            [(eof-object? c)
524             (newline (console-output-port))
525             '("quit")]
526            [(char=? c #\newline)
527             (set-port-bol! (console-output-port) #t)
528             '()]
529            [(char-whitespace? c)
530             (inspector-read ip)]
531            [else
532             (unread-char c ip)
533             (let ([first (inspector-read-command ip)])
534                (cons first (inspector-read-tail ip)))]))))
535
536(define inspector-read-command
537   (lambda (ip)
538      (let ([p (open-output-string)])
539         (let read-letters ()
540            (let ([c (peek-char ip)])
541               (if (and (char? c)
542                        (not (char-numeric? c))
543                        (not (char-whitespace? c)))
544                   (begin (read-char ip)
545                          (write-char c p)
546                          (read-letters))
547                   (get-output-string p)))))))
548
549(define inspector-read-tail
550   (lambda (ip)
551      (let ([c (peek-char ip)])
552         (cond
553            [(char=? c #\newline)
554             (read-char ip)
555             (set-port-bol! (console-output-port) #t)
556             '()]
557            [(or (char-whitespace? c)    ; [(
558                 (memv c '(#\) #\])))
559             (read-char ip)
560             (inspector-read-tail ip)]
561            [else
562             (let ([x (read ip)])
563                (cons x (inspector-read-tail ip)))]))))
564
565(define dispatch
566   (lambda (c t)
567      (let ([handler (or (search-dispatch-table (car c) t)
568                         (search-dispatch-table (car c)
569                                                generic-dispatch-table))])
570         (if handler
571             (apply handler (cdr c))
572             (invalid-command)))))
573
574(define search-dispatch-table
575   (lambda (s t)
576      (and (not (null? t))
577           (let ([first (car t)])
578              (let ([key (car first)])
579                 (if (if (string? key)
580                         (string=? key s)
581                         (or (string=? (car key) s)
582                             (string=? (cdr key) s)))
583                     (caddr first)
584                     (search-dispatch-table s (cdr t))))))))
585
586(define spaces
587   (lambda (n)
588      (if (> n 0)
589          (make-string n #\space)
590          "")))
591
592(define write-to-string
593   (lambda (x)
594      (let ([p (open-output-string)])
595         (x 'write p)
596         (get-output-string p))))
597
598(define short-form-rec
599   (lambda (x limit)
600      (let try ([low 1]
601                [high #f]
602                [r (parameterize ([print-level 0] [print-length 0])
603                      (write-to-string x))])
604         (let ([mid (+ low (if high (quotient (- high low) 2) low))])
605            (if (= mid low)
606                r
607                (let ([s (parameterize ([print-level mid] [print-length mid])
608                            (write-to-string x))])
609                   (cond
610                      [(string=? s r) s]
611                      [(> (string-length s) limit) (try low mid r)]
612                      [else (try mid high s)])))))))
613
614(define short-form-lambda
615   ; x looks like "(lambda vars body)"
616   ; print the "lambda" and all of the vars that fit
617   (lambda (x limit)
618      (let ([first (format "(lambda ~a "                                  ;)
619                           (short-form-rec ((x 'cdr) 'car) (- limit 14)))])
620         (let ([rest (short-form-rec ((x 'cdr) 'cdr)
621                                     (- limit (string-length first)))])
622            (if (and (> (string-length rest) 0)
623                     (char=? (string-ref rest 0) #\())                    ;)
624                 (string-append first (substring rest 1 (string-length rest)))
625                 (short-form-rec x limit))))))
626
627(define short-form
628   (lambda (x limit)
629      (case (x 'type)
630         [(pair)
631          (if (and (eq? ((x 'car) 'type) 'symbol)
632                   (eq? ((x 'car) 'value) 'lambda)
633                   (eq? ((x 'cdr) 'type) 'pair)
634                   (eq? (((x 'cdr) 'cdr) 'type) 'pair))
635              (short-form-lambda x limit)
636              (short-form-rec x limit))]
637         [(string)
638          (let ([s (format "~s"
639                    ; avoid passing format the whole of a large string
640                     (let ([s (x 'value)])
641                       (if (<= (string-length s) limit)
642                           s
643                           (substring s 0 limit))))])
644            (if (<= (string-length s) limit)
645                s
646                (string-append
647                  (substring s 0 (max (- limit 4) 1))
648                  "...\"")))]
649         [else (short-form-rec x limit)])))
650
651(define form
652  (lambda (x used limit)
653    (short-form x (- limit used))))
654
655(define inspector-prompt
656   (lambda ()
657      (let ([obj (form (object) 0 prompt-line-limit)])
658         (fprintf (console-output-port)
659                  "~a~a : "
660                  obj
661                  (spaces (- prompt-line-limit (string-length obj)))))))
662
663(define outer-reset-handler ($make-thread-parameter values))
664
665(define inspector
666  (lambda (last-command)
667    (inspector
668      (let ([saved-state current-state])
669        (parameterize ([reset-handler (call/cc
670                                        (lambda (k)
671                                          (rec f
672                                            (lambda ()
673                                              (clear-output-port (console-output-port))
674                                              (set! current-state saved-state)
675                                              (k f)))))])
676          (let ([ip (console-input-port)])
677            (clear-input-port ip)
678            (inspector-prompt)
679            (let ([cmd (let ([cmd (inspector-read ip)])
680                         (cond
681                           [(null? cmd)
682                            (if (equal? (car last-command) "list")
683                                '("list")
684                                last-command)]
685                           [(number? (car cmd)) (cons "ref" cmd)]
686                           [else cmd]))])
687              (cond
688                [(equal? cmd '("?"))
689                 (let ([t (select-dispatch-table)])
690                   (if (null? t)
691                       (display-options generic-dispatch-table #t)
692                       (display-options t #f)))]
693                [(equal? cmd '("??"))
694                 (display-options generic-dispatch-table #t)]
695                [else
696                 (guard (c [#t (let ([op (console-output-port)])
697                                 (fresh-line op)
698                                 (display-condition c op)
699                                 (newline op)
700                                 (set! current-state saved-state))])
701                   (dispatch cmd (select-dispatch-table)))])
702              cmd)))))))
703
704(define-syntax inspector-print
705  (syntax-rules ()
706    [(_ e)
707     (call-with-values (lambda () e)
708       (case-lambda
709         [(x) (unless (eq? x (void)) (pretty-print x (console-output-port)))]
710         [args (for-each (lambda (x) (pretty-print x (console-output-port))) args)]))]))
711
712(module (inspector-find inspector-find-next)
713  (define down-path
714    (lambda (path)
715      (assert (and (list? path) (>= (length path) 1)))
716      (let f ([path path])
717        (let ([x (car path)] [path (cdr path)])
718          (if (null? path)
719              (assert (eq? x ((object) 'value)))
720              (begin
721                (f path)
722                (down ((object) 'make-me-a-child x) #f)))))))
723  (define inspector-find
724    (lambda (pred gen)
725      (state-find-next-set! current-state (make-object-finder pred ((object) 'value) gen))
726      (let ([path ((state-find-next current-state))])
727        (unless path (inspect-error "Not found"))
728        (down-path path))))
729  (define inspector-find-next
730    (lambda ()
731      (let loop ([state current-state])
732        (cond
733          [(not state) (inspect-error "No current find.")]
734          [(state-find-next state) =>
735           (lambda (find-next)
736             (let ([path (find-next)])
737               (unless path (inspect-error "Not found"))
738               (set! current-state state)
739               (down-path path)))]
740          [else (loop (state-link state))])))))
741
742(define generic-dispatch-table
743 (make-dispatch-table
744
745  [("print" . "p")
746   "pretty-print object"
747   (()
748    (newline (console-output-port))
749    ((object) 'print (console-output-port))
750    (newline (console-output-port)))]
751
752  [("write" . "w")
753   "write object"
754   (()
755    (newline (console-output-port))
756    ((object) 'write (console-output-port))
757    (newline (console-output-port))
758    (newline (console-output-port)))]
759
760  ["size"
761   "recursively compute storage occupied by object"
762   (() (fprintf (console-output-port) "~s\n" ((object) 'size (collect-maximum-generation))))
763   ((g)
764    (require (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static)))
765    (fprintf (console-output-port) "~s\n" ((object) 'size g)))]
766
767  ["find"
768   "find within object, given a predicate"
769   (()
770    (let ([x (waiter-read)])
771      (unless (eof-object? x)
772        (let ([x (eval x)])
773          (unless (procedure? x) (inspect-error "~s is not a procedure" x))
774          (inspector-find x (collect-maximum-generation))))))
775   ((x)
776    (let ([x (eval x)])
777      (unless (procedure? x) (inspect-error "~s is not a procedure" x))
778      (inspector-find x (collect-maximum-generation))))
779   ((x g)
780    (require (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static)))
781    (let ([x (eval x)])
782      (unless (procedure? x) (inspect-error "~s is not a procedure" x))
783      (inspector-find x g)))]
784
785  ["find-next"
786   "repeat find"
787   (()
788    (inspector-find-next))]
789
790  [("up" . "u")
791   "return to [nth] previous level"
792   (() (up))
793   ((n)
794    (range-check n)
795    (let backup ([n n])
796       (unless (= n 0)
797          (up)
798          (backup (- n 1)))))]
799
800  [("top" . "t")
801   "return to initial object"
802   (()
803    (let top ()
804       (let ([next (state-link current-state)])
805          (when next
806             (set! current-state next)
807             (top)))))]
808
809  [("forward" . "f")
810   "move to [nth] next expression"
811   (() (move 1))
812   ((n)
813    (range-check n)
814    (move n))]
815
816  [("back" . "b")
817   "move to [nth] previous expression"
818   (() (move -1))
819   ((n)
820    (range-check n)
821    (move (- n)))]
822
823  ["=>"
824   "send object to procedure"
825   (()
826    (let ([x (waiter-read)])
827       (unless (eof-object? x)
828          (let ([x (eval x)])
829             (unless (procedure? x) (inspect-error "~s is not a procedure" x))
830             (inspector-print (x ((object) 'value)))))))
831   ((x)
832    (let ([x (eval x)])
833       (unless (procedure? x) (inspect-error "~s is not a procedure" x))
834       (inspector-print (x ((object) 'value)))))]
835
836  ["file"
837   "switch to named source file"
838   ((path)
839    (unless (or (string? path) (symbol? path))
840      (inspect-error "invalid path ~s" path))
841    (open-source-file (if (symbol? path) (symbol->string path) path)))]
842
843  ["list"
844   "list the current source file [line [count]]"
845   (() (list-source-file))
846   ((n) (list-source-file n))
847   ((n m) (list-source-file n m))]
848
849  ["files"
850   "show open files"
851   (()
852    (for-each
853      (lambda (sf) (show "~a" (sfile-path sf)))
854      source-files))]
855
856  [("mark" . "m")
857   "mark location [with symbolic mark]"
858   (() (put-mark default-mark))
859   ((m) (put-mark (make-mark m)))]
860
861  [("goto" . "g")
862   "go to marked location [mark]"
863   (() (to-mark default-mark))
864   ((m) (to-mark (make-mark m)))]
865
866  [("new-cafe" . "n")
867   "enter a new cafe"
868   (()
869    (newline (console-output-port))
870    (new-cafe)
871    (newline (console-output-port)))]
872
873  [("quit" . "q")
874   "exit inspector"
875   (()
876    (newline (console-output-port))
877    (exit))]
878
879  [("reset" . "r")
880   "reset scheme"
881   (()
882    (newline (console-output-port))
883    ((outer-reset-handler)))]
884
885  [("abort" . "a")
886   "abort scheme [with exit code n]"
887   (()
888    (newline (console-output-port))
889    (abort))
890   ((x)
891    (newline (console-output-port))
892    (abort x))]
893
894  [("help" . "h")
895   "help"
896   (()
897    (show "
898     An overview of the current object is displayed as part of each
899     prompt.  There are commands for displaying more of an object or
900     inspecting its components.  \"?\" displays type-specific command
901     options and \"??\" displays command options that are always
902     available.  Some commands take parameters, which are entered
903     following the command on the same line.  An empty command line
904     repeats the previous command.  To perform more complex actions,
905     enter the command \"n\", which creates a new top level with access
906     to the usual Scheme environment.  The inspector is resumed upon
907     exit from the new top level.  Enter \"quit\" (or end-of-file) to
908     exit from the inspector.
909"))]
910
911))
912
913(define empty-dispatch-table (make-dispatch-table))
914
915(define pair-dispatch-table
916 (make-dispatch-table
917
918   [("length" . "l")
919    "display list length"
920    (()
921     (apply (lambda (type len)
922               (case type
923                  [(proper) (show "   proper list, length ~d" len)]
924                  [(improper) (show "   improper list, length ~d" len)]
925                  [(circular) (show "   circular list, length ~d" len)]))
926            ((object) 'length)))]
927
928   ["car"
929    "inspect car of pair"
930    (() (ref-list 0))]
931
932   ["cdr"
933    "inspect cdr of pair"
934    (() (down ((object) 'cdr) #f))]
935
936   [("ref" . "r")
937    "inspect [nth] car"
938    (() (ref-list 0))
939    ((n) (ref-list n))]
940
941   ["tail"
942    "inspect [nth] cdr"
943    (() (down ((object) 'cdr) #f))
944    ((n)
945     (range-check n)
946     (let tail ([i n])
947        (unless (= i 0)
948           (unless (type? 'pair (object)) (invalid-movement))
949           (down ((object) 'cdr) #f)
950           (tail (- i 1)))))]
951
952   [("show" . "s")
953     "show [n] elements of list"
954     (() (display-list (cadr ((object) 'length))))
955     ((n)
956      (range-check n)
957      (display-list n))]
958
959))
960
961(define vector-dispatch-table
962 (make-dispatch-table
963
964   [("length" . "l")
965    "display vector length"
966    (() (show "   ~d elements" ((object) 'length)))]
967
968   [("ref" . "r")
969    "inspect [nth] element"
970    (() (ref 0))
971    ((n) (ref n))]
972
973   [("show" . "s")
974     "show [n] elements"
975     (() (display-refs ((object) 'length)))
976     ((n)
977      (range-check n ((object) 'length))
978      (display-refs n))]
979
980))
981
982(define fxvector-dispatch-table
983 (make-dispatch-table
984
985   [("length" . "l")
986    "display fxvector length"
987    (() (show "   ~d elements" ((object) 'length)))]
988
989   [("ref" . "r")
990    "inspect [nth] element"
991    (() (ref 0))
992    ((n) (ref n))]
993
994   [("show" . "s")
995     "show [n] elements"
996     (() (display-refs ((object) 'length)))
997     ((n)
998      (range-check n ((object) 'length))
999      (display-refs n))]
1000
1001))
1002
1003(define bytevector-dispatch-table
1004 (make-dispatch-table
1005
1006   [("length" . "l")
1007    "display bytevector length"
1008    (() (show "   ~d elements" ((object) 'length)))]
1009
1010   [("ref" . "r")
1011    "inspect [nth] element"
1012    (() (ref 0))
1013    ((n) (ref n))]
1014
1015   [("show" . "s")
1016     "show [n] elements"
1017     (() (display-refs ((object) 'length)))
1018     ((n)
1019      (range-check n ((object) 'length))
1020      (display-refs n))]
1021
1022))
1023
1024(define ftype-struct-dispatch-table
1025 (make-dispatch-table
1026   ["fields"
1027    "inspect fields"
1028    (() (down ((object) 'fields) #f))]
1029
1030   [("ref" . "r")
1031    "inspect named or nth element"
1032    (() (down ((object) 'ref 0) 0))
1033    ((f) (down ((object) 'ref f) (and (fixnum? f) f)))]
1034
1035   ["set!"
1036    "set named element, if assignable"
1037    ((f)
1038     (let ([x (waiter-read)])
1039       (unless (eof-object? x)
1040         (let ((x (eval x)))
1041           ((object) 'set! f x)))))
1042    ((f v) ((object) 'set! f (eval v)))]
1043
1044   ["ftype"
1045    "inspect the ftype"
1046    (() (down ((object) 'ftype) #f))]
1047
1048   [("show" . "s")
1049    "show contents of struct"
1050    (()
1051     (let ([fields (((object) 'fields) 'value)])
1052       (if (null? fields)
1053           (show "*** struct has no fields ***")
1054           (for-each
1055             (lambda (f i)
1056               (name-label-line-display
1057                 ((object) 'ref i)
1058                 f
1059                 i))
1060             fields
1061             (iota (length fields))))))]))
1062
1063(define ftype-union-dispatch-table
1064 (make-dispatch-table
1065   ["fields"
1066    "inspect fields"
1067    (() (down ((object) 'fields) #f))]
1068
1069   [("ref" . "r")
1070    "inspect named or nth element"
1071    (() (down ((object) 'ref 0) 0))
1072    ((f) (down ((object) 'ref f) (and (fixnum? f) f)))]
1073
1074   ["set!"
1075    "set named element, if assignable"
1076    ((f)
1077     (let ([x (waiter-read)])
1078       (unless (eof-object? x)
1079         (let ((x (eval x)))
1080           ((object) 'set! f x)))))
1081    ((f v) ((object) 'set! f (eval v)))]
1082
1083   ["ftype"
1084    "inspect the ftype"
1085    (() (down ((object) 'ftype) #f))]
1086
1087   [("show" . "s")
1088    "show contents of union"
1089    (()
1090     (let ([fields (((object) 'fields) 'value)])
1091       (if (null? fields)
1092           (show "*** union has no fields ***")
1093           (for-each
1094             (lambda (f i)
1095               (name-label-line-display
1096                 ((object) 'ref i)
1097                 f
1098                 i))
1099             fields
1100             (iota (length fields))))))]))
1101
1102(define ftype-array-dispatch-table
1103 (make-dispatch-table
1104   [("length" . "l")
1105    "display array length"
1106    (() (show "   ~d elements" ((object) 'length)))]
1107
1108   [("ref" . "r")
1109    "inspect [nth] element"
1110    (() (ref 0))
1111    ((n) (ref n))]
1112
1113   ["set!"
1114    "set [nth] element, if assignable"
1115    ((f)
1116     (let ([x (waiter-read)])
1117       (unless (eof-object? x)
1118         (let ((x (eval x)))
1119           ((object) 'set! f x)))))
1120    ((f v) ((object) 'set! f (eval v)))]
1121
1122   ["ftype"
1123    "inspect the ftype"
1124    (() (down ((object) 'ftype) #f))]
1125
1126   [("show" . "s")
1127     "show [n] elements"
1128     (() (display-refs ((object) 'length)))
1129     ((n)
1130      (range-check n ((object) 'length))
1131      (display-refs n))]
1132   ))
1133
1134(define ftype-pointer-dispatch-table
1135 (make-dispatch-table
1136   [("ref" . "r")
1137    "inspect target of pointer"
1138    (() (down ((object) 'ref) #f))
1139    ((n)
1140     (unless (memv n '(* 0)) (invalid-movement))
1141     (down ((object) 'ref) #f))]
1142
1143   ["set!"
1144    "set target of pointer, if assignable"
1145    (()
1146     (let ([x (waiter-read)])
1147       (unless (eof-object? x)
1148         (let ((x (eval x)))
1149           ((object) 'set! x)))))
1150    ((v) ((object) 'set! (eval v)))]
1151
1152   ["ftype"
1153    "inspect ftype of target"
1154    (() (down ((object) 'ftype) #f))]
1155
1156   [("show" . "s")
1157     "show the target"
1158     (() (label-line-display ((object) 'ref) 0))]
1159   ))
1160
1161(define ftype-function-dispatch-table
1162 (make-dispatch-table
1163   ["name"
1164    "inspect foreign-function name"
1165    (() (down ((object) 'name) #f))]
1166
1167   ["address"
1168    "inspect foreign-function address"
1169    (() (down ((object) 'address) #f))]
1170
1171   ["ftype"
1172    "inspect ftype of target"
1173    (() (down ((object) 'ftype) #f))]
1174
1175   [("show" . "s")
1176     "show the target"
1177     (() (label-line-display ((object) 'name) 0)
1178         (label-line-display ((object) 'address) 1))]
1179   ))
1180
1181(define ftype-bits-dispatch-table
1182 (make-dispatch-table
1183   ["fields"
1184    "inspect fields"
1185    (() (down ((object) 'fields) #f))]
1186
1187   [("ref" . "r")
1188    "inspect named or nth element"
1189    (() (down ((object) 'ref 0) 0))
1190    ((f) (down ((object) 'ref f) (and (fixnum? f) f)))]
1191
1192   ["set!"
1193    "set named element, if assignable"
1194    ((f)
1195     (let ([x (waiter-read)])
1196       (unless (eof-object? x)
1197         (let ((x (eval x)))
1198           ((object) 'set! f x)))))
1199    ((f v) ((object) 'set! f (eval v)))]
1200
1201   ["ftype"
1202    "inspect the ftype"
1203    (() (down ((object) 'ftype) #f))]
1204
1205   [("show" . "s")
1206    "show bit fields"
1207    (()
1208     (let ([fields (((object) 'fields) 'value)])
1209       (if (null? fields)
1210           (show "*** no fields ***")
1211           (for-each
1212             (lambda (f i)
1213               (name-label-line-display
1214                 ((object) 'ref i)
1215                 f
1216                 i))
1217             fields
1218             (iota (length fields))))))]))
1219
1220(define record-dispatch-table
1221 (make-dispatch-table
1222
1223   ["fields"
1224    "inspect fields"
1225    (() (down ((object) 'fields) #f))]
1226
1227   ["name"
1228    "inspect record name"
1229    (() (down ((object) 'name) #f))]
1230
1231   ["rtd"
1232    "inspect record-type descriptor"
1233    (() (down ((object) 'rtd) #f))]
1234
1235   [("ref" . "r")
1236    "inspect named or nth element"
1237    ((f) (down ((object) 'ref f) (and (fixnum? f) f)))]
1238
1239   ["set!"
1240    "set named element, if assignable"
1241    ((f)
1242     (let ([x (waiter-read)])
1243       (unless (eof-object? x)
1244         (let ((x (eval x)))
1245           ((object) 'set! f x)))))
1246    ((f v) ((object) 'set! f (eval v)))]
1247
1248   [("show" . "s")
1249     "show contents of record"
1250    (()
1251     (when (and (eq? (subset-mode) 'system)
1252                (record-type-opaque? (((object) 'rtd) 'value)))
1253       (show "*** inspecting opaque record ***"))
1254     (let ([fields (((object) 'fields) 'value)])
1255       (if (null? fields)
1256           (show "*** record has no fields ***")
1257           (for-each
1258             (lambda (f i)
1259               (name-label-line-display
1260                 (if ((object) 'accessible? i)
1261                     ((object) 'ref i)
1262                     (inspect/object "*** inaccessible ***"))
1263                 f
1264                 i))
1265             fields
1266             (iota (length fields))))))]
1267))
1268
1269
1270(define string-dispatch-table
1271 (make-dispatch-table
1272
1273   [("length" . "l")
1274    "display string length"
1275    (() (show "   ~d characters" ((object) 'length)))]
1276
1277   [("ref" . "r")
1278    "inspect [nth] character"
1279    (() (ref 0))
1280    ((n) (ref n))]
1281
1282   [("show" . "s")
1283     "show [n] characters"
1284     (() (display-chars ((object) 'length) charschemecode 5))
1285     ((n)
1286      (range-check n ((object) 'length))
1287      (display-chars n charschemecode 5))]
1288
1289   ["unicode"
1290     "display [n] characters as hexadecimal unicode codes"
1291     (() (display-chars ((object) 'length) unicodehexcode 8))
1292     ((n)
1293      (range-check n ((object) 'length))
1294      (display-chars n unicodehexcode 8))]
1295
1296   ["ascii"
1297     "display [n] characters as hexadecimal ascii codes"
1298     (() (display-chars ((object) 'length) asciihexcode 16))
1299     ((n)
1300      (range-check n ((object) 'length))
1301      (display-chars n asciihexcode 16))]
1302))
1303
1304(define char-dispatch-table
1305 (make-dispatch-table
1306
1307   ["unicode"
1308    "display character as hexadecimal ascii code"
1309     (() (show "   U+~x" (unicodehexcode ((object) 'value))))]
1310
1311   ["ascii"
1312    "display character as hexadecimal ascii code"
1313     (() (show "   ~x" (asciihexcode ((object) 'value))))]
1314
1315))
1316
1317(define box-dispatch-table
1318 (make-dispatch-table
1319
1320   ["unbox"
1321     "inspect contents of box"
1322     (() (down ((object) 'unbox) #f))]
1323
1324   [("ref" . "r")
1325     "inspect contents of box"
1326     (() (down ((object) 'unbox) #f))]
1327
1328   [("show" . "s")
1329     "show contents of box"
1330     (() (label-line-display ((object) 'unbox) 0))
1331     ((n)
1332      (range-check n 0)
1333      (label-line-display ((object) 'unbox) 0))]
1334))
1335
1336
1337(define system-symbol-dispatch-table
1338 (make-dispatch-table
1339
1340   [("ref" . "r")
1341    "inspect value field [n] of symbol"
1342    (()
1343     (down ((object) 'top-level-value) 0))
1344    ((n)
1345     (range-check n 5)
1346     (down ((object)
1347            (case n
1348               [(0) 'top-level-value]
1349               [(1) '$top-level-value]
1350               [(2) 'name]
1351               [(3) 'property-list]
1352               [(4) 'system-property-list]
1353               [(5) 'symbol-hash]))
1354           n))]
1355
1356   [("value" . "v")
1357    "inspect top-level-value of symbol"
1358    (() (down ((object) 'top-level-value) 0))]
1359
1360   [("value-slot" . "vs")
1361    "inspect value slot of symbol"
1362    (() (down ((object) '$top-level-value) 0))]
1363
1364   [("name" . "n")
1365    "inspect name of symbol"
1366    (() (down ((object) 'name) 1))]
1367
1368   [("property-list" . "pl")
1369    "inspect property-list of symbol"
1370    (() (down ((object) 'property-list) 2))]
1371
1372   [("system-property-list" . "spl")
1373    "inspect system property-list of symbol"
1374    (() (down ((object) 'system-property-list) 4))]
1375
1376   [("symbol-hash" . "sh")
1377    "inspect hash code"
1378    (() (down ((object) 'symbol-hash) 5))]
1379
1380   [("show" . "s")
1381     "show fields of symbol"
1382     (()
1383      (name-label-line-display ((object) 'top-level-value) "top-level value" 0)
1384      (name-label-line-display ((object) '$top-level-value) "value slot" 1)
1385      (name-label-line-display ((object) 'name) "name" 2)
1386      (name-label-line-display ((object) 'property-list) "properties" 3)
1387      (name-label-line-display ((object) 'system-property-list) "system properties" 4)
1388      (name-label-line-display ((object) 'symbol-hash) "hash code" 5))]
1389))
1390
1391(define symbol-dispatch-table
1392 (make-dispatch-table
1393
1394   [("ref" . "r")
1395    "inspect value field [n] of symbol"
1396    (()
1397     (down ((object) 'top-level-value) 0))
1398    ((n)
1399     (range-check n 2)
1400     (down ((object)
1401            (case n
1402               [(0) 'top-level-value]
1403               [(1) 'name]
1404               [(2) 'property-list]))
1405           n))]
1406
1407   [("value" . "v")
1408    "inspect top-level-value of symbol"
1409    (() (down ((object) 'top-level-value) 0))]
1410
1411   [("name" . "n")
1412    "inspect name of symbol"
1413    (() (down ((object) 'name) 1))]
1414
1415   [("property-list" . "pl")
1416    "inspect property-list of symbol"
1417    (() (down ((object) 'property-list) 2))]
1418
1419   [("show" . "s")
1420     "show fields of symbol"
1421     (()
1422      (name-label-line-display ((object) 'top-level-value) "top level value" 0)
1423      (name-label-line-display ((object) 'name) "name" 1)
1424      (name-label-line-display ((object) 'property-list) "properties" 2))]
1425))
1426
1427(define procedure-dispatch-table
1428 (make-dispatch-table
1429
1430   [("length" . "l")
1431    "display number of free variables"
1432    (() (show "   ~d free variables" ((object) 'length)))]
1433
1434   [("ref" . "r")
1435    "inspect [nth] free variable"
1436    (() (ref 0))
1437    ((x) (variable-ref x))]
1438
1439   [("set!" . "!")
1440    "set [nth or named] free variable to value, if assignable"
1441    (()
1442     (let ([e (waiter-read)])
1443       (unless (eof-object? e)
1444         (set 0 ((object) 'eval e)))))
1445    ((x)
1446     (let ([e (waiter-read)])
1447       (unless (eof-object? e)
1448         (variable-set x ((object) 'eval e)))))
1449    ((x e) (variable-set x ((object) 'eval e)))]
1450
1451  [("eval" . "e")
1452    "evaluate expression in context of procedure environment"
1453    (()
1454     (let ([x (waiter-read)])
1455       (unless (eof-object? x)
1456         (inspector-print ((object) 'eval x)))))
1457    ((x)
1458     (inspector-print ((object) 'eval x)))]
1459
1460   [("show" . "s")
1461    "show code and free variables"
1462    (()
1463     (let ([source (((object) 'code) 'source)])
1464        (when source (name-line-display source "code")))
1465     (when (> ((object) 'length) 0)
1466        (show "~afree variables:" line-indent)
1467        (display-variable-refs ((object) 'length))))]
1468
1469   [("code" . "c")
1470    "inspect the code for the procedure"
1471    (()
1472     (let ([source (((object) 'code) 'source)])
1473        (if source
1474            (down source #f)
1475            (show "source code not available"))))]
1476
1477   ["file"
1478    "switch to source file containing the procedure"
1479    (() (open-recorded-source-file ((object) 'code)))
1480    ((path)
1481     (unless (or (string? path) (symbol? path))
1482       (inspect-error "invalid path ~s" path))
1483     (open-source-file (if (symbol? path) (symbol->string path) path)))]
1484))
1485
1486(define code-dispatch-table
1487 (make-dispatch-table
1488
1489  [("length" . "l")
1490   "display number of free variables"
1491   (() (show "   ~d free variables" ((object) 'free-count)))]
1492
1493  [("show" . "s")
1494   "show code"
1495   (()
1496    (let ([source ((object) 'source)])
1497       (when source (name-line-display source "code"))))]
1498
1499  [("code" . "c")
1500   "inspect the code"
1501   (()
1502    (let ([source ((object) 'source)])
1503       (if source
1504           (down source #f)
1505           (show "source code not available"))))]
1506
1507  ["file"
1508   "switch to source file containing the procedure"
1509   (() (open-recorded-source-file (object)))
1510   ((path)
1511    (unless (or (string? path) (symbol? path))
1512      (inspect-error "invalid path ~s" path))
1513    (open-source-file (if (symbol? path) (symbol->string path) path)))]
1514))
1515
1516
1517(define continuation-dispatch-table
1518  (let ()
1519    (define reposition
1520      (lambda (incr)
1521        (let ([old-pos ((object) 'pos)])
1522          (unless (fx= old-pos 0) (up))
1523          (let ([pos (fx+ old-pos incr)])
1524            (when (fx>= pos ((object) 'depth)) (invalid-movement))
1525            (if (fx> pos 0)
1526                (let ((link ((object) 'reposition pos)))
1527                  (unless (type? 'continuation link) (invalid-movement))
1528                  (down link #f))
1529                (unless (fx= pos 0) (invalid-movement)))))))
1530
1531    (define continuation-show
1532      (lambda (free?)
1533        (name-line-display ((object) 'link) "continuation")
1534        (let ([source (((object) 'code) 'source)])
1535          (when source (name-line-display source "procedure code")))
1536        (let ([source ((object) 'source)])
1537          (when source (name-line-display source "call code")))
1538        (let ([cp ((object) 'closure)])
1539          (when cp (name-line-display cp "closure")))
1540        (let ([len ((object) (if free? 'length 'frame-length))])
1541          (when (> len 0)
1542            (show "~a~a:" line-indent (if free? "frame and free variables" "frame variables"))
1543            (display-variable-refs len)))))
1544
1545     (make-dispatch-table
1546
1547       [("length" . "l")
1548        "display number of frame and closure variables"
1549        (() (show "   ~d variables" ((object) 'length)))]
1550
1551       ["depth"
1552         "display number of frames in continuation stack"
1553         (() (let ((d ((object) 'depth)))
1554               (show (if (= d 1) "   ~d frame" "   ~d frames") d)))]
1555
1556       [("ref" . "r")
1557        "inspect [named or nth] variable"
1558        (() (ref 0))
1559        ((x) (variable-ref x))]
1560
1561       [("set!" . "!")
1562        "set [named or nth] variable to value, if assignable"
1563        (()
1564         (let ([e (waiter-read)])
1565           (unless (eof-object? e)
1566             (set 0 ((object) 'eval e)))))
1567        ((x)
1568         (let ([e (waiter-read)])
1569           (unless (eof-object? e)
1570             (variable-set x ((object) 'eval e)))))
1571        ((x e) (variable-set x ((object) 'eval e)))]
1572
1573       [("forward" . "f")
1574        "move to [nth] next frame"
1575        (() (reposition 1))
1576        ((pos)
1577         (range-check pos)
1578         (reposition pos))]
1579
1580       [("back" . "b")
1581        "move to [nth] previous frame"
1582        (() (reposition -1))
1583        ((pos)
1584         (range-check pos)
1585         (reposition (fx- pos)))]
1586
1587       [("down" . "d")
1588        "inspect [nth] next frame"
1589        (() (let ((link ((object) 'link)))
1590              (unless (type? 'continuation link) (invalid-movement))
1591              (down link #f)))
1592        ((n)
1593         (range-check n (- ((object) 'depth) 1))
1594         (let ((link ((object) 'link* n)))
1595           (unless (type? 'continuation link) (invalid-movement))
1596           (down link #f)))]
1597
1598       [("closure" . "cp")
1599        "inspect the frame's closure, if any"
1600        (() (let ([cp ((object) 'closure)])
1601              (unless cp (inspect-error "this frame has no closure"))
1602              (down cp #f)))]
1603
1604       [("eval" . "e")
1605        "evaluate expression in context of current frame"
1606        (()
1607         (let ([x (waiter-read)])
1608           (unless (eof-object? x)
1609             (inspector-print ((object) 'eval x)))))
1610        ((x)
1611         (inspector-print ((object) 'eval x)))]
1612
1613       [("show" . "s")
1614        "show frame with free variables"
1615        (() (continuation-show #t))]
1616
1617       [("show-local" . "sl")
1618        "show frame without free variables"
1619        (() (continuation-show #f))]
1620
1621       [("show-frames" . "sf")
1622        "show the next [n] frames"
1623        (() (display-links (most-positive-fixnum)))
1624        ((n)
1625         (range-check n)
1626         (display-links n))]
1627
1628       ["call"
1629         "inspect the code for the pending call"
1630         (()
1631          (let ([source ((object) 'source)])
1632            (if source
1633                (down source #f)
1634                (show "source code not available"))))]
1635
1636       [("code" . "c")
1637        "inspect the code for the pending procedure"
1638        (()
1639         (let ([source (((object) 'code) 'source)])
1640           (if source
1641               (down source #f)
1642               (show "source code not available"))))]
1643
1644       ["file"
1645         "switch to source file containing the pending call"
1646         (() (open-recorded-source-file (object)))
1647         ((path)
1648          (unless (or (string? path) (symbol? path))
1649            (inspect-error "invalid path ~s" path))
1650          (open-source-file (if (symbol? path) (symbol->string path) path)))]
1651
1652       )))
1653
1654(define port-dispatch-table
1655 (make-dispatch-table
1656
1657   [("show" . "s")
1658    "show port contents"
1659    (()
1660     (name-line-display ((object) 'name) "name")
1661     (name-line-display ((object) 'handler) "handler")
1662     (when ((object) 'input?)
1663        (show "~ainput size: ~s" line-indent ((object) 'input-size))
1664        (show "~ainput index: ~s" line-indent ((object) 'input-index)))
1665     (when ((object) 'output?)
1666        (show "~aoutput size: ~s" line-indent ((object) 'output-size))
1667        (show "~aoutput index: ~s" line-indent ((object) 'output-index))))]
1668
1669   ["name"
1670    "inspect port name"
1671    (() (down ((object) 'name) #f))]
1672
1673   ["handler"
1674    "inspect port handler"
1675    (() (down ((object) 'handler) #f))]
1676
1677   [("output-buffer" . "ob")
1678    "inspect output buffer"
1679    (() (if ((object) 'output?)
1680            (down ((object) 'output-buffer) #f)
1681            (show "not an output port")))]
1682
1683   [("input-buffer" . "ib")
1684    "inspect input buffer"
1685    (() (if ((object) 'input?)
1686            (down ((object) 'input-buffer) #f)
1687            (show "not an input port")))]
1688))
1689
1690(define tlc-dispatch-table
1691 (make-dispatch-table
1692
1693   ["keyval"
1694     "inspect keyval field"
1695     (() (down ((object) 'keyval) #f))]
1696
1697   ["ht"
1698     "inspect ht field"
1699     (() (down ((object) 'ht) #f))]
1700
1701   ["next"
1702     "inspect next field"
1703     (() (down ((object) 'next) #f))]
1704
1705   [("ref" . "r")
1706    "inspect named field"
1707    ((x)
1708     (down ((object)
1709            (case x
1710               [(keyval) 'keyval]
1711               [(ht) 'ht]
1712               [(next) 'next]
1713               [else (invalid-command)]))
1714           x))]
1715
1716   [("show" . "s")
1717     "show fields of tlc"
1718     (()
1719      (name-line-display ((object) 'keyval) "keyval")
1720      (name-line-display ((object) 'ht) "ht")
1721      (name-line-display ((object) 'next) "next"))]
1722))
1723
1724(set! inspect
1725  (lambda (x)
1726    (let ([t (set-timer 0)])
1727      (call/cc
1728        (lambda (k)
1729          (fluid-let ([current-state (make-state (inspect/object x))]
1730                      [marks (make-eq-hashtable)]
1731                      [source-files '()])
1732             (parameterize ([outer-reset-handler (reset-handler)]
1733                            [exit-handler k]
1734                            [$interrupt reset])
1735               (put-mark default-mark)
1736               (dynamic-wind
1737                 void
1738                 (lambda () (inspector '("?")))
1739                 (lambda () (for-each close-source-file source-files)))))))
1740      (set-timer t))
1741    (void)))
1742
1743)
1744
1745(define inspect/object
1746  (lambda (x)
1747    (define compute-size
1748      (let ([size-ht #f])
1749        (lambda (x g)
1750          (unless (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static))
1751            ($oops 'inspector-object "invalid generation ~s" g))
1752          ; using a common size-ht for a single inspect/object call means:
1753          ;   (inspect (let ([x (list 1 2)]) (set-car! x x) (set-car! (cdr x) x) (set-cdr! (cdr x) x) x))
1754          ;     size => 16
1755          ;     cdr, size => 8
1756          ; might be what we want, might not be
1757          (unless size-ht (set! size-ht (make-eq-hashtable)))
1758          ($compute-size x (if (eq? g 'static) (constant static-generation) g) size-ht))))
1759
1760    (define-syntax make-object-maker
1761      (lambda (x)
1762        (syntax-case x ()
1763          [(_ object-name inits [method args e1 e2 ...] ...)
1764           (andmap identifier? #'(object-name method ...))
1765           #'(lambda inits
1766               (let ([method (lambda args e1 e2 ...)] ...)
1767                 (lambda (m . rest)
1768                   (case m
1769                     [(type) 'object-name]
1770                     [(make-me-a-child) (make-object (car rest))]
1771                     [(method) (#2%apply method rest)]
1772                     ...
1773                     [else ($oops 'inspector-object
1774                             "invalid message ~s to object type ~s"
1775                             m
1776                             'object-name)]))))])))
1777
1778    (define frame-eval
1779      (lambda (vars expr)
1780        (define frame-name
1781          (let ((ls '(%0 %1 %2 %3 %4 %5 %6 %7)))
1782            (let ((n (length ls)))
1783              (lambda (i)
1784                (if (< i n)
1785                    (list-ref ls i)
1786                    (string->symbol (format "%~d" i)))))))
1787        (define ->nongensym
1788          (lambda (name)
1789            (if (gensym? name)
1790                (string->symbol (symbol->string name))
1791                name)))
1792        (let ((n (vector-length vars)))
1793          (eval (let f ((i 0))
1794                  (if (= i n)
1795                      expr
1796                      (let ([var (vector-ref vars i)]
1797                            [body (f (+ i 1))])
1798                        (let ([raw-val (var 'raw-value)]
1799                              [name (var 'name)]
1800                              [fv (frame-name i)]
1801                              [t (gensym)])
1802                          `(let ([,t (quote ,raw-val)])
1803                             (let-syntax ([,fv ,(if (assignable? raw-val)
1804                                                    `(identifier-syntax [id (car ,t)] [(set! id e) (set-car! ,t e)])
1805                                                    `(identifier-syntax
1806                                                       [id ,t]
1807                                                       [(set! id e)
1808                                                        (syntax-error #'id "cannot set non-assigned variable")]))])
1809                               ,(if name `(begin (alias ,(->nongensym name) ,fv) ,body) body)))))))))))
1810
1811    (define make-pair-object
1812      (make-object-maker pair (x)
1813        [value () x]
1814        [car () (make-object (car x))]
1815        [cdr () (make-object (cdr x))]
1816        [length ()
1817          (let ([ht (make-eq-hashtable)])
1818            (let length ([x x] [n 0])
1819              (cond
1820                [(null? x) `(proper ,n)]
1821                [(not (pair? x)) `(improper ,n)]
1822                [else
1823                  (let ([a (eq-hashtable-cell ht x #f)])
1824                    (if (cdr a)
1825                        `(circular ,n)
1826                        (begin (set-cdr! a #t)
1827                          (length (cdr x) (+ n 1)))))])))]
1828        [size (g) (compute-size x g)]
1829        [write (p) (write x p)]
1830        [print (p) (pretty-print x p)]))
1831
1832    (define make-box-object
1833      (make-object-maker box (x)
1834        [value () x]
1835        [unbox () (make-object (unbox x))]
1836        [size (g) (compute-size x g)]
1837        [write (p) (write x p)]
1838        [print (p) (pretty-print x p)]))
1839
1840    (define make-tlc-object
1841      (make-object-maker tlc (x)
1842        [value () x]
1843        [keyval () (make-object ($tlc-keyval x))]
1844        [ht () (make-object ($tlc-ht x))]
1845        [next () (make-object ($tlc-next x))]
1846        [size (g) (compute-size x g)]
1847        [write (p) (write x p)]
1848        [print (p) (pretty-print x p)]))
1849
1850    (define make-vector-object
1851      (make-object-maker vector (x)
1852        [value () x]
1853        [length () (vector-length x)]
1854        [ref (i)
1855          (unless (and (fixnum? i) (fx< -1 i (vector-length x)))
1856            ($oops 'vector-object "invalid index ~s" i))
1857          (make-object (vector-ref x i))]
1858        [size (g) (compute-size x g)]
1859        [write (p) (write x p)]
1860        [print (p) (pretty-print x p)]))
1861
1862    (define make-fxvector-object
1863      (make-object-maker fxvector (x)
1864        [value () x]
1865        [length () (fxvector-length x)]
1866        [ref (i)
1867          (unless (and (fixnum? i) (fx< -1 i (fxvector-length x)))
1868            ($oops 'fxvector-object "invalid index ~s" i))
1869          (make-object (fxvector-ref x i))]
1870        [size (g) (compute-size x g)]
1871        [write (p) (write x p)]
1872        [print (p) (pretty-print x p)]))
1873
1874    (define make-bytevector-object
1875      (make-object-maker bytevector (x)
1876        [value () x]
1877        [length () (bytevector-length x)]
1878        [ref (i)
1879          (unless (and (fixnum? i) (fx< -1 i (bytevector-length x)))
1880            ($oops 'bytevector-object "invalid index ~s" i))
1881          (make-object (bytevector-u8-ref x i))]
1882        [size (g) (compute-size x g)]
1883        [write (p) (write x p)]
1884        [print (p) (pretty-print x p)]))
1885
1886    (define make-ftype-pointer-object
1887      (lambda (x)
1888        (define (unrecognized-ux ux)
1889          ($oops 'ftype-pointer-object "unrecognized ftype-pointer type ~s" x))
1890        (define (invalid-field-specifier f)
1891          ($oops 'ftype-pointer-object "invalid field specifier ~s" f))
1892        (define (invalid-index f)
1893          ($oops 'ftype-pointer-object "invalid index ~s" f))
1894        (define (get-field f field*)
1895          (cond
1896            [(assq f field*) => cdr]
1897            [(and (fixnum? f) (#%$fxu< f (length field*)))
1898             (cdr (list-ref field* f))]
1899            [else (invalid-field-specifier f)]))
1900        (define (deref x)
1901          (let ([ux ($unwrap-ftype-pointer x)])
1902            (record-case ux
1903              [(struct union array * bits) ignore (make-object x)]
1904              [(base) (type getter setter) (make-object (getter))]
1905              [else (unrecognized-ux ux)])))
1906        (define (deset! who x v)
1907          (let ([ux ($unwrap-ftype-pointer x)])
1908            (record-case ux
1909              [(struct union array bits) ignore ($oops who "cannot assign struct, union, or array")]
1910              [(*) (get-fptr set-fptr!) (set-fptr! who v)]
1911              [(base) (type getter setter) (setter v)]
1912              [else (unrecognized-ux ux)])))
1913        (let ([ux ($unwrap-ftype-pointer x)])
1914          (record-case ux
1915            [(struct) field*
1916             ((make-object-maker ftype-struct (x)
1917                [value () x]
1918                [ftype () (make-object (ftype-pointer-ftype x))]
1919                [fields () (make-object (map (lambda (x) (or (car x) '_)) field*))]
1920                [length () (length field*)]
1921                [ref (f) (deref (get-field f field*))]
1922                [set! (f v) (deset! 'ftype-struct-object (get-field f field*) v)]
1923                [size (g) (compute-size x g)]
1924                [write (p) (write `(ftype struct ...) p)]
1925                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
1926              x)]
1927            [(union) field*
1928             ((make-object-maker ftype-union (x)
1929                [value () x]
1930                [ftype () (make-object (ftype-pointer-ftype x))]
1931                [fields () (make-object (map (lambda (x) (or (car x) '_)) field*))]
1932                [length () (length field*)]
1933                [ref (f) (deref (get-field f field*))]
1934                [set! (f v) (deset! 'ftype-union-object (get-field f field*) v)]
1935                [size (g) (compute-size x g)]
1936                [write (p) (write `(ftype union ...) p)]
1937                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
1938              x)]
1939            [(array) (n get-fptr)
1940             ((make-object-maker ftype-array (x)
1941                [value () x]
1942                [ftype () (make-object (ftype-pointer-ftype x))]
1943                [length () n]
1944                [ref (f)
1945                  (unless (and (integer? f) (exact? f) (#%$fxu< f n))
1946                    (invalid-index f))
1947                  (deref (get-fptr f))]
1948                [set! (f v)
1949                  (unless (and (integer? f) (exact? f) (#%$fxu< f n))
1950                    (invalid-index f))
1951                  (deset! 'ftype-array-object (get-fptr f) v)]
1952                [size (g) (compute-size x g)]
1953                [write (p) (write `(ftype array ...) p)]
1954                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
1955              x)]
1956            [(*) (get-fptr set-fptr!)
1957             ((make-object-maker ftype-* (x)
1958                [value () x]
1959                [ftype () (make-object (ftype-pointer-ftype x))]
1960                [ref () (deref (get-fptr))]
1961                [set! (v) (deset! 'ftype-*-object (get-fptr) v)]
1962                [size (g) (compute-size x g)]
1963                [write (p) (write `(ftype * ...) p)]
1964                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
1965              x)]
1966            [(bits) field*
1967             ((make-object-maker ftype-bits (x)
1968                [value () x]
1969                [ftype () (make-object (ftype-pointer-ftype x))]
1970                [fields () (make-object (map (lambda (x) (or (car x) '_)) field*))]
1971                [length () (length field*)]
1972                [ref (f) (apply (lambda (getter setter) (make-object (getter)))
1973                           (get-field f field*))]
1974                [set! (f v) (apply (lambda (getter setter) (make-object (setter v)))
1975                              (get-field f field*))]
1976                [size (g) (compute-size x g)]
1977                [write (p) (write `(ftype bits ...) p)]
1978                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
1979              x)]
1980            [(base) (type getter setter)
1981             ((make-object-maker ftype-base (x)
1982                [value () x]
1983                [ftype () (make-object (ftype-pointer-ftype x))]
1984                [ref () (make-object (getter))]
1985                [set! (v) (setter v)]
1986                [size (g) (compute-size x g)]
1987                [write (p) (write `(ftype ,type ...) p)]
1988                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
1989              x)]
1990            [(function) (name)
1991             ((make-object-maker ftype-function (x)
1992                [value () x]
1993                [ftype () (make-object (ftype-pointer-ftype x))]
1994                [address () (make-object (ftype-pointer-address x))]
1995                [name () (make-object name)]
1996                [size (g) (compute-size x g)]
1997                [write (p) (write `(ftype function ...) p)]
1998                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
1999              x)]
2000            [else (unrecognized-ux ux)]))))
2001
2002    (define make-record-object
2003      (lambda (x)
2004        (let* ((rtd ($record-type-descriptor x))
2005               (fields (csv7:record-type-field-names rtd)))
2006          (define check-field
2007            (lambda (f)
2008              (unless (or (and (symbol? f) (memq f fields))
2009                          (and (fixnum? f) (fx>= f 0) (fx< f (length fields))))
2010                ($oops 'record-object "invalid field specifier ~s" f))))
2011          ((make-object-maker record (x)
2012             [value () x]
2013             [length () (length fields)]
2014             [fields () (make-object fields)]
2015             [accessible? (f)
2016               (check-field f)
2017               (csv7:record-field-accessible? rtd f)]
2018             [mutable? (f)
2019               (check-field f)
2020               (csv7:record-field-mutable? rtd f)]
2021             [name () (make-object (csv7:record-type-name rtd))]
2022             [rtd () (make-object rtd)]
2023             [ref (f)
2024               (check-field f)
2025               (unless (csv7:record-field-accessible? rtd f)
2026                 ($oops 'record-object "field ~s is inaccessible" f))
2027               (make-object ((csv7:record-field-accessor rtd f) x))]
2028             [set! (f v)
2029               (check-field f)
2030               (unless (csv7:record-field-mutable? rtd f)
2031                 ($oops 'record-object "field ~s is immutable" f))
2032               ((csv7:record-field-mutator rtd f) x v)]
2033             [size (g) (compute-size x g)]
2034             [write (p) (write x p)]
2035             [print (p) (pretty-print x p)])
2036           x))))
2037
2038    (define make-string-object
2039      (make-object-maker string (x)
2040        [value () x]
2041        [length () (string-length x)]
2042        [ref (i)
2043          (unless (and (fixnum? i) (< -1 i (string-length x)))
2044            ($oops 'string-object "invalid index ~s" i))
2045          (make-object (string-ref x i))]
2046        [size (g) (compute-size x g)]
2047        [write (p) (write x p)]
2048        [print (p) (pretty-print x p)]))
2049
2050    (define make-simple-object
2051      (make-object-maker simple (x)
2052        [value () x]
2053        [size (g) (compute-size x g)]
2054        [write (p) (write x p)]
2055        [print (p) (pretty-print x p)]))
2056
2057    (define make-unbound-object
2058      (make-object-maker unbound (x)
2059        [value () x]
2060        [size (g) (compute-size x g)]
2061        [write (p) (write x p)]
2062        [print (p) (pretty-print x p)]))
2063
2064    (define make-procedure-object
2065      (lambda (x)
2066        (real-make-procedure-object x (list->vector (make-procedure-vars x)))))
2067
2068    (define real-make-procedure-object
2069      (make-object-maker procedure (x vars)
2070        [value () x]
2071        [length () (vector-length vars)]
2072        [ref (i)
2073          (unless (and (fixnum? i) (fx< -1 i (vector-length vars)))
2074            ($oops 'procedure-object "invalid index ~s" i))
2075          (vector-ref vars i)]
2076        [eval (x) (frame-eval vars x)]
2077        [code () (make-object ($closure-code x))]
2078        [size (g) (compute-size x g)]
2079        [write (p) (write x p)]
2080        [print (p) (pretty-print x p)]))
2081
2082    (define make-procedure-vars
2083      (lambda (x)
2084        (include "types.ss")
2085        (let ([code ($closure-code x)])
2086          (let ([info ($code-info code)]
2087                [len ($code-free-count code)])
2088            (let ([free (and (code-info? info) (code-info-free info))])
2089              (unless (or (not free) (fx= (vector-length free) len))
2090                ($oops 'inspector "invalid info structure ~s" info))
2091              (let vars ([i 0])
2092                (if (= i len)
2093                    '()
2094                    (cons (make-variable-object
2095                            ($closure-ref x i)
2096                            (and free (vector-ref free i)))
2097                      (vars (+ i 1))))))))))
2098
2099    (define assignable?
2100      (lambda (raw-val)
2101        (and (pair? raw-val) ($unbound-object? (cdr raw-val)))))
2102
2103    (define make-variable-object
2104      (make-object-maker variable (x name)
2105        [name () name]
2106        [assignable? () (assignable? x)]
2107        [raw-value () x]
2108        [ref () (make-object
2109                  (if (assignable? x)
2110                      (car x)
2111                      x))]
2112        [set! (v) (make-object
2113                    (if (assignable? x)
2114                        (set-car! x v)
2115                        ($oops 'variable-object "unassignable variable")))]
2116        [size (g)
2117         (if (assignable? x)
2118             (fx+ (constant size-pair) (compute-size (car x) g))
2119             (compute-size x g))]
2120        [write (p) (display "#<variable>" p)]
2121        [print (p) (display "#<variable>" p) (newline p)]))
2122
2123    (define get-reloc-objs
2124      (foreign-procedure "(cs)s_get_reloc"
2125        (scheme-object) scheme-object))
2126
2127    (module (get-code-src get-code-sexpr)
2128      (include "types.ss")
2129      (define get-code-src
2130        (lambda (x)
2131          (let ([info ($code-info x)])
2132            (and (code-info? info) (code-info-src info)))))
2133      (define get-code-sexpr
2134        (lambda (x)
2135          (let ([info ($code-info x)])
2136            (and (code-info? info) (code-info-sexpr info))))))
2137
2138    (define make-code-object
2139      (make-object-maker code (x)
2140        [value () x]
2141        [name () ($code-name x)]
2142        [info () (make-object ($code-info x))]
2143        [free-count () ($code-free-count x)]
2144        [source ()
2145          (cond
2146            [(get-code-sexpr x) => make-object]
2147            [else #f])]
2148        [source-path () (return-source (get-code-src x))]
2149        [source-object () (get-code-src x)]
2150        [reloc () (make-object (get-reloc-objs x))]
2151        [size (g) (compute-size x g)]
2152        [write (p) (write x p)]
2153        [print (p) (pretty-print x p)]))
2154
2155    (define return-source
2156      (lambda (src)
2157        (include "types.ss")
2158        (if src
2159            (call-with-values
2160              (lambda () ((current-locate-source-object-source) src #t #f))
2161              (case-lambda
2162                [() (let ([sfd (source-sfd src)] [fp (source-bfp src)])
2163                      (values (source-file-descriptor-name sfd) fp))]
2164                [(path line char) (values path line char)]))
2165            (values))))
2166
2167    (define-who make-continuation-object
2168      (lambda (x pos)
2169        (include "types.ss")
2170        (define find-rpi
2171          (lambda (offset rpis)
2172            (let f ([start 0] [end (fx1- (vector-length rpis))])
2173              (if (fx< end start)
2174                  #f
2175                  (let* ([curr (fx+ (fx/ (fx- end start) 2) start)]
2176                         [rpi (vector-ref rpis curr)]
2177                         [rpi-offset (rp-info-offset rpi)])
2178                    (cond
2179                      [(fx= offset rpi-offset) rpi]
2180                      [(fx< offset rpi-offset) (f start (fx1- curr))]
2181                      [else  (f (fx1+ curr) end)]))))))
2182        ($split-continuation x 0)
2183        (let ([info ($code-info ($continuation-return-code x))]
2184              [offset ($continuation-return-offset x)]
2185              [len ($continuation-stack-length x)]
2186              [lpm ($continuation-return-livemask x)])
2187          (cond
2188            [(and (code-info? info) (code-info-rpis info) (find-rpi offset (code-info-rpis info))) =>
2189             (lambda (rpi)
2190               (let ([cookie '(chocolate . chip)])
2191                 (let ([vals (make-vector len cookie)] [vars (make-vector len '())] [live (code-info-live info)])
2192                   ; fill vals based on live-pointer mask
2193                   (let f ([i 1] [lpm lpm])
2194                     (unless (>= i len)
2195                       (when (odd? lpm)
2196                         (vector-set! vals (fx1- i) ($continuation-stack-ref x i)))
2197                       (f (fx1+ i) (ash lpm -1))))
2198                   ; fill vars based on code-info variable mask
2199                   (let f ([i 0] [mask (rp-info-mask rpi)])
2200                     (unless (eqv? mask 0)
2201                       (when (odd? mask)
2202                         (let ([p (vector-ref live i)])
2203                           (let ([index (fx1- (cdr p))])
2204                             (vector-set! vars index (cons (car p) (vector-ref vars index))))))
2205                       (f (+ i 1) (ash mask -1))))
2206                   ; create return vector
2207                   (with-values
2208                     (let f ([i 0] [count 0] [cp #f] [cpvar* '()])
2209                       (if (fx= i len)
2210                           (if cp
2211                               (let ([v (let f ([count count] [cpvar* cpvar*])
2212                                          (if (null? cpvar*)
2213                                              (make-vector count)
2214                                              (let ([v (f (fx+ count 1) (cdr cpvar*))])
2215                                                (vector-set! v count (car cpvar*))
2216                                                v)))])
2217                                 (values v count cp))
2218                               (values (make-vector count) count cp))
2219                           (let ([obj (vector-ref vals i)] [var* (vector-ref vars i)])
2220                             (cond
2221                               [(eq? obj cookie)
2222                                (unless (null? var*) ($oops who "expected value for ~s but it was not in lpm" (car var*)))
2223                                (f (fx1+ i) count cp cpvar*)]
2224                               [(null? var*)
2225                                (let-values ([(v frame-count cp) (f (fx1+ i) (fx1+ count) cp cpvar*)])
2226                                  (vector-set! v count (make-variable-object obj #f))
2227                                  (values v frame-count cp))]
2228                               [else
2229                                 (let g ([var* var*] [count count] [cp cp] [cpvar* cpvar*])
2230                                   (if (null? var*)
2231                                       (f (fx1+ i) count cp cpvar*)
2232                                       (let ([var (car var*)])
2233                                         (if (eq? var cpsymbol)
2234                                             (g (cdr var*) count obj (if (procedure? obj) (make-procedure-vars obj) '()))
2235                                             (cond
2236                                               [(pair? var) ; closure environment represented as a pair
2237                                                (unless (pair? obj)
2238                                                  ($oops who "expected pair value for paired environment, not ~s" obj))
2239                                                (g (cdr var*) count obj (list
2240                                                                          (make-variable-object (car obj) (car var))
2241                                                                          (make-variable-object (cdr obj) (cdr var))))]
2242                                               [(vector? var) ; closure environment represented as a vector
2243                                                (unless (vector? obj)
2244                                                  ($oops who "expected vector value for vector environment, not ~s" obj))
2245                                                (g (cdr var*) count obj (map (lambda (obj var) (make-variable-object obj var))
2246                                                                          (vector->list obj)
2247                                                                          (vector->list var)))]
2248                                               [else
2249                                                 (let-values ([(v frame-count cp) (g (cdr var*) (fx1+ count) cp cpvar*)])
2250                                                   (vector-set! v count (make-variable-object obj var))
2251                                                   (values v frame-count cp))])))))]))))
2252                     (lambda (v frame-count cp)
2253                       (real-make-continuation-object x (rp-info-src rpi) (rp-info-sexpr rpi) cp v frame-count pos))))))]
2254            [else
2255              (let ([v (list->vector
2256                         (let f ([i 1] [lpm lpm])
2257                           (cond
2258                             [(>= i len) '()]
2259                             [(odd? lpm)
2260                              (cons (make-variable-object ($continuation-stack-ref x i) #f)
2261                                (f (fx1+ i) (ash lpm -1)))]
2262                             [else (f (fx1+ i) (ash lpm -1))])))])
2263                (real-make-continuation-object x #f #f #f v (vector-length v) pos))]))))
2264
2265    (define real-make-continuation-object
2266      (let ((continuation-depth
2267              (foreign-procedure "(cs)continuation_depth" (scheme-object)
2268                iptr)))
2269        (make-object-maker continuation (x src sexpr cp vars frame-count pos)
2270          [value () x]
2271          [length () (vector-length vars)]
2272          [closure () (and cp (make-object cp))]
2273          [frame-length () frame-count]
2274          [depth () (continuation-depth x)]
2275          [ref (i)
2276            (unless (and (fixnum? i) (fx< -1 i (vector-length vars)))
2277              ($oops 'continuation-object "invalid index ~s" i))
2278            (vector-ref vars i)]
2279          [pos () pos]
2280          [reposition (pos)
2281            (let ((k (and (fixnum? pos) (fx> pos 0) ($split-continuation x pos))))
2282              (unless k ($oops 'continuation-object "invalid position ~s" pos))
2283              (make-continuation-object k pos))]
2284          [link () (make-object ($continuation-link x))]
2285          [link* (i)
2286            (let ((k (and (fixnum? i) (fx>= i 0) ($split-continuation x i))))
2287              (unless k ($oops 'continuation-object "invalid link* depth ~s" i))
2288              (make-object k))]
2289          [eval (x) (frame-eval vars x)]
2290          [code () (make-object ($continuation-return-code x))]
2291          [source () (and sexpr (make-object sexpr))]
2292          [source-object () src]
2293          [source-path () (return-source src)]
2294          [size (g) (compute-size x g)]
2295          [write (p) (write x p)]
2296          [print (p) (pretty-print x p)])))
2297
2298    (define make-port-object
2299      (make-object-maker port (x)
2300        [value () x]
2301        [input? () (input-port? x)]
2302        [output? () (output-port? x)]
2303        [binary? () (binary-port? x)]
2304        [closed? () (port-closed? x)]
2305        [handler () (make-object ($port-handler x))]
2306        [output-buffer () (and (output-port? x)
2307                               (make-object
2308                                 (if (textual-port? x)
2309                                     (textual-port-output-buffer x)
2310                                     (binary-port-output-buffer x))))]
2311        [output-size () (and (output-port? x)
2312                             (if (textual-port? x)
2313                                 (textual-port-output-size x)
2314                                 (binary-port-output-size x)))]
2315        [output-index () (and (output-port? x)
2316                              (if (textual-port? x)
2317                                  (textual-port-output-index x)
2318                                  (binary-port-output-index x)))]
2319        [input-buffer () (and (input-port? x)
2320                              (make-object
2321                                (if (textual-port? x)
2322                                    (textual-port-input-buffer x)
2323                                    (binary-port-input-buffer x))))]
2324        [input-size () (and (input-port? x)
2325                            (if (textual-port? x)
2326                                (textual-port-input-size x)
2327                                (binary-port-input-size x)))]
2328        [input-index () (and (input-port? x)
2329                             (if (textual-port? x)
2330                                 (textual-port-input-index x)
2331                                 (binary-port-input-index x)))]
2332        [info () (make-object ($port-info x))]
2333        [name () (make-object (port-name x))]
2334        [size (g) (compute-size x g)]
2335        [write (p) (write x p)]
2336        [print (p) (pretty-print x p)]))
2337
2338    (define make-symbol-object
2339      (make-object-maker symbol (x)
2340        [value () x]
2341        [gensym? () (gensym? x)]
2342        [top-level-value ()
2343          (if (top-level-bound? x)
2344              (make-object (top-level-value x))
2345              (make-object ($unbound-object)))]
2346        [$top-level-value ()
2347          (if ($top-level-bound? x)
2348              (make-object ($top-level-value x))
2349              (make-object ($unbound-object)))]
2350        [system-property-list () (make-object ($system-property-list x))]
2351        [symbol-hash () (make-object ($symbol-hash x))]
2352        [name () (make-object (symbol->string x))]
2353        [property-list () (make-object ($symbol-property-list x))]
2354        [size (g) (compute-size x g)]
2355        [write (p) (write x p)]
2356        [print (p) (pretty-print x p)]))
2357
2358    (define make-object
2359      (lambda (x)
2360        (cond
2361          [(pair? x) (make-pair-object x)]
2362          [(symbol? x) (make-symbol-object x)]
2363          [(vector? x) (make-vector-object x)]
2364          [(fxvector? x) (make-fxvector-object x)]
2365          [(bytevector? x) (make-bytevector-object x)]
2366          ; ftype-pointer? test must come before record? test
2367          [($ftype-pointer? x) (make-ftype-pointer-object x)]
2368          [(or (record? x) (and (eq? (subset-mode) 'system) ($record? x)))
2369           (make-record-object x)]
2370          [(string? x) (make-string-object x)]
2371          [(box? x) (make-box-object x)]
2372          [(procedure? x)
2373           (if ($continuation? x)
2374               (if (= ($continuation-stack-length x)
2375                      (constant unscaled-shot-1-shot-flag))
2376                   (make-simple-object x)
2377                   (make-continuation-object x 0))
2378               (make-procedure-object x))]
2379          [($code? x) (make-code-object x)]
2380          [(port? x) (make-port-object x)]
2381          [($unbound-object? x) (make-unbound-object x)]
2382          [($tlc? x) (make-tlc-object x)]
2383          [else (make-simple-object x)])))
2384
2385    (make-object x)))
2386
2387(let ()
2388  (define rtd-size (csv7:record-field-accessor #!base-rtd 'size))
2389  (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
2390  (define $generation (foreign-procedure "(cs)generation" (ptr) ptr))
2391  (define $get-code-obj (foreign-procedure "(cs)get_code_obj" (int ptr iptr iptr) ptr))
2392  (define $code-reloc-size
2393    (lambda (x)
2394      (let ([reloc-table ($object-ref 'scheme-object x (constant code-reloc-disp))])
2395        (if (eqv? reloc-table 0)
2396            0
2397            ($object-ref 'iptr reloc-table (constant reloc-table-size-disp))))))
2398  (define $code-length
2399    (lambda (x)
2400      ($object-ref 'iptr x (constant code-length-disp))))
2401  (define $get-reloc
2402    (lambda (x i)
2403      (let ([reloc-table ($object-ref 'scheme-object x (constant code-reloc-disp))])
2404        (and (not (eqv? reloc-table 0))
2405             ($object-ref 'uptr reloc-table
2406               (fx+ (constant reloc-table-data-disp)
2407                 (fx* i (constant ptr-bytes))))))))
2408  (define-syntax tc-ptr-offsets
2409    (lambda (x)
2410      #`'#,(datum->syntax #'*
2411             (fold-left
2412               (lambda (ls fld)
2413                 (apply (lambda (name type disp len)
2414                          (if (eq? type 'ptr)
2415                              (if len
2416                                  (do ([len len (fx- len 1)]
2417                                       [disp disp (fx+ disp (constant ptr-bytes))]
2418                                       [ls ls (cons disp ls)])
2419                                    ((fx= len 0) ls))
2420                                  (cons disp ls))
2421                              ls))
2422                   fld))
2423               '()
2424               (or (getprop 'tc '*fields* #f) ($oops 'tc-ptr-offsets "missing fields for tc"))))))
2425  (define align
2426    (lambda (n)
2427      (fxlogand (fx+ n (fx- (constant byte-alignment) 1)) (fx- (constant byte-alignment)))))
2428
2429  (set-who! $compute-size
2430    (rec $compute-size
2431      (case-lambda
2432        [(x maxgen) ($compute-size x maxgen (make-eq-hashtable))]
2433        [(x maxgen size-ht)
2434         (define cookie (cons 'date 'nut)) ; recreate on each call to $compute-size
2435         (define compute-size
2436           (lambda (x)
2437             (if (or ($immediate? x)
2438                     (let ([g ($generation x)])
2439                       (or (not g) (fx> g maxgen))))
2440                 0
2441                 (let ([a (eq-hashtable-cell size-ht x #f)])
2442                   (cond
2443                     [(cdr a) =>
2444                      (lambda (p)
2445                        ; if we find our cookie, return 0 to avoid counting shared structure twice.
2446                        ; otherwise, (car p) must be a cookie from an earlier call to $compute-size,
2447                        ; so return the recorded size
2448                        (if (eq? (car p) cookie)
2449                            0
2450                            (begin
2451                              (set-car! p cookie)
2452                              (cdr p))))]
2453                     [else
2454                      (let ([p (cons cookie 0)])
2455                        (set-cdr! a p)
2456                        (let ([size (really-compute-size x)])
2457                          (set-cdr! p size)
2458                          size))])))))
2459         (define really-compute-size
2460           (lambda (x)
2461             (cond
2462               [(pair? x) (fx+ (constant size-pair) (compute-size (car x)) (compute-size (cdr x)))]
2463               [(symbol? x)
2464                (fx+ (constant size-symbol)
2465                  (compute-size (#3%$top-level-value x))
2466                  (compute-size (property-list x))
2467                  (compute-size ($system-property-list x))
2468                  (compute-size ($symbol-name x)))]
2469               [(vector? x)
2470                (let ([n (vector-length x)])
2471                  (do ([i 0 (fx+ i 1)]
2472                       [size (align (fx+ (constant header-size-vector) (fx* (vector-length x) (constant ptr-bytes))))
2473                         (fx+ size (compute-size (vector-ref x i)))])
2474                    ((fx= i n) size)))]
2475               [(fxvector? x) (align (fx+ (constant header-size-fxvector) (fx* (fxvector-length x) (constant ptr-bytes))))]
2476               [(bytevector? x) (align (fx+ (constant header-size-bytevector) (bytevector-length x)))]
2477               [($record? x)
2478                (let ([rtd ($record-type-descriptor x)])
2479                  (fold-left (lambda (size fld)
2480                               (if (eq? (fld-type fld) 'scheme-object)
2481                                   (fx+ size (compute-size ($object-ref 'scheme-object x (fld-byte fld))))
2482                                   size))
2483                    (fx+ (align (rtd-size rtd)) (compute-size rtd))
2484                    (rtd-flds rtd)))]
2485               [(string? x) (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes))))]
2486               [(box? x) (fx+ (constant size-box) (compute-size (unbox x)))]
2487               [(flonum? x) (constant size-flonum)]
2488               [(bignum? x) (align (fx+ (constant header-size-bignum) (fx* ($bignum-length x) (constant bigit-bytes))))]
2489               [(ratnum? x) (fx+ (constant size-ratnum) (compute-size ($ratio-numerator x)) (compute-size ($ratio-denominator x)))]
2490               [($exactnum? x) (fx+ (constant size-exactnum) (compute-size ($exactnum-real-part x)) (compute-size ($exactnum-imag-part x)))]
2491               [($inexactnum? x) (constant size-inexactnum)]
2492               [(procedure? x)
2493                (if ($continuation? x)
2494                    (if (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag)))
2495                        (constant size-continuation)
2496                        (begin
2497                          ; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate
2498                          ; NB: picture of the size prior to splitting.  will add overhead to eventual invocation of
2499                          ; NB: the continuation as well
2500                          ($split-continuation x 0)
2501                          ; not following RA slot at base of the frame, but this should always hold dounderflow,
2502                          ; which will be in the static generation and therefore ignored anyway after compact heap
2503                          (let ([len ($continuation-stack-length x)])
2504                            (let loop ([i 1]
2505                                       [lpm ($continuation-return-livemask x)]
2506                                       [size (fx+ (constant size-continuation)
2507                                               (align (fx* len (constant ptr-bytes)))
2508                                               (compute-size ($continuation-return-code x))
2509                                               (compute-size ($closure-code x))
2510                                               (compute-size ($continuation-link x))
2511                                               (compute-size ($continuation-winders x)))])
2512                              (if (fx>= i len)
2513                                  size
2514                                  (loop (fx+ i 1) (ash lpm -1) (if (odd? lpm) (fx+ size (compute-size ($continuation-stack-ref x i))) size)))))))
2515                    (let ([n ($closure-length x)])
2516                      (do ([i 0 (fx+ i 1)]
2517                           [size (fx+ (align (fx+ (constant header-size-closure) (fx* n (constant ptr-bytes)))) (compute-size ($closure-code x)))
2518                             (fx+ size (compute-size ($closure-ref x i)))])
2519                        ((fx= i n) size))))]
2520               [($code? x)
2521                (fx+ (align (fx+ (constant header-size-code) ($code-length x)))
2522                  (let ([n ($code-reloc-size x)])
2523                    (let loop ([i 0] [size (align (fx+ (constant header-size-reloc-table) (fx* n (constant ptr-bytes))))] [addr 0])
2524                      (if (fx= i n)
2525                          size
2526                          (let ([r ($get-reloc x i)])
2527                            (and r
2528                                 (let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))])
2529                                   (if (logtest r (constant reloc-extended-format))
2530                                       (let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))])
2531                                         (loop (fx+ i 3)
2532                                           (fx+ size
2533                                             (compute-size
2534                                               ($get-code-obj type x addr ($get-reloc x (fx+ i 1)))))
2535                                           addr))
2536                                       (let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))])
2537                                         (loop (fx+ i 1)
2538                                           (fx+ size
2539                                             (compute-size
2540                                               ($get-code-obj type x addr
2541                                                 (logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask)))))
2542                                           addr)))))))))
2543                  (compute-size ($code-name x))
2544                  (compute-size ($code-info x))
2545                  (compute-size ($code-pinfo* x)))]
2546               [(port? x)
2547                (fx+ (constant size-port)
2548                  (compute-size ($port-handler x))
2549                  (if (input-port? x) (compute-size (port-input-buffer x)) 0)
2550                  (if (output-port? x) (compute-size (port-output-buffer x)) 0)
2551                  (compute-size ($port-info x))
2552                  (compute-size (port-name x)))]
2553               [(thread? x)
2554                (let ([tc ($object-ref 'scheme-object x (constant thread-tc-disp))])
2555                  (fold-left
2556                    (lambda (size disp)
2557                      (fx+ size (compute-size ($object-ref 'scheme-object tc disp))))
2558                    (constant size-thread)
2559                    tc-ptr-offsets))]
2560               [($tlc? x)
2561                (fx+ (constant size-tlc)
2562                  (compute-size ($tlc-ht x))
2563                  (compute-size ($tlc-keyval x))
2564                  (compute-size ($tlc-next x)))]
2565               [($rtd-counts? x) (constant size-rtd-counts)]
2566               [else ($oops who "missing case for ~s" x)])))
2567         ; ensure size-ht isn't counted in the size of any object
2568         (eq-hashtable-set! size-ht size-ht (cons cookie 0))
2569         (compute-size x)])))
2570
2571  (set-who! $compute-composition
2572    (lambda (x maxgen)
2573      (define cookie (cons 'oatmeal 'raisin))
2574      (define seen-ht (make-eq-hashtable))
2575      (define rtd-ht (make-eq-hashtable))
2576      (define-syntax define-counters
2577        (lambda (x)
2578          (syntax-case x ()
2579            [(_ (name-vec count-vec incr!) type ...)
2580             (with-syntax ([(i ...) (enumerate #'(type ...))])
2581               #'(begin
2582                   (define name-vec (vector 'type ...))
2583                   (define count-vec (make-vector (length #'(type ...)) #f))
2584                   (define-syntax incr!
2585                     (syntax-rules (type ...)
2586                       [(_ type size)
2587                        (let ([p (vector-ref count-vec i)])
2588                          (if p
2589                              (begin
2590                                (set-car! p (fx+ (car p) 1))
2591                                (set-cdr! p (fx+ (cdr p) size)))
2592                              (vector-set! count-vec i (cons 1 size))))]
2593                       ...))))])))
2594      (define-counters (type-names type-counts incr!)
2595        pair symbol vector fxvector bytevector string box flonum bignum ratnum exactnum
2596        inexactnum continuation stack procedure code-object reloc-table port thread tlc
2597        rtd-counts)
2598      (define compute-composition!
2599        (lambda (x)
2600          (unless (or ($immediate? x)
2601                      (let ([g ($generation x)])
2602                        (or (not g) (fx> g maxgen))))
2603            (let ([a (eq-hashtable-cell seen-ht x #f)])
2604              (unless (cdr a)
2605                (set-cdr! a #t)
2606                (really-compute-composition! x))))))
2607      (define really-compute-composition!
2608        (lambda (x)
2609          (cond
2610            [(pair? x)
2611             (incr! pair (constant size-pair))
2612             (compute-composition! (car x))
2613             (compute-composition! (cdr x))]
2614            [(symbol? x)
2615             (incr! symbol (constant size-symbol))
2616             (compute-composition! (#3%$top-level-value x))
2617             (compute-composition! (property-list x))
2618             (compute-composition! ($system-property-list x))
2619             (compute-composition! ($symbol-name x))]
2620            [(vector? x)
2621             (incr! vector (align (fx+ (constant header-size-vector) (fx* (vector-length x) (constant ptr-bytes)))))
2622             (vector-for-each compute-composition! x)]
2623            [(fxvector? x) (incr! fxvector (align (fx+ (constant header-size-fxvector) (fx* (fxvector-length x) (constant ptr-bytes)))))]
2624            [(bytevector? x) (incr! bytevector (align (fx+ (constant header-size-bytevector) (bytevector-length x))))]
2625            [($record? x)
2626             (let ([rtd ($record-type-descriptor x)])
2627               (let ([p (eq-hashtable-ref rtd-ht rtd #f)] [size (align (rtd-size rtd))])
2628                 (if p
2629                     (begin
2630                       (set-car! p (fx+ (car p) 1))
2631                       (set-cdr! p (fx+ (cdr p) size)))
2632                     (eq-hashtable-set! rtd-ht rtd (cons 1 size))))
2633               (compute-composition! rtd)
2634               (for-each (lambda (fld)
2635                           (when (eq? (fld-type fld) 'scheme-object)
2636                             (compute-composition! ($object-ref 'scheme-object x (fld-byte fld)))))
2637                 (rtd-flds rtd)))]
2638            [(string? x) (incr! string (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes)))))]
2639            [(box? x)
2640             (incr! box (constant size-box))
2641             (compute-composition! (unbox x))]
2642            [(flonum? x) (incr! flonum (constant size-flonum))]
2643            [(bignum? x) (incr! bignum (align (fx+ (constant header-size-bignum) (fx* ($bignum-length x) (constant bigit-bytes)))))]
2644            [(ratnum? x)
2645             (incr! ratnum (constant size-ratnum))
2646             (compute-composition! ($ratio-numerator x))
2647             (compute-composition! ($ratio-denominator x))]
2648            [($exactnum? x)
2649             (incr! exactnum (constant size-exactnum))
2650             (compute-composition! ($exactnum-real-part x))
2651             (compute-composition! ($exactnum-imag-part x))]
2652            [($inexactnum? x) (incr! inexactnum (constant size-inexactnum))]
2653            [(procedure? x)
2654             (if ($continuation? x)
2655                 (begin
2656                   (incr! continuation (constant size-continuation))
2657                   (unless (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag)))
2658                     ; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate
2659                     ; NB: picture of the continuation counts & sizes prior to splitting.  will add overhead to eventual invocation of
2660                     ; NB: the continuation as well
2661                     ($split-continuation x 0)
2662                     (compute-composition! ($continuation-return-code x))
2663                     (compute-composition! ($closure-code x))
2664                     (compute-composition! ($continuation-link x))
2665                     (compute-composition! ($continuation-winders x))
2666                     (let ([len ($continuation-stack-length x)])
2667                       (incr! stack (align (fx* len (constant ptr-bytes))))
2668                       (let loop ([i 1] [lpm ($continuation-return-livemask x)])
2669                         (unless (fx>= i len)
2670                           (when (odd? lpm) (compute-composition! ($continuation-stack-ref x i)))
2671                           (loop (fx+ i 1) (ash lpm -1)))))))
2672                 (begin
2673                   (compute-composition! ($closure-code x))
2674                   (let ([n ($closure-length x)])
2675                     (incr! procedure (align (fx+ (constant header-size-closure) (fx* n (constant ptr-bytes)))))
2676                     (do ([i 0 (fx+ i 1)])
2677                       ((fx= i n))
2678                       (compute-composition! ($closure-ref x i))))))]
2679            [($code? x)
2680             (incr! code-object (align (fx+ (constant header-size-code) ($code-length x))))
2681             (let ([n ($code-reloc-size x)])
2682               (incr! reloc-table (align (fx+ (constant header-size-reloc-table) (fx* n (constant ptr-bytes)))))
2683               (let loop ([i 0] [addr 0])
2684                 (unless (fx= i n)
2685                   (let ([r ($get-reloc x i)])
2686                     (and r
2687                          (let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))])
2688                            (if (logtest r (constant reloc-extended-format))
2689                                (let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))])
2690                                  (compute-composition! ($get-code-obj type x addr ($get-reloc x (fx+ i 1))))
2691                                  (loop (fx+ i 3) addr))
2692                                (let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))])
2693                                  (compute-composition!
2694                                    ($get-code-obj type x addr
2695                                      (logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask))))
2696                                  (loop (fx+ i 1) addr)))))))))
2697             (compute-composition! ($code-name x))
2698             (compute-composition! ($code-info x))
2699             (compute-composition! ($code-pinfo* x))]
2700            [(port? x)
2701             (incr! port (constant size-port))
2702             (compute-composition! ($port-handler x))
2703             (if (input-port? x) (compute-composition! (port-input-buffer x)) 0)
2704             (if (output-port? x) (compute-composition! (port-output-buffer x)) 0)
2705             (compute-composition! ($port-info x))
2706             (compute-composition! (port-name x))]
2707            [(thread? x)
2708             (incr! thread (constant size-thread))
2709             (let ([tc ($object-ref 'scheme-object x (constant thread-tc-disp))])
2710               (for-each (lambda (disp) (compute-composition! ($object-ref 'scheme-object tc disp))) tc-ptr-offsets))]
2711            [($tlc? x)
2712             (incr! tlc (constant size-tlc))
2713             (compute-composition! ($tlc-ht x))
2714             (compute-composition! ($tlc-keyval x))
2715             (compute-composition! ($tlc-next x))]
2716            [($rtd-counts? x) (incr! rtd-counts (constant size-rtd-counts))]
2717            [else ($oops who "missing case for ~s" x)])))
2718      ; ensure hashtables aren't counted
2719      (eq-hashtable-set! seen-ht seen-ht #t)
2720      (eq-hashtable-set! seen-ht rtd-ht #t)
2721      (compute-composition! x)
2722      (append
2723        (filter cdr (vector->list (vector-map cons type-names type-counts)))
2724        (vector->list
2725          (let-values ([(keys vals) (hashtable-entries rtd-ht)])
2726            (vector-map cons keys vals))))))
2727
2728  (set-who! $make-object-finder
2729    ; pred object maxgen => object-finder procedure that returns
2730    ;                               next object satisfying pred
2731    ;                               or #f, if no object found
2732    (lambda (pred x maxgen)
2733      (let ([seen-ht (make-eq-hashtable)])
2734        (define saved-next-proc
2735          (lambda ()
2736            (find! x '() (lambda () #f))))
2737        (define find!
2738          (lambda (x path next-proc)
2739            (let ([path (cons x path)])
2740              (cond
2741                [(or ($immediate? x) (let ([g ($generation x)]) (or (not g) (fx> g maxgen))))
2742                 (if (pred x)
2743                     (begin (set! saved-next-proc next-proc) path)
2744                     (next-proc))]
2745                [else
2746                  (if (eq-hashtable-ref seen-ht x #f)
2747                      (next-proc) ; detected a loop, so backtrack and keep looking
2748                      (begin
2749                        (eq-hashtable-set! seen-ht x #t) ; mark this node as visited
2750                        (really-find! x path next-proc)))]))))
2751        ; We're visiting this node for the first time
2752        (define really-find!
2753          (lambda (x path next-proc)
2754            (define-syntax construct-proc
2755              (syntax-rules ()
2756                [(_ ?next-proc) ?next-proc]
2757                [(_ ?e ?e* ... ?next-proc)
2758                 (lambda () (find! ?e path (construct-proc ?e* ... ?next-proc)))]))
2759            (let ([next-proc
2760                    (cond
2761                      [(pair? x) (construct-proc (car x) (cdr x) next-proc)]
2762                      [(symbol? x)
2763                       (construct-proc
2764                         (#3%$top-level-value x)
2765                         (property-list x)
2766                         ($system-property-list x)
2767                         ($symbol-name x) next-proc)]
2768                      [(vector? x)
2769                       (let ([n (vector-length x)])
2770                         (let f ([i 0])
2771                           (if (fx= i n)
2772                               next-proc
2773                               (construct-proc (vector-ref x i) (f (fx+ i 1))))))]
2774                      [($record? x)
2775                       (let ([rtd ($record-type-descriptor x)])
2776                         (construct-proc rtd
2777                           (let f ([flds (rtd-flds rtd)])
2778                             (if (null? flds)
2779                                 next-proc
2780                                 (let ([fld (car flds)])
2781                                   (if (eq? (fld-type fld) 'scheme-object)
2782                                       (construct-proc ($object-ref 'scheme-object x (fld-byte fld)) (f (cdr flds)))
2783                                       (f (cdr flds))))))))]
2784                      [(or (fxvector? x) (bytevector? x) (string? x) (flonum? x) (bignum? x)
2785                           ($inexactnum? x) ($rtd-counts? x))
2786                       next-proc]
2787                      [(box? x) (construct-proc (unbox x) next-proc)]
2788                      [(ratnum? x) (construct-proc ($ratio-numerator x) ($ratio-denominator x) next-proc)]
2789                      [($exactnum? x) (construct-proc ($exactnum-real-part x) ($exactnum-imag-part x) next-proc)]
2790                      [(procedure? x)
2791                       (if ($continuation? x)
2792                           (if (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag)))
2793                               next-proc
2794                               (begin
2795                                 ; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate
2796                                 ; NB: picture of the size prior to splitting.  will add overhead to eventual invocation of
2797                                 ; NB: the continuation as well
2798                                 ($split-continuation x 0)
2799                                 ; not following RA slot at base of the frame, but this should always hold dounderflow,
2800                                 ; which will be in the static generation and therefore ignored anyway after compact heap
2801                                 (let ([len ($continuation-stack-length x)])
2802                                   (let loop ([i 1] [lpm ($continuation-return-livemask x)])
2803                                     (if (fx>= i len)
2804                                         (construct-proc ($continuation-return-code x) ($closure-code x) ($continuation-link x) ($continuation-winders x) next-proc)
2805                                         (if (odd? lpm)
2806                                             (construct-proc ($continuation-stack-ref x i) (loop (fx+ i 1) (ash lpm -1)))
2807                                             (loop (fx+ i 1) (ash lpm -1))))))))
2808                           (construct-proc ($closure-code x)
2809                             (let ([n ($closure-length x)])
2810                               (let f ([i 0])
2811                                 (if (fx= i n)
2812                                     next-proc
2813                                     (construct-proc ($closure-ref x i) (f (fx+ i 1))))))))]
2814                      [($code? x)
2815                       (construct-proc ($code-name x) ($code-info x) ($code-pinfo* x)
2816                         (let ([n ($code-reloc-size x)])
2817                           (let loop ([i 0] [addr 0])
2818                             (if (fx= i n)
2819                                 next-proc
2820                                 (let ([r ($get-reloc x i)])
2821                                   (if (not r)
2822                                       next-proc
2823                                       (let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))])
2824                                         (if (logtest r (constant reloc-extended-format))
2825                                             (let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))])
2826                                               (construct-proc ($get-code-obj type x addr ($get-reloc x (fx+ i 1)))
2827                                                 (loop (fx+ i 3) addr)))
2828                                             (let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))])
2829                                               (construct-proc
2830                                                 ($get-code-obj type x addr
2831                                                   (logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask)))
2832                                                 (loop (fx+ i 1) addr)))))))))))]
2833                      [(port? x)
2834                       (construct-proc ($port-handler x) ($port-info x) (port-name x)
2835                         (let ([th (lambda () (if (output-port? x) (construct-proc (port-output-buffer x) next-proc) next-proc))])
2836                           (if (input-port? x) (construct-proc (port-input-buffer x) (th)) (th))))]
2837                      [(thread? x)
2838                       (let ([tc ($object-ref 'scheme-object x (constant thread-tc-disp))])
2839                         (let f ([disp-list tc-ptr-offsets])
2840                           (if (null? disp-list)
2841                               next-proc
2842                               (construct-proc ($object-ref 'scheme-object tc (car disp-list)) (f (cdr tc-ptr-offsets))))))]
2843                      [($tlc? x) (construct-proc ($tlc-ht x) ($tlc-keyval x) ($tlc-next x) next-proc)]
2844                      [else ($oops who "missing case for ~s" x)])])
2845              ; check if this node is what we're looking for
2846              (if (pred x)
2847                  (begin (set! saved-next-proc next-proc) path)
2848                  (next-proc)))))
2849        (rec find-next (lambda () (saved-next-proc)))))))
2850
2851(let ()
2852  (define filter-generation
2853    (lambda (who g)
2854      (unless (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static))
2855        ($oops who "invalid generation ~s" g))
2856      (if (eq? g 'static) (constant static-generation) g)))
2857
2858  (set-who! make-object-finder
2859    (case-lambda
2860      [(pred)
2861       (unless (procedure? pred) ($oops who "~s is not a procedure" pred))
2862       ($make-object-finder pred (oblist) (collect-maximum-generation))]
2863      [(pred x)
2864       (unless (procedure? pred) ($oops who "~s is not a procedure" pred))
2865       ($make-object-finder pred x (collect-maximum-generation))]
2866      [(pred x g)
2867       (unless (procedure? pred) ($oops who "~s is not a procedure" pred))
2868       ($make-object-finder pred x (filter-generation who g))]))
2869
2870  (set-who! compute-size
2871    (case-lambda
2872      [(x) ($compute-size x (collect-maximum-generation))]
2873      [(x g) ($compute-size x (filter-generation who g))]))
2874
2875  (set-who! compute-composition
2876    (case-lambda
2877      [(x) ($compute-composition x (collect-maximum-generation))]
2878      [(x g) ($compute-composition x (filter-generation who g))])))
2879
2880(define object-counts (foreign-procedure "(cs)object_counts" () ptr))
2881)
2882