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 flvector bytevector string record
458              ftype-struct ftype-union ftype-array ftype-bits stencil-vector)
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         [(flvector) flvector-dispatch-table]
497         [(bytevector) bytevector-dispatch-table]
498         [(stencil-vector) stencil-vector-dispatch-table]
499         [(record) record-dispatch-table]
500         [(string) string-dispatch-table]
501         [(box) box-dispatch-table]
502         [(continuation) continuation-dispatch-table]
503         [(procedure) procedure-dispatch-table]
504         [(code) code-dispatch-table]
505         [(port) port-dispatch-table]
506         [(simple)
507          (let ([x ((object) 'value)])
508             (cond
509                [(char? x) char-dispatch-table]
510                [else empty-dispatch-table]))]
511         [(tlc) tlc-dispatch-table]
512         [(phantom-bytevector) phantom-dispatch-table]
513         [(ftype-struct) ftype-struct-dispatch-table]
514         [(ftype-union) ftype-union-dispatch-table]
515         [(ftype-array) ftype-array-dispatch-table]
516         [(ftype-*) ftype-pointer-dispatch-table]
517         [(ftype-bits) ftype-bits-dispatch-table]
518         [(ftype-base) ftype-pointer-dispatch-table]
519         [(ftype-function) ftype-function-dispatch-table]
520         [else empty-dispatch-table])))
521
522(define inspector-read
523   (lambda (ip)
524      (let* ([ip (console-input-port)] [c (read-char ip)])
525         (cond
526            [(eof-object? c)
527             (newline (console-output-port))
528             '("quit")]
529            [(char=? c #\newline)
530             (set-port-bol! (console-output-port) #t)
531             '()]
532            [(char-whitespace? c)
533             (inspector-read ip)]
534            [else
535             (unread-char c ip)
536             (let ([first (inspector-read-command ip)])
537                (cons first (inspector-read-tail ip)))]))))
538
539(define inspector-read-command
540   (lambda (ip)
541      (let ([p (open-output-string)])
542         (let read-letters ()
543            (let ([c (peek-char ip)])
544               (if (and (char? c)
545                        (not (char-numeric? c))
546                        (not (char-whitespace? c)))
547                   (begin (read-char ip)
548                          (write-char c p)
549                          (read-letters))
550                   (get-output-string p)))))))
551
552(define inspector-read-tail
553   (lambda (ip)
554      (let ([c (peek-char ip)])
555         (cond
556            [(char=? c #\newline)
557             (read-char ip)
558             (set-port-bol! (console-output-port) #t)
559             '()]
560            [(or (char-whitespace? c)    ; [(
561                 (memv c '(#\) #\])))
562             (read-char ip)
563             (inspector-read-tail ip)]
564            [else
565             (let ([x (read ip)])
566                (cons x (inspector-read-tail ip)))]))))
567
568(define dispatch
569   (lambda (c t)
570      (let ([handler (or (search-dispatch-table (car c) t)
571                         (search-dispatch-table (car c)
572                                                generic-dispatch-table))])
573         (if handler
574             (apply handler (cdr c))
575             (invalid-command)))))
576
577(define search-dispatch-table
578   (lambda (s t)
579      (and (not (null? t))
580           (let ([first (car t)])
581              (let ([key (car first)])
582                 (if (if (string? key)
583                         (string=? key s)
584                         (or (string=? (car key) s)
585                             (string=? (cdr key) s)))
586                     (caddr first)
587                     (search-dispatch-table s (cdr t))))))))
588
589(define spaces
590   (lambda (n)
591      (if (> n 0)
592          (make-string n #\space)
593          "")))
594
595(define write-to-string
596   (lambda (x)
597      (let ([p (open-output-string)])
598         (x 'write p)
599         (get-output-string p))))
600
601(define short-form-rec
602   (lambda (x limit)
603      (let try ([low 1]
604                [high #f]
605                [r (parameterize ([print-level 0] [print-length 0])
606                      (write-to-string x))])
607         (let ([mid (+ low (if high (quotient (- high low) 2) low))])
608            (if (= mid low)
609                r
610                (let ([s (parameterize ([print-level mid] [print-length mid])
611                            (write-to-string x))])
612                   (cond
613                      [(string=? s r) s]
614                      [(> (string-length s) limit) (try low mid r)]
615                      [else (try mid high s)])))))))
616
617(define short-form-lambda
618   ; x looks like "(lambda vars body)"
619   ; print the "lambda" and all of the vars that fit
620   (lambda (x limit)
621      (let ([first (format "(lambda ~a "                                  ;)
622                           (short-form-rec ((x 'cdr) 'car) (- limit 14)))])
623         (let ([rest (short-form-rec ((x 'cdr) 'cdr)
624                                     (- limit (string-length first)))])
625            (if (and (> (string-length rest) 0)
626                     (char=? (string-ref rest 0) #\())                    ;)
627                 (string-append first (substring rest 1 (string-length rest)))
628                 (short-form-rec x limit))))))
629
630(define short-form
631   (lambda (x limit)
632      (case (x 'type)
633         [(pair)
634          (if (and (eq? ((x 'car) 'type) 'symbol)
635                   (eq? ((x 'car) 'value) 'lambda)
636                   (eq? ((x 'cdr) 'type) 'pair)
637                   (eq? (((x 'cdr) 'cdr) 'type) 'pair))
638              (short-form-lambda x limit)
639              (short-form-rec x limit))]
640         [(string)
641          (let ([s (format "~s"
642                    ; avoid passing format the whole of a large string
643                     (let ([s (x 'value)])
644                       (if (<= (string-length s) limit)
645                           s
646                           (substring s 0 limit))))])
647            (if (<= (string-length s) limit)
648                s
649                (string-append
650                  (substring s 0 (max (- limit 4) 1))
651                  "...\"")))]
652         [else (short-form-rec x limit)])))
653
654(define form
655  (lambda (x used limit)
656    (short-form x (- limit used))))
657
658(define inspector-prompt
659   (lambda ()
660      (let ([obj (form (object) 0 prompt-line-limit)])
661         (fprintf (console-output-port)
662                  "~a~a : "
663                  obj
664                  (spaces (- prompt-line-limit (string-length obj)))))))
665
666(define outer-reset-handler ($make-thread-parameter values))
667
668(define inspector
669  (lambda (last-command)
670    (inspector
671      (let ([saved-state current-state])
672        (parameterize ([reset-handler (call/cc
673                                        (lambda (k)
674                                          (rec f
675                                            (lambda ()
676                                              (clear-output-port (console-output-port))
677                                              (set! current-state saved-state)
678                                              (k f)))))])
679          (let ([ip (console-input-port)])
680            (clear-input-port ip)
681            (inspector-prompt)
682            (let ([cmd (let ([cmd (inspector-read ip)])
683                         (cond
684                           [(null? cmd)
685                            (if (equal? (car last-command) "list")
686                                '("list")
687                                last-command)]
688                           [(number? (car cmd)) (cons "ref" cmd)]
689                           [else cmd]))])
690              (cond
691                [(equal? cmd '("?"))
692                 (let ([t (select-dispatch-table)])
693                   (if (null? t)
694                       (display-options generic-dispatch-table #t)
695                       (display-options t #f)))]
696                [(equal? cmd '("??"))
697                 (display-options generic-dispatch-table #t)]
698                [else
699                 (guard (c [#t (let ([op (console-output-port)])
700                                 (fresh-line op)
701                                 (display-condition c op)
702                                 (newline op)
703                                 (set! current-state saved-state))])
704                   (dispatch cmd (select-dispatch-table)))])
705              cmd)))))))
706
707(define-syntax inspector-print
708  (syntax-rules ()
709    [(_ e)
710     (call-with-values (lambda () e)
711       (case-lambda
712         [(x) (unless (eq? x (void)) (pretty-print x (console-output-port)))]
713         [args (for-each (lambda (x) (pretty-print x (console-output-port))) args)]))]))
714
715(module (inspector-find inspector-find-next)
716  (define down-path
717    (lambda (path)
718      (assert (and (list? path) (>= (length path) 1)))
719      (let f ([path path])
720        (let ([x (car path)] [path (cdr path)])
721          (if (null? path)
722              (assert (eq? x ((object) 'value)))
723              (begin
724                (f path)
725                (down ((object) 'make-me-a-child x) #f)))))))
726  (define inspector-find
727    (lambda (pred gen)
728      (state-find-next-set! current-state (make-object-finder pred ((object) 'value) gen))
729      (let ([path ((state-find-next current-state))])
730        (unless path (inspect-error "Not found"))
731        (down-path path))))
732  (define inspector-find-next
733    (lambda ()
734      (let loop ([state current-state])
735        (cond
736          [(not state) (inspect-error "No current find.")]
737          [(state-find-next state) =>
738           (lambda (find-next)
739             (let ([path (find-next)])
740               (unless path (inspect-error "Not found"))
741               (set! current-state state)
742               (down-path path)))]
743          [else (loop (state-link state))])))))
744
745(define generic-dispatch-table
746 (make-dispatch-table
747
748  [("print" . "p")
749   "pretty-print object"
750   (()
751    (newline (console-output-port))
752    ((object) 'print (console-output-port))
753    (newline (console-output-port)))]
754
755  [("write" . "w")
756   "write object"
757   (()
758    (newline (console-output-port))
759    ((object) 'write (console-output-port))
760    (newline (console-output-port))
761    (newline (console-output-port)))]
762
763  ["size"
764   "recursively compute storage occupied by object"
765   (() (fprintf (console-output-port) "~s\n" ((object) 'size (collect-maximum-generation))))
766   ((g)
767    (require (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static)))
768    (fprintf (console-output-port) "~s\n" ((object) 'size g)))]
769
770  ["find"
771   "find within object, given a predicate"
772   (()
773    (let ([x (waiter-read)])
774      (unless (eof-object? x)
775        (let ([x (eval x)])
776          (unless (procedure? x) (inspect-error "~s is not a procedure" x))
777          (inspector-find x (collect-maximum-generation))))))
778   ((x)
779    (let ([x (eval x)])
780      (unless (procedure? x) (inspect-error "~s is not a procedure" x))
781      (inspector-find x (collect-maximum-generation))))
782   ((x g)
783    (require (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static)))
784    (let ([x (eval x)])
785      (unless (procedure? x) (inspect-error "~s is not a procedure" x))
786      (inspector-find x g)))]
787
788  ["find-next"
789   "repeat find"
790   (()
791    (inspector-find-next))]
792
793  [("up" . "u")
794   "return to [nth] previous level"
795   (() (up))
796   ((n)
797    (range-check n)
798    (let backup ([n n])
799       (unless (= n 0)
800          (up)
801          (backup (- n 1)))))]
802
803  [("top" . "t")
804   "return to initial object"
805   (()
806    (let top ()
807       (let ([next (state-link current-state)])
808          (when next
809             (set! current-state next)
810             (top)))))]
811
812  [("forward" . "f")
813   "move to [nth] next expression"
814   (() (move 1))
815   ((n)
816    (range-check n)
817    (move n))]
818
819  [("back" . "b")
820   "move to [nth] previous expression"
821   (() (move -1))
822   ((n)
823    (range-check n)
824    (move (- n)))]
825
826  ["=>"
827   "send object to procedure"
828   (()
829    (let ([x (waiter-read)])
830       (unless (eof-object? x)
831          (let ([x (eval x)])
832             (unless (procedure? x) (inspect-error "~s is not a procedure" x))
833             (inspector-print (x ((object) 'value)))))))
834   ((x)
835    (let ([x (eval x)])
836       (unless (procedure? x) (inspect-error "~s is not a procedure" x))
837       (inspector-print (x ((object) 'value)))))]
838
839  ["file"
840   "switch to named source file"
841   ((path)
842    (unless (or (string? path) (symbol? path))
843      (inspect-error "invalid path ~s" path))
844    (open-source-file (if (symbol? path) (symbol->string path) path)))]
845
846  ["list"
847   "list the current source file [line [count]]"
848   (() (list-source-file))
849   ((n) (list-source-file n))
850   ((n m) (list-source-file n m))]
851
852  ["files"
853   "show open files"
854   (()
855    (for-each
856      (lambda (sf) (show "~a" (sfile-path sf)))
857      source-files))]
858
859  [("mark" . "m")
860   "mark location [with symbolic mark]"
861   (() (put-mark default-mark))
862   ((m) (put-mark (make-mark m)))]
863
864  [("goto" . "g")
865   "go to marked location [mark]"
866   (() (to-mark default-mark))
867   ((m) (to-mark (make-mark m)))]
868
869  [("new-cafe" . "n")
870   "enter a new cafe"
871   (()
872    (newline (console-output-port))
873    (new-cafe)
874    (newline (console-output-port)))]
875
876  [("quit" . "q")
877   "exit inspector"
878   (()
879    (newline (console-output-port))
880    (exit))]
881
882  [("reset" . "r")
883   "reset scheme"
884   (()
885    (newline (console-output-port))
886    ((outer-reset-handler)))]
887
888  [("abort" . "a")
889   "abort scheme [with exit code n]"
890   (()
891    (newline (console-output-port))
892    (abort))
893   ((x)
894    (newline (console-output-port))
895    (abort x))]
896
897  [("help" . "h")
898   "help"
899   (()
900    (show "
901     An overview of the current object is displayed as part of each
902     prompt.  There are commands for displaying more of an object or
903     inspecting its components.  \"?\" displays type-specific command
904     options and \"??\" displays command options that are always
905     available.  Some commands take parameters, which are entered
906     following the command on the same line.  An empty command line
907     repeats the previous command.  To perform more complex actions,
908     enter the command \"n\", which creates a new top level with access
909     to the usual Scheme environment.  The inspector is resumed upon
910     exit from the new top level.  Enter \"quit\" (or end-of-file) to
911     exit from the inspector.
912"))]
913
914))
915
916(define empty-dispatch-table (make-dispatch-table))
917
918(define pair-dispatch-table
919 (make-dispatch-table
920
921   [("length" . "l")
922    "display list length"
923    (()
924     (apply (lambda (type len)
925               (case type
926                  [(proper) (show "   proper list, length ~d" len)]
927                  [(improper) (show "   improper list, length ~d" len)]
928                  [(circular) (show "   circular list, length ~d" len)]))
929            ((object) 'length)))]
930
931   ["car"
932    "inspect car of pair"
933    (() (ref-list 0))]
934
935   ["cdr"
936    "inspect cdr of pair"
937    (() (down ((object) 'cdr) #f))]
938
939   [("ref" . "r")
940    "inspect [nth] car"
941    (() (ref-list 0))
942    ((n) (ref-list n))]
943
944   ["tail"
945    "inspect [nth] cdr"
946    (() (down ((object) 'cdr) #f))
947    ((n)
948     (range-check n)
949     (let tail ([i n])
950        (unless (= i 0)
951           (unless (type? 'pair (object)) (invalid-movement))
952           (down ((object) 'cdr) #f)
953           (tail (- i 1)))))]
954
955   [("show" . "s")
956     "show [n] elements of list"
957     (() (display-list (cadr ((object) 'length))))
958     ((n)
959      (range-check n)
960      (display-list n))]
961
962))
963
964(define vector-dispatch-table
965 (make-dispatch-table
966
967   [("length" . "l")
968    "display vector length"
969    (() (show "   ~d elements" ((object) 'length)))]
970
971   [("ref" . "r")
972    "inspect [nth] element"
973    (() (ref 0))
974    ((n) (ref n))]
975
976   [("show" . "s")
977     "show [n] elements"
978     (() (display-refs ((object) 'length)))
979     ((n)
980      (range-check n ((object) 'length))
981      (display-refs n))]
982
983))
984
985(define fxvector-dispatch-table
986 (make-dispatch-table
987
988   [("length" . "l")
989    "display fxvector length"
990    (() (show "   ~d elements" ((object) 'length)))]
991
992   [("ref" . "r")
993    "inspect [nth] element"
994    (() (ref 0))
995    ((n) (ref n))]
996
997   [("show" . "s")
998     "show [n] elements"
999     (() (display-refs ((object) 'length)))
1000     ((n)
1001      (range-check n ((object) 'length))
1002      (display-refs n))]
1003
1004))
1005
1006(define flvector-dispatch-table
1007 (make-dispatch-table
1008
1009   [("length" . "l")
1010    "display flvector length"
1011    (() (show "   ~d elements" ((object) 'length)))]
1012
1013   [("ref" . "r")
1014    "inspect [nth] element"
1015    (() (ref 0))
1016    ((n) (ref n))]
1017
1018   [("show" . "s")
1019     "show [n] elements"
1020     (() (display-refs ((object) 'length)))
1021     ((n)
1022      (range-check n ((object) 'length))
1023      (display-refs n))]
1024
1025))
1026
1027(define bytevector-dispatch-table
1028 (make-dispatch-table
1029
1030   [("length" . "l")
1031    "display bytevector length"
1032    (() (show "   ~d elements" ((object) 'length)))]
1033
1034   [("ref" . "r")
1035    "inspect [nth] element"
1036    (() (ref 0))
1037    ((n) (ref n))]
1038
1039   [("show" . "s")
1040     "show [n] elements"
1041     (() (display-refs ((object) 'length)))
1042     ((n)
1043      (range-check n ((object) 'length))
1044      (display-refs n))]
1045
1046))
1047
1048(define stencil-vector-dispatch-table
1049 (make-dispatch-table
1050
1051   [("length" . "l")
1052    "display stencil vector length"
1053    (() (show "   ~d elements" ((object) 'length)))]
1054
1055   [("mask" . "m")
1056    "display stencil vector mask"
1057    (() (show "   #x~x" ((object) 'mask)))]
1058
1059   [("ref" . "r")
1060    "inspect [nth] element"
1061    (() (ref 0))
1062    ((n) (ref n))]
1063
1064   [("show" . "s")
1065     "show [n] elements"
1066     (() (display-refs ((object) 'length)))
1067     ((n)
1068      (range-check n ((object) 'length))
1069      (display-refs n))]
1070
1071))
1072
1073(define ftype-struct-dispatch-table
1074 (make-dispatch-table
1075   ["fields"
1076    "inspect fields"
1077    (() (down ((object) 'fields) #f))]
1078
1079   [("ref" . "r")
1080    "inspect named or nth element"
1081    (() (down ((object) 'ref 0) 0))
1082    ((f) (down ((object) 'ref f) (and (fixnum? f) f)))]
1083
1084   ["set!"
1085    "set named element, if assignable"
1086    ((f)
1087     (let ([x (waiter-read)])
1088       (unless (eof-object? x)
1089         (let ((x (eval x)))
1090           ((object) 'set! f x)))))
1091    ((f v) ((object) 'set! f (eval v)))]
1092
1093   ["ftype"
1094    "inspect the ftype"
1095    (() (down ((object) 'ftype) #f))]
1096
1097   [("show" . "s")
1098    "show contents of struct"
1099    (()
1100     (let ([fields (((object) 'fields) 'value)])
1101       (if (null? fields)
1102           (show "*** struct has no fields ***")
1103           (for-each
1104             (lambda (f i)
1105               (name-label-line-display
1106                 ((object) 'ref i)
1107                 f
1108                 i))
1109             fields
1110             (iota (length fields))))))]))
1111
1112(define ftype-union-dispatch-table
1113 (make-dispatch-table
1114   ["fields"
1115    "inspect fields"
1116    (() (down ((object) 'fields) #f))]
1117
1118   [("ref" . "r")
1119    "inspect named or nth element"
1120    (() (down ((object) 'ref 0) 0))
1121    ((f) (down ((object) 'ref f) (and (fixnum? f) f)))]
1122
1123   ["set!"
1124    "set named element, if assignable"
1125    ((f)
1126     (let ([x (waiter-read)])
1127       (unless (eof-object? x)
1128         (let ((x (eval x)))
1129           ((object) 'set! f x)))))
1130    ((f v) ((object) 'set! f (eval v)))]
1131
1132   ["ftype"
1133    "inspect the ftype"
1134    (() (down ((object) 'ftype) #f))]
1135
1136   [("show" . "s")
1137    "show contents of union"
1138    (()
1139     (let ([fields (((object) 'fields) 'value)])
1140       (if (null? fields)
1141           (show "*** union has no fields ***")
1142           (for-each
1143             (lambda (f i)
1144               (name-label-line-display
1145                 ((object) 'ref i)
1146                 f
1147                 i))
1148             fields
1149             (iota (length fields))))))]))
1150
1151(define ftype-array-dispatch-table
1152 (make-dispatch-table
1153   [("length" . "l")
1154    "display array length"
1155    (() (show "   ~d elements" ((object) 'length)))]
1156
1157   [("ref" . "r")
1158    "inspect [nth] element"
1159    (() (ref 0))
1160    ((n) (ref n))]
1161
1162   ["set!"
1163    "set [nth] element, if assignable"
1164    ((f)
1165     (let ([x (waiter-read)])
1166       (unless (eof-object? x)
1167         (let ((x (eval x)))
1168           ((object) 'set! f x)))))
1169    ((f v) ((object) 'set! f (eval v)))]
1170
1171   ["ftype"
1172    "inspect the ftype"
1173    (() (down ((object) 'ftype) #f))]
1174
1175   [("show" . "s")
1176     "show [n] elements"
1177     (() (display-refs ((object) 'length)))
1178     ((n)
1179      (range-check n ((object) 'length))
1180      (display-refs n))]
1181   ))
1182
1183(define ftype-pointer-dispatch-table
1184 (make-dispatch-table
1185   [("ref" . "r")
1186    "inspect target of pointer"
1187    (() (down ((object) 'ref) #f))
1188    ((n)
1189     (unless (memv n '(* 0)) (invalid-movement))
1190     (down ((object) 'ref) #f))]
1191
1192   ["set!"
1193    "set target of pointer, if assignable"
1194    (()
1195     (let ([x (waiter-read)])
1196       (unless (eof-object? x)
1197         (let ((x (eval x)))
1198           ((object) 'set! x)))))
1199    ((v) ((object) 'set! (eval v)))]
1200
1201   ["ftype"
1202    "inspect ftype of target"
1203    (() (down ((object) 'ftype) #f))]
1204
1205   [("show" . "s")
1206     "show the target"
1207     (() (label-line-display ((object) 'ref) 0))]
1208   ))
1209
1210(define ftype-function-dispatch-table
1211 (make-dispatch-table
1212   ["name"
1213    "inspect foreign-function name"
1214    (() (down ((object) 'name) #f))]
1215
1216   ["address"
1217    "inspect foreign-function address"
1218    (() (down ((object) 'address) #f))]
1219
1220   ["ftype"
1221    "inspect ftype of target"
1222    (() (down ((object) 'ftype) #f))]
1223
1224   [("show" . "s")
1225     "show the target"
1226     (() (label-line-display ((object) 'name) 0)
1227         (label-line-display ((object) 'address) 1))]
1228   ))
1229
1230(define ftype-bits-dispatch-table
1231 (make-dispatch-table
1232   ["fields"
1233    "inspect fields"
1234    (() (down ((object) 'fields) #f))]
1235
1236   [("ref" . "r")
1237    "inspect named or nth element"
1238    (() (down ((object) 'ref 0) 0))
1239    ((f) (down ((object) 'ref f) (and (fixnum? f) f)))]
1240
1241   ["set!"
1242    "set named element, if assignable"
1243    ((f)
1244     (let ([x (waiter-read)])
1245       (unless (eof-object? x)
1246         (let ((x (eval x)))
1247           ((object) 'set! f x)))))
1248    ((f v) ((object) 'set! f (eval v)))]
1249
1250   ["ftype"
1251    "inspect the ftype"
1252    (() (down ((object) 'ftype) #f))]
1253
1254   [("show" . "s")
1255    "show bit fields"
1256    (()
1257     (let ([fields (((object) 'fields) 'value)])
1258       (if (null? fields)
1259           (show "*** no fields ***")
1260           (for-each
1261             (lambda (f i)
1262               (name-label-line-display
1263                 ((object) 'ref i)
1264                 f
1265                 i))
1266             fields
1267             (iota (length fields))))))]))
1268
1269(define record-dispatch-table
1270 (make-dispatch-table
1271
1272   ["fields"
1273    "inspect fields"
1274    (() (down ((object) 'fields) #f))]
1275
1276   ["name"
1277    "inspect record name"
1278    (() (down ((object) 'name) #f))]
1279
1280   ["rtd"
1281    "inspect record-type descriptor"
1282    (() (down ((object) 'rtd) #f))]
1283
1284   [("ref" . "r")
1285    "inspect named or nth element"
1286    ((f) (down ((object) 'ref f) (and (fixnum? f) f)))]
1287
1288   ["set!"
1289    "set named element, if assignable"
1290    ((f)
1291     (let ([x (waiter-read)])
1292       (unless (eof-object? x)
1293         (let ((x (eval x)))
1294           ((object) 'set! f x)))))
1295    ((f v) ((object) 'set! f (eval v)))]
1296
1297   [("show" . "s")
1298     "show contents of record"
1299    (()
1300     (when (and (eq? (subset-mode) 'system)
1301                (record-type-opaque? (((object) 'rtd) 'value)))
1302       (show "*** inspecting opaque record ***"))
1303     (let ([fields (((object) 'fields) 'value)])
1304       (if (null? fields)
1305           (show "*** record has no fields ***")
1306           (for-each
1307             (lambda (f i)
1308               (name-label-line-display
1309                 (if ((object) 'accessible? i)
1310                     ((object) 'ref i)
1311                     (inspect/object "*** inaccessible ***"))
1312                 f
1313                 i))
1314             fields
1315             (iota (length fields))))))]
1316))
1317
1318
1319(define string-dispatch-table
1320 (make-dispatch-table
1321
1322   [("length" . "l")
1323    "display string length"
1324    (() (show "   ~d characters" ((object) 'length)))]
1325
1326   [("ref" . "r")
1327    "inspect [nth] character"
1328    (() (ref 0))
1329    ((n) (ref n))]
1330
1331   [("show" . "s")
1332     "show [n] characters"
1333     (() (display-chars ((object) 'length) charschemecode 5))
1334     ((n)
1335      (range-check n ((object) 'length))
1336      (display-chars n charschemecode 5))]
1337
1338   ["unicode"
1339     "display [n] characters as hexadecimal unicode codes"
1340     (() (display-chars ((object) 'length) unicodehexcode 8))
1341     ((n)
1342      (range-check n ((object) 'length))
1343      (display-chars n unicodehexcode 8))]
1344
1345   ["ascii"
1346     "display [n] characters as hexadecimal ascii codes"
1347     (() (display-chars ((object) 'length) asciihexcode 16))
1348     ((n)
1349      (range-check n ((object) 'length))
1350      (display-chars n asciihexcode 16))]
1351))
1352
1353(define char-dispatch-table
1354 (make-dispatch-table
1355
1356   ["unicode"
1357    "display character as hexadecimal ascii code"
1358     (() (show "   U+~x" (unicodehexcode ((object) 'value))))]
1359
1360   ["ascii"
1361    "display character as hexadecimal ascii code"
1362     (() (show "   ~x" (asciihexcode ((object) 'value))))]
1363
1364))
1365
1366(define box-dispatch-table
1367 (make-dispatch-table
1368
1369   ["unbox"
1370     "inspect contents of box"
1371     (() (down ((object) 'unbox) #f))]
1372
1373   [("ref" . "r")
1374     "inspect contents of box"
1375     (() (down ((object) 'unbox) #f))]
1376
1377   [("show" . "s")
1378     "show contents of box"
1379     (() (label-line-display ((object) 'unbox) 0))
1380     ((n)
1381      (range-check n 0)
1382      (label-line-display ((object) 'unbox) 0))]
1383))
1384
1385
1386(define system-symbol-dispatch-table
1387 (make-dispatch-table
1388
1389   [("ref" . "r")
1390    "inspect value field [n] of symbol"
1391    (()
1392     (down ((object) 'top-level-value) 0))
1393    ((n)
1394     (range-check n 5)
1395     (down ((object)
1396            (case n
1397               [(0) 'top-level-value]
1398               [(1) '$top-level-value]
1399               [(2) 'name]
1400               [(3) 'property-list]
1401               [(4) 'system-property-list]
1402               [(5) 'symbol-hash]))
1403           n))]
1404
1405   [("value" . "v")
1406    "inspect top-level-value of symbol"
1407    (() (down ((object) 'top-level-value) 0))]
1408
1409   [("value-slot" . "vs")
1410    "inspect value slot of symbol"
1411    (() (down ((object) '$top-level-value) 0))]
1412
1413   [("name" . "n")
1414    "inspect name of symbol"
1415    (() (down ((object) 'name) 1))]
1416
1417   [("property-list" . "pl")
1418    "inspect property-list of symbol"
1419    (() (down ((object) 'property-list) 2))]
1420
1421   [("system-property-list" . "spl")
1422    "inspect system property-list of symbol"
1423    (() (down ((object) 'system-property-list) 4))]
1424
1425   [("symbol-hash" . "sh")
1426    "inspect hash code"
1427    (() (down ((object) 'symbol-hash) 5))]
1428
1429   [("show" . "s")
1430     "show fields of symbol"
1431     (()
1432      (name-label-line-display ((object) 'top-level-value) "top-level value" 0)
1433      (name-label-line-display ((object) '$top-level-value) "value slot" 1)
1434      (name-label-line-display ((object) 'name) "name" 2)
1435      (name-label-line-display ((object) 'property-list) "properties" 3)
1436      (name-label-line-display ((object) 'system-property-list) "system properties" 4)
1437      (name-label-line-display ((object) 'symbol-hash) "hash code" 5))]
1438))
1439
1440(define symbol-dispatch-table
1441 (make-dispatch-table
1442
1443   [("ref" . "r")
1444    "inspect value field [n] of symbol"
1445    (()
1446     (down ((object) 'top-level-value) 0))
1447    ((n)
1448     (range-check n 2)
1449     (down ((object)
1450            (case n
1451               [(0) 'top-level-value]
1452               [(1) 'name]
1453               [(2) 'property-list]))
1454           n))]
1455
1456   [("value" . "v")
1457    "inspect top-level-value of symbol"
1458    (() (down ((object) 'top-level-value) 0))]
1459
1460   [("name" . "n")
1461    "inspect name of symbol"
1462    (() (down ((object) 'name) 1))]
1463
1464   [("property-list" . "pl")
1465    "inspect property-list of symbol"
1466    (() (down ((object) 'property-list) 2))]
1467
1468   [("show" . "s")
1469     "show fields of symbol"
1470     (()
1471      (name-label-line-display ((object) 'top-level-value) "top level value" 0)
1472      (name-label-line-display ((object) 'name) "name" 1)
1473      (name-label-line-display ((object) 'property-list) "properties" 2))]
1474))
1475
1476(define procedure-dispatch-table
1477 (make-dispatch-table
1478
1479   [("length" . "l")
1480    "display number of free variables"
1481    (() (show "   ~d free variables" ((object) 'length)))]
1482
1483   [("ref" . "r")
1484    "inspect [nth] free variable"
1485    (() (ref 0))
1486    ((x) (variable-ref x))]
1487
1488   [("set!" . "!")
1489    "set [nth or named] free variable to value, if assignable"
1490    (()
1491     (let ([e (waiter-read)])
1492       (unless (eof-object? e)
1493         (set 0 ((object) 'eval e)))))
1494    ((x)
1495     (let ([e (waiter-read)])
1496       (unless (eof-object? e)
1497         (variable-set x ((object) 'eval e)))))
1498    ((x e) (variable-set x ((object) 'eval e)))]
1499
1500  [("eval" . "e")
1501    "evaluate expression in context of procedure environment"
1502    (()
1503     (let ([x (waiter-read)])
1504       (unless (eof-object? x)
1505         (inspector-print ((object) 'eval x)))))
1506    ((x)
1507     (inspector-print ((object) 'eval x)))]
1508
1509   [("show" . "s")
1510    "show code and free variables"
1511    (()
1512     (let ([source (((object) 'code) 'source)])
1513        (when source (name-line-display source "code")))
1514     (when (> ((object) 'length) 0)
1515        (show "~afree variables:" line-indent)
1516        (display-variable-refs ((object) 'length))))]
1517
1518   [("code" . "c")
1519    "inspect the code for the procedure"
1520    (()
1521     (let ([source (((object) 'code) 'source)])
1522        (if source
1523            (down source #f)
1524            (show "source code not available"))))]
1525
1526   ["file"
1527    "switch to source file containing the procedure"
1528    (() (open-recorded-source-file ((object) 'code)))
1529    ((path)
1530     (unless (or (string? path) (symbol? path))
1531       (inspect-error "invalid path ~s" path))
1532     (open-source-file (if (symbol? path) (symbol->string path) path)))]
1533))
1534
1535(define code-dispatch-table
1536 (make-dispatch-table
1537
1538  [("length" . "l")
1539   "display number of free variables"
1540   (() (show "   ~d free variables" ((object) 'free-count)))]
1541
1542  [("show" . "s")
1543   "show code"
1544   (()
1545    (let ([source ((object) 'source)])
1546       (when source (name-line-display source "code"))))]
1547
1548  [("code" . "c")
1549   "inspect the code"
1550   (()
1551    (let ([source ((object) 'source)])
1552       (if source
1553           (down source #f)
1554           (show "source code not available"))))]
1555
1556  ["file"
1557   "switch to source file containing the procedure"
1558   (() (open-recorded-source-file (object)))
1559   ((path)
1560    (unless (or (string? path) (symbol? path))
1561      (inspect-error "invalid path ~s" path))
1562    (open-source-file (if (symbol? path) (symbol->string path) path)))]
1563))
1564
1565
1566(define continuation-dispatch-table
1567  (let ()
1568    (define reposition
1569      (lambda (incr)
1570        (let ([old-pos ((object) 'pos)])
1571          (unless (fx= old-pos 0) (up))
1572          (let ([pos (fx+ old-pos incr)])
1573            (when (fx>= pos ((object) 'depth)) (invalid-movement))
1574            (if (fx> pos 0)
1575                (let ((link ((object) 'reposition pos)))
1576                  (unless (type? 'continuation link) (invalid-movement))
1577                  (down link #f))
1578                (unless (fx= pos 0) (invalid-movement)))))))
1579
1580    (define continuation-show
1581      (lambda (free?)
1582        (name-line-display ((object) 'link) "continuation")
1583        (let ([source (((object) 'code) 'source)])
1584          (when source (name-line-display source "procedure code")))
1585        (let ([source ((object) 'source)])
1586          (when source (name-line-display source "call code")))
1587        (let ([cp ((object) 'closure)])
1588          (when cp (name-line-display cp "closure")))
1589        (let ([len ((object) (if free? 'length 'frame-length))])
1590          (when (> len 0)
1591            (show "~a~a:" line-indent (if free? "frame and free variables" "frame variables"))
1592            (display-variable-refs len)))))
1593
1594     (make-dispatch-table
1595
1596       [("length" . "l")
1597        "display number of frame and closure variables"
1598        (() (show "   ~d variables" ((object) 'length)))]
1599
1600       ["depth"
1601         "display number of frames in continuation stack"
1602         (() (let ((d ((object) 'depth)))
1603               (show (if (= d 1) "   ~d frame" "   ~d frames") d)))]
1604
1605       [("ref" . "r")
1606        "inspect [named or nth] variable"
1607        (() (ref 0))
1608        ((x) (variable-ref x))]
1609
1610       [("set!" . "!")
1611        "set [named or nth] variable to value, if assignable"
1612        (()
1613         (let ([e (waiter-read)])
1614           (unless (eof-object? e)
1615             (set 0 ((object) 'eval e)))))
1616        ((x)
1617         (let ([e (waiter-read)])
1618           (unless (eof-object? e)
1619             (variable-set x ((object) 'eval e)))))
1620        ((x e) (variable-set x ((object) 'eval e)))]
1621
1622       [("forward" . "f")
1623        "move to [nth] next frame"
1624        (() (reposition 1))
1625        ((pos)
1626         (range-check pos)
1627         (reposition pos))]
1628
1629       [("back" . "b")
1630        "move to [nth] previous frame"
1631        (() (reposition -1))
1632        ((pos)
1633         (range-check pos)
1634         (reposition (fx- pos)))]
1635
1636       [("down" . "d")
1637        "inspect [nth] next frame"
1638        (() (let ((link ((object) 'link)))
1639              (unless (type? 'continuation link) (invalid-movement))
1640              (down link #f)))
1641        ((n)
1642         (range-check n (- ((object) 'depth) 1))
1643         (let ((link ((object) 'link* n)))
1644           (unless (type? 'continuation link) (invalid-movement))
1645           (down link #f)))]
1646
1647       [("closure" . "cp")
1648        "inspect the frame's closure, if any"
1649        (() (let ([cp ((object) 'closure)])
1650              (unless cp (inspect-error "this frame has no closure"))
1651              (down cp #f)))]
1652
1653       [("eval" . "e")
1654        "evaluate expression in context of current frame"
1655        (()
1656         (let ([x (waiter-read)])
1657           (unless (eof-object? x)
1658             (inspector-print ((object) 'eval x)))))
1659        ((x)
1660         (inspector-print ((object) 'eval x)))]
1661
1662       [("show" . "s")
1663        "show frame with free variables"
1664        (() (continuation-show #t))]
1665
1666       [("show-local" . "sl")
1667        "show frame without free variables"
1668        (() (continuation-show #f))]
1669
1670       [("show-frames" . "sf")
1671        "show the next [n] frames"
1672        (() (display-links (most-positive-fixnum)))
1673        ((n)
1674         (range-check n)
1675         (display-links n))]
1676
1677       ["call"
1678         "inspect the code for the pending call"
1679         (()
1680          (let ([source ((object) 'source)])
1681            (if source
1682                (down source #f)
1683                (show "source code not available"))))]
1684
1685       [("code" . "c")
1686        "inspect the code for the pending procedure"
1687        (()
1688         (let ([source (((object) 'code) 'source)])
1689           (if source
1690               (down source #f)
1691               (show "source code not available"))))]
1692
1693       ["file"
1694         "switch to source file containing the pending call"
1695         (() (open-recorded-source-file (object)))
1696         ((path)
1697          (unless (or (string? path) (symbol? path))
1698            (inspect-error "invalid path ~s" path))
1699          (open-source-file (if (symbol? path) (symbol->string path) path)))]
1700
1701       )))
1702
1703(define port-dispatch-table
1704 (make-dispatch-table
1705
1706   [("show" . "s")
1707    "show port contents"
1708    (()
1709     (name-line-display ((object) 'name) "name")
1710     (name-line-display ((object) 'handler) "handler")
1711     (when ((object) 'input?)
1712        (show "~ainput size: ~s" line-indent ((object) 'input-size))
1713        (show "~ainput index: ~s" line-indent ((object) 'input-index)))
1714     (when ((object) 'output?)
1715        (show "~aoutput size: ~s" line-indent ((object) 'output-size))
1716        (show "~aoutput index: ~s" line-indent ((object) 'output-index))))]
1717
1718   ["name"
1719    "inspect port name"
1720    (() (down ((object) 'name) #f))]
1721
1722   ["handler"
1723    "inspect port handler"
1724    (() (down ((object) 'handler) #f))]
1725
1726   [("output-buffer" . "ob")
1727    "inspect output buffer"
1728    (() (if ((object) 'output?)
1729            (down ((object) 'output-buffer) #f)
1730            (show "not an output port")))]
1731
1732   [("input-buffer" . "ib")
1733    "inspect input buffer"
1734    (() (if ((object) 'input?)
1735            (down ((object) 'input-buffer) #f)
1736            (show "not an input port")))]
1737))
1738
1739(define tlc-dispatch-table
1740 (make-dispatch-table
1741
1742   ["keyval"
1743     "inspect keyval field"
1744     (() (down ((object) 'keyval) #f))]
1745
1746   ["ht"
1747     "inspect ht field"
1748     (() (down ((object) 'ht) #f))]
1749
1750   ["next"
1751     "inspect next field"
1752     (() (down ((object) 'next) #f))]
1753
1754   [("ref" . "r")
1755    "inspect named field"
1756    ((x)
1757     (down ((object)
1758            (case x
1759               [(keyval) 'keyval]
1760               [(ht) 'ht]
1761               [(next) 'next]
1762               [else (invalid-command)]))
1763           x))]
1764
1765   [("show" . "s")
1766     "show fields of tlc"
1767     (()
1768      (name-line-display ((object) 'keyval) "keyval")
1769      (name-line-display ((object) 'ht) "ht")
1770      (name-line-display ((object) 'next) "next"))]
1771))
1772
1773(define phantom-dispatch-table
1774 (make-dispatch-table
1775
1776   ["content-size"
1777     "show size field"
1778     (() (name-line-display ((object) 'content-size) "content-size"))]
1779
1780))
1781
1782(set! inspect
1783  (lambda (x)
1784    (let ([t (set-timer 0)])
1785      (call/cc
1786        (lambda (k)
1787          (fluid-let ([current-state (make-state (inspect/object x))]
1788                      [marks (make-eq-hashtable)]
1789                      [source-files '()])
1790             (parameterize ([outer-reset-handler (reset-handler)]
1791                            [exit-handler k]
1792                            [$interrupt reset])
1793               (put-mark default-mark)
1794               (dynamic-wind
1795                 void
1796                 (lambda () (inspector '("?")))
1797                 (lambda () (for-each close-source-file source-files)))))))
1798      (set-timer t))
1799    (void)))
1800
1801)
1802
1803(define inspect/object
1804  (lambda (x)
1805    (define compute-size
1806      (let ([size-ht #f])
1807        (lambda (x g)
1808          (unless (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static))
1809            ($oops 'inspector-object "invalid generation ~s" g))
1810          ; using a common size-ht for a single inspect/object call means:
1811          ;   (inspect (let ([x (list 1 2)]) (set-car! x x) (set-car! (cdr x) x) (set-cdr! (cdr x) x) x))
1812          ;     size => 16
1813          ;     cdr, size => 8
1814          ; might be what we want, might not be
1815          (unless size-ht (set! size-ht (make-eq-hashtable)))
1816          ($compute-size x (if (eq? g 'static) (constant static-generation) g) size-ht))))
1817
1818    (define-syntax make-object-maker
1819      (lambda (x)
1820        (syntax-case x ()
1821          [(_ object-name inits [method args e1 e2 ...] ...)
1822           (andmap identifier? #'(object-name method ...))
1823           #'(lambda inits
1824               (let ([method (lambda args e1 e2 ...)] ...)
1825                 (lambda (m . rest)
1826                   (case m
1827                     [(type) 'object-name]
1828                     [(make-me-a-child) (make-object (car rest))]
1829                     [(method) (#2%apply method rest)]
1830                     ...
1831                     [else ($oops 'inspector-object
1832                             "invalid message ~s to object type ~s"
1833                             m
1834                             'object-name)]))))])))
1835
1836    (define frame-eval
1837      (lambda (vars expr)
1838        (define frame-name
1839          (let ((ls '(%0 %1 %2 %3 %4 %5 %6 %7)))
1840            (let ((n (length ls)))
1841              (lambda (i)
1842                (if (< i n)
1843                    (list-ref ls i)
1844                    (string->symbol (format "%~d" i)))))))
1845        (define ->nongensym
1846          (lambda (name)
1847            (if (gensym? name)
1848                (string->symbol (symbol->string name))
1849                name)))
1850        (let ((n (vector-length vars)))
1851          (eval (let f ((i 0))
1852                  (if (= i n)
1853                      expr
1854                      (let ([var (vector-ref vars i)]
1855                            [body (f (+ i 1))])
1856                        (let ([raw-val (var 'raw-value)]
1857                              [name (var 'name)]
1858                              [fv (frame-name i)]
1859                              [t (gensym)])
1860                          `(let ([,t (quote ,raw-val)])
1861                             (let-syntax ([,fv ,(if (assignable? raw-val)
1862                                                    `(identifier-syntax [id (car ,t)] [(set! id e) (set-car! ,t e)])
1863                                                    `(identifier-syntax
1864                                                       [id ,t]
1865                                                       [(set! id e)
1866                                                        (syntax-error #'id "cannot set non-assigned variable")]))])
1867                               ,(if name `(begin (alias ,(->nongensym name) ,fv) ,body) body)))))))))))
1868
1869    (define make-pair-object
1870      (make-object-maker pair (x)
1871        [value () x]
1872        [car () (make-object (car x))]
1873        [cdr () (make-object (cdr x))]
1874        [length ()
1875          (let ([ht (make-eq-hashtable)])
1876            (let length ([x x] [n 0])
1877              (cond
1878                [(null? x) `(proper ,n)]
1879                [(not (pair? x)) `(improper ,n)]
1880                [else
1881                  (let ([a (eq-hashtable-cell ht x #f)])
1882                    (if (cdr a)
1883                        `(circular ,n)
1884                        (begin (set-cdr! a #t)
1885                          (length (cdr x) (+ n 1)))))])))]
1886        [size (g) (compute-size x g)]
1887        [write (p) (write x p)]
1888        [print (p) (pretty-print x p)]))
1889
1890    (define make-box-object
1891      (make-object-maker box (x)
1892        [value () x]
1893        [unbox () (make-object (unbox x))]
1894        [size (g) (compute-size x g)]
1895        [write (p) (write x p)]
1896        [print (p) (pretty-print x p)]))
1897
1898    (define make-tlc-object
1899      (make-object-maker tlc (x)
1900        [value () x]
1901        [keyval () (make-object ($tlc-keyval x))]
1902        [ht () (make-object ($tlc-ht x))]
1903        [next () (make-object ($tlc-next x))]
1904        [size (g) (compute-size x g)]
1905        [write (p) (write x p)]
1906        [print (p) (pretty-print x p)]))
1907
1908    (define make-vector-object
1909      (make-object-maker vector (x)
1910        [value () x]
1911        [length () (vector-length x)]
1912        [ref (i)
1913          (unless (and (fixnum? i) (fx< -1 i (vector-length x)))
1914            ($oops 'vector-object "invalid index ~s" i))
1915          (make-object (vector-ref x i))]
1916        [size (g) (compute-size x g)]
1917        [write (p) (write x p)]
1918        [print (p) (pretty-print x p)]))
1919
1920    (define make-fxvector-object
1921      (make-object-maker fxvector (x)
1922        [value () x]
1923        [length () (fxvector-length x)]
1924        [ref (i)
1925          (unless (and (fixnum? i) (fx< -1 i (fxvector-length x)))
1926            ($oops 'fxvector-object "invalid index ~s" i))
1927          (make-object (fxvector-ref x i))]
1928        [size (g) (compute-size x g)]
1929        [write (p) (write x p)]
1930        [print (p) (pretty-print x p)]))
1931
1932    (define make-flvector-object
1933      (make-object-maker flvector (x)
1934        [value () x]
1935        [length () (flvector-length x)]
1936        [ref (i)
1937          (unless (and (flonum? i) (fx< -1 i (flvector-length x)))
1938            ($oops 'flvector-object "invalid index ~s" i))
1939          (make-object (flvector-ref x i))]
1940        [size (g) (compute-size x g)]
1941        [write (p) (write x p)]
1942        [print (p) (pretty-print x p)]))
1943
1944    (define make-bytevector-object
1945      (make-object-maker bytevector (x)
1946        [value () x]
1947        [length () (bytevector-length x)]
1948        [ref (i)
1949          (unless (and (fixnum? i) (fx< -1 i (bytevector-length x)))
1950            ($oops 'bytevector-object "invalid index ~s" i))
1951          (make-object (bytevector-u8-ref x i))]
1952        [size (g) (compute-size x g)]
1953        [write (p) (write x p)]
1954        [print (p) (pretty-print x p)]))
1955
1956    (define make-stencil-vector-object
1957      (make-object-maker stencil-vector (x)
1958        [value () x]
1959        [length () (stencil-vector-length x)]
1960        [mask () (stencil-vector-mask x)]
1961        [ref (i)
1962          (unless (and (fixnum? i) (fx< -1 i (stencil-vector-length x)))
1963            ($oops 'stencil-vector-object "invalid index ~s" i))
1964          (make-object (stencil-vector-ref x i))]
1965        [size (g) (compute-size x g)]
1966        [write (p) (write x p)]
1967        [print (p) (pretty-print x p)]))
1968
1969    (define make-phantom-object
1970      (make-object-maker phantom-bytevector (x)
1971        [value () x]
1972        [length () (phantom-bytevector-length x)]
1973        [size (g) (compute-size x g)]
1974        [write (p) (write x p)]
1975        [print (p) (pretty-print x p)]))
1976
1977    (define make-ftype-pointer-object
1978      (lambda (x)
1979        (define (unrecognized-ux ux)
1980          ($oops 'ftype-pointer-object "unrecognized ftype-pointer type ~s" x))
1981        (define (invalid-field-specifier f)
1982          ($oops 'ftype-pointer-object "invalid field specifier ~s" f))
1983        (define (invalid-index f)
1984          ($oops 'ftype-pointer-object "invalid index ~s" f))
1985        (define (get-field f field*)
1986          (cond
1987            [(assq f field*) => cdr]
1988            [(and (fixnum? f) (#%$fxu< f (length field*)))
1989             (cdr (list-ref field* f))]
1990            [else (invalid-field-specifier f)]))
1991        (define (deref x)
1992          (let ([ux ($unwrap-ftype-pointer x)])
1993            (record-case ux
1994              [(struct union array * bits) ignore (make-object x)]
1995              [(base) (type getter setter) (make-object (getter))]
1996              [else (unrecognized-ux ux)])))
1997        (define (deset! who x v)
1998          (let ([ux ($unwrap-ftype-pointer x)])
1999            (record-case ux
2000              [(struct union array bits) ignore ($oops who "cannot assign struct, union, or array")]
2001              [(*) (get-fptr set-fptr!) (set-fptr! who v)]
2002              [(base) (type getter setter) (setter v)]
2003              [else (unrecognized-ux ux)])))
2004        (let ([ux ($unwrap-ftype-pointer x)])
2005          (record-case ux
2006            [(struct) field*
2007             ((make-object-maker ftype-struct (x)
2008                [value () x]
2009                [ftype () (make-object (ftype-pointer-ftype x))]
2010                [fields () (make-object (map (lambda (x) (or (car x) '_)) field*))]
2011                [length () (length field*)]
2012                [ref (f) (deref (get-field f field*))]
2013                [set! (f v) (deset! 'ftype-struct-object (get-field f field*) v)]
2014                [size (g) (compute-size x g)]
2015                [write (p) (write `(ftype struct ...) p)]
2016                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
2017              x)]
2018            [(union) field*
2019             ((make-object-maker ftype-union (x)
2020                [value () x]
2021                [ftype () (make-object (ftype-pointer-ftype x))]
2022                [fields () (make-object (map (lambda (x) (or (car x) '_)) field*))]
2023                [length () (length field*)]
2024                [ref (f) (deref (get-field f field*))]
2025                [set! (f v) (deset! 'ftype-union-object (get-field f field*) v)]
2026                [size (g) (compute-size x g)]
2027                [write (p) (write `(ftype union ...) p)]
2028                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
2029              x)]
2030            [(array) (n get-fptr)
2031             ((make-object-maker ftype-array (x)
2032                [value () x]
2033                [ftype () (make-object (ftype-pointer-ftype x))]
2034                [length () n]
2035                [ref (f)
2036                  (unless (and (integer? f) (exact? f) (#%$fxu< f n))
2037                    (invalid-index f))
2038                  (deref (get-fptr f))]
2039                [set! (f v)
2040                  (unless (and (integer? f) (exact? f) (#%$fxu< f n))
2041                    (invalid-index f))
2042                  (deset! 'ftype-array-object (get-fptr f) v)]
2043                [size (g) (compute-size x g)]
2044                [write (p) (write `(ftype array ...) p)]
2045                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
2046              x)]
2047            [(*) (get-fptr set-fptr!)
2048             ((make-object-maker ftype-* (x)
2049                [value () x]
2050                [ftype () (make-object (ftype-pointer-ftype x))]
2051                [ref () (deref (get-fptr))]
2052                [set! (v) (deset! 'ftype-*-object (get-fptr) v)]
2053                [size (g) (compute-size x g)]
2054                [write (p) (write `(ftype * ...) p)]
2055                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
2056              x)]
2057            [(bits) field*
2058             ((make-object-maker ftype-bits (x)
2059                [value () x]
2060                [ftype () (make-object (ftype-pointer-ftype x))]
2061                [fields () (make-object (map (lambda (x) (or (car x) '_)) field*))]
2062                [length () (length field*)]
2063                [ref (f) (apply (lambda (getter setter) (make-object (getter)))
2064                           (get-field f field*))]
2065                [set! (f v) (apply (lambda (getter setter) (make-object (setter v)))
2066                              (get-field f field*))]
2067                [size (g) (compute-size x g)]
2068                [write (p) (write `(ftype bits ...) p)]
2069                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
2070              x)]
2071            [(base) (type getter setter)
2072             ((make-object-maker ftype-base (x)
2073                [value () x]
2074                [ftype () (make-object (ftype-pointer-ftype x))]
2075                [ref () (make-object (getter))]
2076                [set! (v) (setter v)]
2077                [size (g) (compute-size x g)]
2078                [write (p) (write `(ftype ,type ...) p)]
2079                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
2080              x)]
2081            [(function) (name)
2082             ((make-object-maker ftype-function (x)
2083                [value () x]
2084                [ftype () (make-object (ftype-pointer-ftype x))]
2085                [address () (make-object (ftype-pointer-address x))]
2086                [name () (make-object name)]
2087                [size (g) (compute-size x g)]
2088                [write (p) (write `(ftype function ...) p)]
2089                [print (p) (pretty-print (ftype-pointer->sexpr x) p)])
2090              x)]
2091            [else (unrecognized-ux ux)]))))
2092
2093    (define make-record-object
2094      (lambda (x)
2095        (let* ((rtd ($record-type-descriptor x))
2096               (fields (if (record-type-named-fields? rtd)
2097                           (csv7:record-type-field-names rtd)
2098                           (csv7:record-type-field-indices rtd))))
2099          (define check-field
2100            (lambda (f)
2101              (unless (or (and (symbol? f) (memq f fields))
2102                          (and (fixnum? f) (fx>= f 0) (fx< f (length fields))))
2103                ($oops 'record-object "invalid field specifier ~s" f))))
2104          ((make-object-maker record (x)
2105             [value () x]
2106             [length () (length fields)]
2107             [fields () (make-object fields)]
2108             [accessible? (f)
2109               (check-field f)
2110               (csv7:record-field-accessible? rtd f)]
2111             [mutable? (f)
2112               (check-field f)
2113               (csv7:record-field-mutable? rtd f)]
2114             [name () (make-object (csv7:record-type-name rtd))]
2115             [rtd () (make-object rtd)]
2116             [ref (f)
2117               (check-field f)
2118               (unless (csv7:record-field-accessible? rtd f)
2119                 ($oops 'record-object "field ~s is inaccessible" f))
2120               (make-object ((csv7:record-field-accessor rtd f) x))]
2121             [set! (f v)
2122               (check-field f)
2123               (unless (csv7:record-field-mutable? rtd f)
2124                 ($oops 'record-object "field ~s is immutable" f))
2125               ((csv7:record-field-mutator rtd f) x v)]
2126             [size (g) (compute-size x g)]
2127             [write (p) (write x p)]
2128             [print (p) (pretty-print x p)])
2129           x))))
2130
2131    (define make-string-object
2132      (make-object-maker string (x)
2133        [value () x]
2134        [length () (string-length x)]
2135        [ref (i)
2136          (unless (and (fixnum? i) (< -1 i (string-length x)))
2137            ($oops 'string-object "invalid index ~s" i))
2138          (make-object (string-ref x i))]
2139        [size (g) (compute-size x g)]
2140        [write (p) (write x p)]
2141        [print (p) (pretty-print x p)]))
2142
2143    (define make-simple-object
2144      (make-object-maker simple (x)
2145        [value () x]
2146        [size (g) (compute-size x g)]
2147        [write (p) (write x p)]
2148        [print (p) (pretty-print x p)]))
2149
2150    (define make-unbound-object
2151      (make-object-maker unbound (x)
2152        [value () x]
2153        [size (g) (compute-size x g)]
2154        [write (p) (write x p)]
2155        [print (p) (pretty-print x p)]))
2156
2157    (define make-procedure-object
2158      (lambda (x)
2159        (real-make-procedure-object x (list->vector (make-procedure-vars x)))))
2160
2161    (define real-make-procedure-object
2162      (make-object-maker procedure (x vars)
2163        [value () x]
2164        [length () (vector-length vars)]
2165        [ref (i)
2166          (unless (and (fixnum? i) (fx< -1 i (vector-length vars)))
2167            ($oops 'procedure-object "invalid index ~s" i))
2168          (vector-ref vars i)]
2169        [eval (x) (frame-eval vars x)]
2170        [code () (make-object ($closure-code x))]
2171        [size (g) (compute-size x g)]
2172        [write (p) (write x p)]
2173        [print (p) (pretty-print x p)]))
2174
2175    (define make-procedure-vars
2176      (lambda (x)
2177        (include "types.ss")
2178        (let ([code ($closure-code x)])
2179          (let ([info ($code-info code)]
2180                [len ($code-free-count code)])
2181            (let ([free (and (code-info? info) (code-info-free info))])
2182              (unless (or (not free) (fx= (vector-length free) len))
2183                ($oops 'inspector "invalid info structure ~s" info))
2184              (let vars ([i 0])
2185                (if (= i len)
2186                    '()
2187                    (cons (make-variable-object
2188                            ($closure-ref x i)
2189                            (and free (vector-ref free i)))
2190                      (vars (+ i 1))))))))))
2191
2192    (define assignable?
2193      (lambda (raw-val)
2194        (and (pair? raw-val) ($unbound-object? (cdr raw-val)))))
2195
2196    (define make-variable-object
2197      (make-object-maker variable (x name)
2198        [name () name]
2199        [assignable? () (assignable? x)]
2200        [raw-value () x]
2201        [ref () (make-object
2202                  (if (assignable? x)
2203                      (car x)
2204                      x))]
2205        [set! (v) (make-object
2206                    (if (assignable? x)
2207                        (set-car! x v)
2208                        ($oops 'variable-object "unassignable variable")))]
2209        [size (g)
2210         (if (assignable? x)
2211             (fx+ (constant size-pair) (compute-size (car x) g))
2212             (compute-size x g))]
2213        [write (p) (display "#<variable>" p)]
2214        [print (p) (display "#<variable>" p) (newline p)]))
2215
2216    (define get-reloc-objs
2217      (foreign-procedure "(cs)s_get_reloc"
2218        (scheme-object boolean) scheme-object))
2219
2220    (module (get-code-src get-code-sexpr)
2221      (include "types.ss")
2222      (define get-code-src
2223        (lambda (x)
2224          (let ([info ($code-info x)])
2225            (and (code-info? info) (code-info-src info)))))
2226      (define get-code-sexpr
2227        (lambda (x)
2228          (let ([info ($code-info x)])
2229            (and (code-info? info) (code-info-sexpr info))))))
2230
2231    (define make-code-object
2232      (make-object-maker code (x)
2233        [value () x]
2234        [name () ($code-name x)]
2235        [info () (make-object ($code-info x))]
2236        [free-count () ($code-free-count x)]
2237        [arity-mask () ($code-arity-mask x)]
2238        [source ()
2239          (cond
2240            [(get-code-sexpr x) => make-object]
2241            [else #f])]
2242        [source-path () (return-source (get-code-src x))]
2243        [source-object () (get-code-src x)]
2244        [reloc () (make-object (get-reloc-objs x #f))]
2245        [reloc+offset () (make-object (get-reloc-objs x #t))]
2246        [size (g) (compute-size x g)]
2247        [write (p) (write x p)]
2248        [print (p) (pretty-print x p)]))
2249
2250    (define return-source
2251      (lambda (src)
2252        (include "types.ss")
2253        (if src
2254            (call-with-values
2255              (lambda () ((current-locate-source-object-source) src #t #f))
2256              (case-lambda
2257                [() (let ([sfd (source-sfd src)] [fp (source-bfp src)])
2258                      (values (source-file-descriptor-name sfd) fp))]
2259                [(path line char) (values path line char)]))
2260            (values))))
2261
2262    (define-who make-continuation-object
2263      (lambda (x pos)
2264        (include "types.ss")
2265        (define find-rpi
2266          (lambda (offset rpis)
2267            (let f ([start 0] [end (fx1- (vector-length rpis))])
2268              (if (fx< end start)
2269                  #f
2270                  (let* ([curr (fx+ (fx/ (fx- end start) 2) start)]
2271                         [rpi (vector-ref rpis curr)]
2272                         [rpi-offset (rp-info-offset rpi)])
2273                    (cond
2274                      [(fx= offset rpi-offset) rpi]
2275                      [(fx< offset rpi-offset) (f start (fx1- curr))]
2276                      [else  (f (fx1+ curr) end)]))))))
2277        ($split-continuation x 0)
2278        (let ([info ($code-info ($continuation-return-code x))]
2279              [offset ($continuation-return-offset x)]
2280              [len ($continuation-stack-length x)]
2281              [lpm ($continuation-return-livemask x)])
2282          (cond
2283            [(and (code-info? info) (code-info-rpis info) (find-rpi offset (code-info-rpis info))) =>
2284             (lambda (rpi)
2285               (let ([cookie '(chocolate . chip)])
2286                 (let ([vals (make-vector len cookie)] [vars (make-vector len '())] [live (code-info-live info)])
2287                   ; fill vals based on live-pointer mask
2288                   (let f ([i 1] [lpm lpm])
2289                     (unless (>= i len)
2290                       (when (odd? lpm)
2291                         (vector-set! vals (fx1- i) ($continuation-stack-ref x i)))
2292                       (f (fx1+ i) (ash lpm -1))))
2293                   ; fill vars based on code-info variable mask
2294                   (let f ([i 0] [mask (rp-info-mask rpi)])
2295                     (unless (eqv? mask 0)
2296                       (when (odd? mask)
2297                         (let ([p (vector-ref live i)])
2298                           (let ([index (fx1- (cdr p))])
2299                             (vector-set! vars index (cons (car p) (vector-ref vars index))))))
2300                       (f (+ i 1) (ash mask -1))))
2301                   ; create return vector
2302                   (with-values
2303                     (let f ([i 0] [count 0] [cp #f] [cpvar* '()])
2304                       (if (fx= i len)
2305                           (if cp
2306                               (let ([v (let f ([count count] [cpvar* cpvar*])
2307                                          (if (null? cpvar*)
2308                                              (make-vector count)
2309                                              (let ([v (f (fx+ count 1) (cdr cpvar*))])
2310                                                (vector-set! v count (car cpvar*))
2311                                                v)))])
2312                                 (values v count cp))
2313                               (values (make-vector count) count cp))
2314                           (let ([obj (vector-ref vals i)] [var* (vector-ref vars i)])
2315                             (cond
2316                               [(and (eq? obj cookie)
2317                                     (or (null? var*)
2318                                         ;; unboxed variable?
2319                                         (not (and (pair? var*) (box? (car var*)) (null? (cdr var*))))))
2320                                (unless (null? var*)
2321                                  ($oops who "expected value for ~s but it was not in lpm" (car var*)))
2322                                (f (fx1+ i) count cp cpvar*)]
2323                               [(null? var*)
2324                                (let-values ([(v frame-count cp) (f (fx1+ i) (fx1+ count) cp cpvar*)])
2325                                  (vector-set! v count (make-variable-object obj #f))
2326                                  (values v frame-count cp))]
2327                               [else
2328                                 (let g ([var* var*] [count count] [cp cp] [cpvar* cpvar*])
2329                                   (if (null? var*)
2330                                       (f (fx1+ i) count cp cpvar*)
2331                                       (let ([var (car var*)])
2332                                         (if (eq? var cpsymbol)
2333                                             (g (cdr var*) count obj (if (procedure? obj) (make-procedure-vars obj) '()))
2334                                             (cond
2335                                               [(pair? var) ; closure environment represented as a pair
2336                                                (unless (pair? obj)
2337                                                  ($oops who "expected pair value for paired environment, not ~s" obj))
2338                                                (g (cdr var*) count obj (list
2339                                                                          (make-variable-object (car obj) (car var))
2340                                                                          (make-variable-object (cdr obj) (cdr var))))]
2341                                               [(vector? var) ; closure environment represented as a vector
2342                                                (unless (vector? obj)
2343                                                  ($oops who "expected vector value for vector environment, not ~s" obj))
2344                                                (g (cdr var*) count obj (map (lambda (obj var) (make-variable-object obj var))
2345                                                                          (vector->list obj)
2346                                                                          (vector->list var)))]
2347                                               [else
2348                                                 (let-values ([(v frame-count cp) (g (cdr var*) (fx1+ count) cp cpvar*)])
2349                                                   (vector-set! v count (cond
2350                                                                          [(box? var)
2351                                                                           ;; unboxed variable
2352                                                                           (make-variable-object '<unboxed-flonum> (unbox var))]
2353                                                                          [else
2354                                                                           (make-variable-object obj var)]))
2355                                                   (values v frame-count cp))])))))]))))
2356                     (lambda (v frame-count cp)
2357                       (real-make-continuation-object x (rp-info-src rpi) (rp-info-sexpr rpi) cp v frame-count pos))))))]
2358            [else
2359              (let ([v (list->vector
2360                         (let f ([i 1] [lpm lpm])
2361                           (cond
2362                             [(>= i len) '()]
2363                             [(odd? lpm)
2364                              (cons (make-variable-object ($continuation-stack-ref x i) #f)
2365                                (f (fx1+ i) (ash lpm -1)))]
2366                             [else (f (fx1+ i) (ash lpm -1))])))])
2367                (real-make-continuation-object x #f #f #f v (vector-length v) pos))]))))
2368
2369    (define real-make-continuation-object
2370      (let ((continuation-depth
2371              (foreign-procedure "(cs)continuation_depth" (scheme-object)
2372                iptr)))
2373        (make-object-maker continuation (x src sexpr cp vars frame-count pos)
2374          [value () x]
2375          [length () (vector-length vars)]
2376          [closure () (and cp (make-object cp))]
2377          [frame-length () frame-count]
2378          [depth () (continuation-depth x)]
2379          [ref (i)
2380            (unless (and (fixnum? i) (fx< -1 i (vector-length vars)))
2381              ($oops 'continuation-object "invalid index ~s" i))
2382            (vector-ref vars i)]
2383          [pos () pos]
2384          [reposition (pos)
2385            (let ((k (and (fixnum? pos) (fx> pos 0) ($split-continuation x pos))))
2386              (unless k ($oops 'continuation-object "invalid position ~s" pos))
2387              (make-continuation-object k pos))]
2388          [link () (make-object ($continuation-link x))]
2389          [link* (i)
2390            (let ((k (and (fixnum? i) (fx>= i 0) ($split-continuation x i))))
2391              (unless k ($oops 'continuation-object "invalid link* depth ~s" i))
2392              (make-object k))]
2393          [eval (x) (frame-eval vars x)]
2394          [code () (make-object ($continuation-return-code x))]
2395          [source () (and sexpr (make-object sexpr))]
2396          [source-object () src]
2397          [source-path () (return-source src)]
2398          [size (g) (compute-size x g)]
2399          [write (p) (write x p)]
2400          [print (p) (pretty-print x p)])))
2401
2402    (define make-port-object
2403      (make-object-maker port (x)
2404        [value () x]
2405        [input? () (input-port? x)]
2406        [output? () (output-port? x)]
2407        [binary? () (binary-port? x)]
2408        [closed? () (port-closed? x)]
2409        [handler () (make-object ($port-handler x))]
2410        [output-buffer () (and (output-port? x)
2411                               (make-object
2412                                 (if (textual-port? x)
2413                                     (textual-port-output-buffer x)
2414                                     (binary-port-output-buffer x))))]
2415        [output-size () (and (output-port? x)
2416                             (if (textual-port? x)
2417                                 (textual-port-output-size x)
2418                                 (binary-port-output-size x)))]
2419        [output-index () (and (output-port? x)
2420                              (if (textual-port? x)
2421                                  (textual-port-output-index x)
2422                                  (binary-port-output-index x)))]
2423        [input-buffer () (and (input-port? x)
2424                              (make-object
2425                                (if (textual-port? x)
2426                                    (textual-port-input-buffer x)
2427                                    (binary-port-input-buffer x))))]
2428        [input-size () (and (input-port? x)
2429                            (if (textual-port? x)
2430                                (textual-port-input-size x)
2431                                (binary-port-input-size x)))]
2432        [input-index () (and (input-port? x)
2433                             (if (textual-port? x)
2434                                 (textual-port-input-index x)
2435                                 (binary-port-input-index x)))]
2436        [info () (make-object ($port-info x))]
2437        [name () (make-object (port-name x))]
2438        [size (g) (compute-size x g)]
2439        [write (p) (write x p)]
2440        [print (p) (pretty-print x p)]))
2441
2442    (define make-symbol-object
2443      (make-object-maker symbol (x)
2444        [value () x]
2445        [gensym? () (gensym? x)]
2446        [top-level-value ()
2447          (if (top-level-bound? x)
2448              (make-object (top-level-value x))
2449              (make-object ($unbound-object)))]
2450        [$top-level-value ()
2451          (if ($top-level-bound? x)
2452              (make-object ($top-level-value x))
2453              (make-object ($unbound-object)))]
2454        [system-property-list () (make-object ($system-property-list x))]
2455        [symbol-hash () (make-object ($symbol-hash x))]
2456        [name () (make-object (symbol->string x))]
2457        [property-list () (make-object ($symbol-property-list x))]
2458        [size (g) (compute-size x g)]
2459        [write (p) (write x p)]
2460        [print (p) (pretty-print x p)]))
2461
2462    (define make-object
2463      (lambda (x)
2464        (cond
2465          [(pair? x) (make-pair-object x)]
2466          [(symbol? x) (make-symbol-object x)]
2467          [(vector? x) (make-vector-object x)]
2468          [(fxvector? x) (make-fxvector-object x)]
2469          [(flvector? x) (make-flvector-object x)]
2470          [(bytevector? x) (make-bytevector-object x)]
2471          [(stencil-vector? x) (make-stencil-vector-object x)]
2472          ; ftype-pointer? test must come before record? test
2473          [($ftype-pointer? x) (make-ftype-pointer-object x)]
2474          [(or (record? x) (and (eq? (subset-mode) 'system) ($record? x)))
2475           (make-record-object x)]
2476          [(string? x) (make-string-object x)]
2477          [(box? x) (make-box-object x)]
2478          [(procedure? x)
2479           (if ($continuation? x)
2480               (if (= ($continuation-stack-length x)
2481                      (constant unscaled-shot-1-shot-flag))
2482                   (make-simple-object x)
2483                   (make-continuation-object x 0))
2484               (make-procedure-object x))]
2485          [($code? x) (make-code-object x)]
2486          [(port? x) (make-port-object x)]
2487          [($unbound-object? x) (make-unbound-object x)]
2488          [($tlc? x) (make-tlc-object x)]
2489          [(phantom-bytevector? x) (make-phantom-object x)]
2490          [else (make-simple-object x)])))
2491
2492    (make-object x)))
2493
2494(let ()
2495  (define rtd-size (csv7:record-field-accessor #!base-rtd 'size))
2496  (define rtd-flds (csv7:record-field-accessor #!base-rtd 'flds))
2497  (define $get-code-obj (foreign-procedure "(cs)get_code_obj" (int ptr iptr iptr) ptr))
2498  (define $code-reloc-size
2499    (lambda (x)
2500      (let ([reloc-table ($object-ref 'scheme-object x (constant code-reloc-disp))])
2501        (if (eqv? reloc-table 0)
2502            0
2503            ($object-ref 'iptr reloc-table (constant reloc-table-size-disp))))))
2504  (define $code-length
2505    (lambda (x)
2506      ($object-ref 'iptr x (constant code-length-disp))))
2507  (define $get-reloc
2508    (lambda (x i)
2509      (let ([reloc-table ($object-ref 'scheme-object x (constant code-reloc-disp))])
2510        (and (not (eqv? reloc-table 0))
2511             ($object-ref 'uptr reloc-table
2512               (fx+ (constant reloc-table-data-disp)
2513                 (fx* i (constant ptr-bytes))))))))
2514  (define-syntax tc-ptr-offsets
2515    (lambda (x)
2516      #`'#,(datum->syntax #'*
2517             (fold-left
2518               (lambda (ls fld)
2519                 (apply (lambda (name type disp len)
2520                          (if (eq? type 'ptr)
2521                              (if len
2522                                  (do ([len len (fx- len 1)]
2523                                       [disp disp (fx+ disp (constant ptr-bytes))]
2524                                       [ls ls (cons disp ls)])
2525                                    ((fx= len 0) ls))
2526                                  (cons disp ls))
2527                              ls))
2528                   fld))
2529               '()
2530               (or (getprop 'tc '*fields* #f) ($oops 'tc-ptr-offsets "missing fields for tc"))))))
2531  (define align
2532    (lambda (n)
2533      (fxlogand (fx+ n (fx- (constant byte-alignment) 1)) (fx- (constant byte-alignment)))))
2534
2535  (define (thread->stack-objects thread)
2536    (with-tc-mutex
2537     (let ([tc ($thread-tc thread)])
2538       (cond
2539        [(eqv? tc 0)
2540         ;; Thread terminated
2541         '()]
2542        [(zero? ($object-ref 'integer-32 tc (constant tc-active-disp)))
2543         ;; Inactive, so we can traverse it while holding the tc mutex
2544         (let ([stack ($object-ref 'scheme-object tc (constant tc-scheme-stack-disp))])
2545           (let loop ([frame ($object-ref 'scheme-object tc (constant tc-sfp-disp))] [x* '()])
2546             (cond
2547              [(fx= frame stack)
2548               x*]
2549              [else
2550               (let* ([ret ($object-ref 'scheme-object frame 0)]
2551                      [mask+size+mode ($object-ref 'iptr ret (constant compact-return-address-mask+size+mode-disp))]
2552                      [compact? (fxlogtest mask+size+mode (constant compact-header-mask))]
2553                      [size (if (not compact?)
2554                                ($object-ref 'scheme-object ret (constant return-address-frame-size-disp))
2555                                (fxand (fxsrl mask+size+mode (constant compact-frame-words-offset))
2556                                       (constant compact-frame-words-mask)))]
2557                      [livemask (if (not compact?)
2558                                    ($object-ref 'scheme-object ret (constant return-address-livemask-disp))
2559                                    (fxsrl mask+size+mode (constant compact-frame-mask-offset)))]
2560                      [next-frame (fx- frame size)])
2561                 (let frame-loop ([p (fx+ next-frame 1)] [livemask livemask] [x* x*])
2562                   (if (eqv? livemask 0)
2563                       (loop next-frame x*)
2564                       (frame-loop (fx+ p 1)
2565                                   (bitwise-arithmetic-shift-right livemask 1)
2566                                   (if (bitwise-bit-set? livemask 0)
2567                                       (cons ($object-ref 'scheme-object p 0) x*)
2568                                       x*)))))])))]
2569        [else
2570         ;; Can't inspect active thread
2571         '()]))))
2572
2573  (define (thread->objects thread)
2574    ;; Get immediate content while holding the tc mutex to be sure
2575    ;; that the thread doesn't terminate while getting its content
2576    (with-tc-mutex
2577     (let ([tc ($thread-tc thread)])
2578       (cond
2579        [(eqv? tc 0)
2580         ;; Thread terminated
2581         '()]
2582        [else
2583         (map (lambda (disp) ($object-ref 'scheme-object tc disp))
2584              tc-ptr-offsets)]))))
2585
2586  (set-who! $compute-size
2587    (rec $compute-size
2588      (case-lambda
2589        [(x maxgen) ($compute-size x maxgen (make-eq-hashtable))]
2590        [(x maxgen size-ht)
2591         (define cookie (cons 'date 'nut)) ; recreate on each call to $compute-size
2592         (define compute-size
2593           (lambda (x)
2594             (if (or (fixmediate? x)
2595                     (let ([g ($generation x)])
2596                       (or (not g) (fx> g maxgen))))
2597                 0
2598                 (let ([a (eq-hashtable-cell size-ht x #f)])
2599                   (cond
2600                     [(cdr a) =>
2601                      (lambda (p)
2602                        ; if we find our cookie, return 0 to avoid counting shared structure twice.
2603                        ; otherwise, (car p) must be a cookie from an earlier call to $compute-size,
2604                        ; so return the recorded size
2605                        (if (eq? (car p) cookie)
2606                            0
2607                            (begin
2608                              (set-car! p cookie)
2609                              (cdr p))))]
2610                     [else
2611                      (let ([p (cons cookie 0)])
2612                        (set-cdr! a p)
2613                        (let ([size (really-compute-size x)])
2614                          (set-cdr! p size)
2615                          size))])))))
2616         (define really-compute-size
2617           (lambda (x)
2618             (cond
2619               [(pair? x)
2620                (cond
2621                  [(ephemeron-pair? x)
2622                   (fx+ (constant size-ephemeron) (compute-size (car x)) (compute-size (cdr x)))]
2623                  [else
2624                   (fx+ (constant size-pair) (compute-size (car x)) (compute-size (cdr x)))])]
2625               [(symbol? x)
2626                (fx+ (constant size-symbol)
2627                  (compute-size (#3%$top-level-value x))
2628                  (compute-size ($symbol-property-list x))
2629                  (compute-size ($system-property-list x))
2630                  (compute-size ($symbol-name x)))]
2631               [(vector? x)
2632                (let ([n (vector-length x)])
2633                  (do ([i 0 (fx+ i 1)]
2634                       [size (align (fx+ (constant header-size-vector) (fx* (vector-length x) (constant ptr-bytes))))
2635                         (fx+ size (compute-size (vector-ref x i)))])
2636                    ((fx= i n) size)))]
2637               [(fxvector? x) (align (fx+ (constant header-size-fxvector) (fx* (fxvector-length x) (constant ptr-bytes))))]
2638               [(flvector? x) (align (fx+ (constant header-size-flvector) (fx* (flvector-length x) (constant ptr-bytes))))]
2639               [(bytevector? x) (align (fx+ (constant header-size-bytevector) (bytevector-length x)))]
2640               [(stencil-vector? x)
2641                (let ([n (stencil-vector-length x)])
2642                  (do ([i 0 (fx+ i 1)]
2643                       [size (align (fx+ (constant header-size-stencil-vector) (fx* (stencil-vector-length x) (constant ptr-bytes))))
2644                         (fx+ size (compute-size (stencil-vector-ref x i)))])
2645                    ((fx= i n) size)))]
2646               [($record? x)
2647                (let ([rtd ($record-type-descriptor x)])
2648                  (let ([flds (rtd-flds rtd)])
2649                    (cond
2650                     [(fixnum? flds)
2651                      (let loop ([i 0] [size (fx+ (align (rtd-size rtd)) (compute-size rtd))])
2652                        (cond
2653                         [(fx= i flds) size]
2654                         [else (loop (fx+ i 1)
2655                                     (fx+ size (compute-size ($record-ref x i))))]))]
2656                     [else
2657                      (let loop ([size (fx+ (align (rtd-size rtd)) (compute-size rtd))] [flds flds])
2658                        (cond
2659                          [(null? flds) size]
2660                          [else
2661                           (let ([fld (car flds)])
2662                             (loop (if (eq? (fld-type fld) 'scheme-object)
2663                                       (fx+ size (compute-size ($object-ref 'scheme-object x (fld-byte fld))))
2664                                       size)
2665                                   (cdr flds)))]))])))]
2666               [(string? x) (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes))))]
2667               [(box? x) (fx+ (constant size-box) (compute-size (unbox x)))]
2668               [(flonum? x) (constant size-flonum)]
2669               [(bignum? x) (align (fx+ (constant header-size-bignum) (fx* ($bignum-length x) (constant bigit-bytes))))]
2670               [(ratnum? x) (fx+ (constant size-ratnum) (compute-size ($ratio-numerator x)) (compute-size ($ratio-denominator x)))]
2671               [($exactnum? x) (fx+ (constant size-exactnum) (compute-size ($exactnum-real-part x)) (compute-size ($exactnum-imag-part x)))]
2672               [($inexactnum? x) (constant size-inexactnum)]
2673               [(procedure? x)
2674                (if ($continuation? x)
2675                    (if (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag)))
2676                        (constant size-continuation)
2677                        (begin
2678                          ; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate
2679                          ; NB: picture of the size prior to splitting.  will add overhead to eventual invocation of
2680                          ; NB: the continuation as well
2681                          ($split-continuation x 0)
2682                          ; not following RA slot at base of the frame, but this should always hold dounderflow,
2683                          ; which will be in the static generation and therefore ignored anyway after compact heap
2684                          (let ([len ($continuation-stack-length x)])
2685                            (let loop ([i 1]
2686                                       [lpm ($continuation-return-livemask x)]
2687                                       [size (fx+ (constant size-continuation)
2688                                               (align (fx* len (constant ptr-bytes)))
2689                                               (compute-size ($continuation-return-code x))
2690                                               (compute-size ($closure-code x))
2691                                               (compute-size ($continuation-link x))
2692                                               (compute-size ($continuation-winders x))
2693                                               (compute-size ($continuation-attachments x)))])
2694                              (if (fx>= i len)
2695                                  size
2696                                  (loop (fx+ i 1) (ash lpm -1) (if (odd? lpm) (fx+ size (compute-size ($continuation-stack-ref x i))) size)))))))
2697                    (let ([n ($closure-length x)])
2698                      (do ([i 0 (fx+ i 1)]
2699                           [size (fx+ (align (fx+ (constant header-size-closure) (fx* n (constant ptr-bytes)))) (compute-size ($closure-code x)))
2700                             (fx+ size (compute-size ($closure-ref x i)))])
2701                        ((fx= i n) size))))]
2702               [($code? x)
2703                (fx+ (align (fx+ (constant header-size-code) ($code-length x)))
2704                  (let ([n ($code-reloc-size x)])
2705                    (let loop ([i 0] [size (align (fx+ (constant header-size-reloc-table) (fx* n (constant ptr-bytes))))] [addr 0])
2706                      (if (fx= i n)
2707                          size
2708                          (let ([r ($get-reloc x i)])
2709                            (if (not r)
2710                                 0
2711                                 (let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))])
2712                                   (if (logtest r (constant reloc-extended-format))
2713                                       (let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))])
2714                                         (loop (fx+ i 3)
2715                                           (fx+ size
2716                                             (compute-size
2717                                               ($get-code-obj type x addr ($get-reloc x (fx+ i 1)))))
2718                                           addr))
2719                                       (let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))])
2720                                         (loop (fx+ i 1)
2721                                           (fx+ size
2722                                             (compute-size
2723                                               ($get-code-obj type x addr
2724                                                 (logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask)))))
2725                                           addr)))))))))
2726                  (compute-size ($code-name x))
2727                  (compute-size ($code-info x))
2728                  (compute-size ($code-pinfo* x)))]
2729               [(port? x)
2730                (fx+ (constant size-port)
2731                  (compute-size ($port-handler x))
2732                  (if (input-port? x) (compute-size (port-input-buffer x)) 0)
2733                  (if (output-port? x) (compute-size (port-output-buffer x)) 0)
2734                  (compute-size ($port-info x))
2735                  (compute-size (port-name x)))]
2736               [(thread? x)
2737                (fx+ (fold-left (lambda (size x)
2738                                  (fx+ size (compute-size x)))
2739                                (constant size-thread)
2740                           (thread->objects x))
2741                     (fold-left (lambda (size x) (fx+ size (compute-size x)))
2742                                0
2743                                (thread->stack-objects x)))]
2744               [($tlc? x)
2745                (fx+ (constant size-tlc)
2746                  (compute-size ($tlc-ht x))
2747                  (compute-size ($tlc-keyval x))
2748                  (compute-size ($tlc-next x)))]
2749               [($rtd-counts? x) (constant size-rtd-counts)]
2750               [(phantom-bytevector? x)
2751                (fx+ (constant size-tlc)
2752                  (phantom-bytevector-length x))]
2753               [else ($oops who "missing case for ~s" x)])))
2754         ; ensure size-ht isn't counted in the size of any object
2755         (eq-hashtable-set! size-ht size-ht (cons cookie 0))
2756         (compute-size x)])))
2757
2758  (set-who! $compute-composition
2759    (lambda (x maxgen)
2760      (define cookie (cons 'oatmeal 'raisin))
2761      (define seen-ht (make-eq-hashtable))
2762      (define rtd-ht (make-eq-hashtable))
2763      (define-syntax define-counters
2764        (lambda (x)
2765          (syntax-case x ()
2766            [(_ (name-vec count-vec incr!) type ...)
2767             (with-syntax ([(i ...) (enumerate #'(type ...))])
2768               #'(begin
2769                   (define name-vec (vector 'type ...))
2770                   (define count-vec (make-vector (length #'(type ...)) #f))
2771                   (define-syntax incr!
2772                     (syntax-rules (type ...)
2773                       [(_ type size)
2774                        (let ([p (vector-ref count-vec i)])
2775                          (if p
2776                              (begin
2777                                (set-car! p (fx+ (car p) 1))
2778                                (set-cdr! p (fx+ (cdr p) size)))
2779                              (vector-set! count-vec i (cons 1 size))))]
2780                       ...))))])))
2781      (define-counters (type-names type-counts incr!)
2782        pair symbol vector fxvector flvector bytevector stencil-vector string box flonum bignum ratnum exactnum
2783        inexactnum continuation stack procedure code-object reloc-table port thread tlc
2784        rtd-counts phantom)
2785      (define compute-composition!
2786        (lambda (x)
2787          (unless (or (fixmediate? x)
2788                      (let ([g ($generation x)])
2789                        (or (not g) (fx> g maxgen))))
2790            (let ([a (eq-hashtable-cell seen-ht x #f)])
2791              (unless (cdr a)
2792                (set-cdr! a #t)
2793                (really-compute-composition! x))))))
2794      (define really-compute-composition!
2795        (lambda (x)
2796          (cond
2797            [(pair? x)
2798             (incr! pair (constant size-pair))
2799             (compute-composition! (car x))
2800             (compute-composition! (cdr x))]
2801            [(symbol? x)
2802             (incr! symbol (constant size-symbol))
2803             (compute-composition! (#3%$top-level-value x))
2804             (compute-composition! ($symbol-property-list x))
2805             (compute-composition! ($system-property-list x))
2806             (compute-composition! ($symbol-name x))]
2807            [(vector? x)
2808             (incr! vector (align (fx+ (constant header-size-vector) (fx* (vector-length x) (constant ptr-bytes)))))
2809             (vector-for-each compute-composition! x)]
2810            [(fxvector? x) (incr! fxvector (align (fx+ (constant header-size-fxvector) (fx* (fxvector-length x) (constant ptr-bytes)))))]
2811            [(flvector? x) (incr! flvector (align (fx+ (constant header-size-flvector) (fx* (flvector-length x) (constant ptr-bytes)))))]
2812            [(bytevector? x) (incr! bytevector (align (fx+ (constant header-size-bytevector) (bytevector-length x))))]
2813            [(stencil-vector? x)
2814             (let ([len (stencil-vector-length x)])
2815               (incr! stencil-vector (align (fx+ (constant header-size-stencil-vector) (fx* len (constant ptr-bytes)))))
2816               (let loop ([i len])
2817                 (unless (fx= i 0)
2818                   (let ([i (fx- i 1)])
2819                     (compute-composition! (stencil-vector-ref x i))
2820                     (loop i)))))]
2821            [($record? x)
2822             (let ([rtd ($record-type-descriptor x)])
2823               (let ([p (eq-hashtable-ref rtd-ht rtd #f)] [size (align (rtd-size rtd))])
2824                 (if p
2825                     (begin
2826                       (set-car! p (fx+ (car p) 1))
2827                       (set-cdr! p (fx+ (cdr p) size)))
2828                     (eq-hashtable-set! rtd-ht rtd (cons 1 size))))
2829               (compute-composition! rtd)
2830               (let ([flds (rtd-flds rtd)])
2831                 (cond
2832                  [(fixnum? flds)
2833                   (let loop ([i 0])
2834                     (unless (fx= i flds)
2835                       (compute-composition! ($record-ref x i))
2836                       (loop (fx+ i 1))))]
2837                  [else
2838                   (for-each (lambda (fld)
2839                               (when (eq? (fld-type fld) 'scheme-object)
2840                                 (compute-composition! ($object-ref 'scheme-object x (fld-byte fld)))))
2841                     (rtd-flds rtd))])))]
2842            [(string? x) (incr! string (align (fx+ (constant header-size-string) (fx* (string-length x) (constant string-char-bytes)))))]
2843            [(box? x)
2844             (incr! box (constant size-box))
2845             (compute-composition! (unbox x))]
2846            [(flonum? x) (incr! flonum (constant size-flonum))]
2847            [(bignum? x) (incr! bignum (align (fx+ (constant header-size-bignum) (fx* ($bignum-length x) (constant bigit-bytes)))))]
2848            [(ratnum? x)
2849             (incr! ratnum (constant size-ratnum))
2850             (compute-composition! ($ratio-numerator x))
2851             (compute-composition! ($ratio-denominator x))]
2852            [($exactnum? x)
2853             (incr! exactnum (constant size-exactnum))
2854             (compute-composition! ($exactnum-real-part x))
2855             (compute-composition! ($exactnum-imag-part x))]
2856            [($inexactnum? x) (incr! inexactnum (constant size-inexactnum))]
2857            [(procedure? x)
2858             (if ($continuation? x)
2859                 (begin
2860                   (incr! continuation (constant size-continuation))
2861                   (unless (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag)))
2862                     ; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate
2863                     ; NB: picture of the continuation counts & sizes prior to splitting.  will add overhead to eventual invocation of
2864                     ; NB: the continuation as well
2865                     ($split-continuation x 0)
2866                     (compute-composition! ($continuation-return-code x))
2867                     (compute-composition! ($closure-code x))
2868                     (compute-composition! ($continuation-link x))
2869                     (compute-composition! ($continuation-winders x))
2870                     (compute-composition! ($continuation-attachments x))
2871                     (let ([len ($continuation-stack-length x)])
2872                       (incr! stack (align (fx* len (constant ptr-bytes))))
2873                       (let loop ([i 1] [lpm ($continuation-return-livemask x)])
2874                         (unless (fx>= i len)
2875                           (when (odd? lpm) (compute-composition! ($continuation-stack-ref x i)))
2876                           (loop (fx+ i 1) (ash lpm -1)))))))
2877                 (begin
2878                   (compute-composition! ($closure-code x))
2879                   (let ([n ($closure-length x)])
2880                     (incr! procedure (align (fx+ (constant header-size-closure) (fx* n (constant ptr-bytes)))))
2881                     (do ([i 0 (fx+ i 1)])
2882                       ((fx= i n))
2883                       (compute-composition! ($closure-ref x i))))))]
2884            [($code? x)
2885             (incr! code-object (align (fx+ (constant header-size-code) ($code-length x))))
2886             (let ([n ($code-reloc-size x)])
2887               (incr! reloc-table (align (fx+ (constant header-size-reloc-table) (fx* n (constant ptr-bytes)))))
2888               (let loop ([i 0] [addr 0])
2889                 (unless (fx= i n)
2890                   (let ([r ($get-reloc x i)])
2891                     (and r
2892                          (let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))])
2893                            (if (logtest r (constant reloc-extended-format))
2894                                (let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))])
2895                                  (compute-composition! ($get-code-obj type x addr ($get-reloc x (fx+ i 1))))
2896                                  (loop (fx+ i 3) addr))
2897                                (let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))])
2898                                  (compute-composition!
2899                                    ($get-code-obj type x addr
2900                                      (logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask))))
2901                                  (loop (fx+ i 1) addr)))))))))
2902             (compute-composition! ($code-name x))
2903             (compute-composition! ($code-info x))
2904             (compute-composition! ($code-pinfo* x))]
2905            [(port? x)
2906             (incr! port (constant size-port))
2907             (compute-composition! ($port-handler x))
2908             (if (input-port? x) (compute-composition! (port-input-buffer x)) 0)
2909             (if (output-port? x) (compute-composition! (port-output-buffer x)) 0)
2910             (compute-composition! ($port-info x))
2911             (compute-composition! (port-name x))]
2912            [(thread? x)
2913             (incr! thread (constant size-thread))
2914             (for-each compute-composition! (thread->objects x))
2915             (for-each compute-composition! (thread->stack-objects x))]
2916            [($tlc? x)
2917             (incr! tlc (constant size-tlc))
2918             (compute-composition! ($tlc-ht x))
2919             (compute-composition! ($tlc-keyval x))
2920             (compute-composition! ($tlc-next x))]
2921            [($rtd-counts? x) (incr! rtd-counts (constant size-rtd-counts))]
2922            [(phantom-bytevector? x) (incr! phantom (fx+ (constant size-phantom)
2923                                                         (phantom-bytevector-length x)))]
2924            [else ($oops who "missing case for ~s" x)])))
2925      ; ensure hashtables aren't counted
2926      (eq-hashtable-set! seen-ht seen-ht #t)
2927      (eq-hashtable-set! seen-ht rtd-ht #t)
2928      (compute-composition! x)
2929      (append
2930        (filter cdr (vector->list (vector-map cons type-names type-counts)))
2931        (vector->list
2932          (let-values ([(keys vals) (hashtable-entries rtd-ht)])
2933            (vector-map cons keys vals))))))
2934
2935  (set-who! $make-object-finder
2936    ; pred object maxgen => object-finder procedure that returns
2937    ;                               next object satisfying pred
2938    ;                               or #f, if no object found
2939    (lambda (pred x maxgen)
2940      (let ([seen-ht (make-eq-hashtable)])
2941        (define saved-next-proc
2942          (lambda ()
2943            (find! x '() (lambda () #f))))
2944        (define find!
2945          (lambda (x path next-proc)
2946            (let ([path (cons x path)])
2947              (cond
2948                [(or (fixmediate? x) (let ([g ($generation x)]) (or (not g) (fx> g maxgen))))
2949                 (if (pred x)
2950                     (begin (set! saved-next-proc next-proc) path)
2951                     (next-proc))]
2952                [else
2953                  (if (eq-hashtable-ref seen-ht x #f)
2954                      (next-proc) ; detected a loop, so backtrack and keep looking
2955                      (begin
2956                        (eq-hashtable-set! seen-ht x #t) ; mark this node as visited
2957                        (really-find! x path next-proc)))]))))
2958        ; We're visiting this node for the first time
2959        (define really-find!
2960          (lambda (x path next-proc)
2961            (define-syntax construct-proc
2962              (syntax-rules ()
2963                [(_ ?next-proc) ?next-proc]
2964                [(_ ?e ?e* ... ?next-proc)
2965                 (lambda () (find! ?e path (construct-proc ?e* ... ?next-proc)))]))
2966            (let ([next-proc
2967                    (cond
2968                      [(pair? x) (construct-proc (car x) (cdr x) next-proc)]
2969                      [(symbol? x)
2970                       (construct-proc
2971                         (#3%$top-level-value x)
2972                         ($symbol-property-list x)
2973                         ($system-property-list x)
2974                         ($symbol-name x) next-proc)]
2975                      [(vector? x)
2976                       (let ([n (vector-length x)])
2977                         (let f ([i 0])
2978                           (if (fx= i n)
2979                               next-proc
2980                               (construct-proc (vector-ref x i) (f (fx+ i 1))))))]
2981                      [(stencil-vector? x)
2982                       (let ([n (stencil-vector-length x)])
2983                         (let f ([i 0])
2984                           (if (fx= i n)
2985                               next-proc
2986                               (construct-proc (stencil-vector-ref x i) (f (fx+ i 1))))))]
2987                      [($record? x)
2988                       (let ([rtd ($record-type-descriptor x)])
2989                         (construct-proc rtd
2990                           (let ([flds (rtd-flds rtd)])
2991                             (cond
2992                              [(fixnum? flds)
2993                               (let loop ([i 0])
2994                                 (if (fx= i flds)
2995                                     next-proc
2996                                     (construct-proc ($record-ref x i) (loop (fx+ i 1)))))]
2997                              [else
2998                               (let f ([flds (rtd-flds rtd)])
2999                                 (if (null? flds)
3000                                     next-proc
3001                                     (let ([fld (car flds)])
3002                                       (if (eq? (fld-type fld) 'scheme-object)
3003                                           (construct-proc ($object-ref 'scheme-object x (fld-byte fld)) (f (cdr flds)))
3004                                           (f (cdr flds))))))]))))]
3005                      [(or (fxvector? x) (flvector? x) (bytevector? x) (string? x) (flonum? x) (bignum? x)
3006                           ($inexactnum? x) ($rtd-counts? x) (phantom-bytevector? x))
3007                       next-proc]
3008                      [(box? x) (construct-proc (unbox x) next-proc)]
3009                      [(ratnum? x) (construct-proc ($ratio-numerator x) ($ratio-denominator x) next-proc)]
3010                      [($exactnum? x) (construct-proc ($exactnum-real-part x) ($exactnum-imag-part x) next-proc)]
3011                      [(procedure? x)
3012                       (if ($continuation? x)
3013                           (if (or (eq? x $null-continuation) (= ($continuation-stack-length x) (constant unscaled-shot-1-shot-flag)))
3014                               next-proc
3015                               (begin
3016                                 ; NB: rather not do this...splitting creates new continuation objects and gives an inaccurate
3017                                 ; NB: picture of the size prior to splitting.  will add overhead to eventual invocation of
3018                                 ; NB: the continuation as well
3019                                 ($split-continuation x 0)
3020                                 ; not following RA slot at base of the frame, but this should always hold dounderflow,
3021                                 ; which will be in the static generation and therefore ignored anyway after compact heap
3022                                 (let ([len ($continuation-stack-length x)])
3023                                   (let loop ([i 1] [lpm ($continuation-return-livemask x)])
3024                                     (if (fx>= i len)
3025                                         (construct-proc ($continuation-return-code x) ($closure-code x) ($continuation-link x)
3026                                                         ($continuation-winders x) ($continuation-attachments x) next-proc)
3027                                         (if (odd? lpm)
3028                                             (construct-proc ($continuation-stack-ref x i) (loop (fx+ i 1) (ash lpm -1)))
3029                                             (loop (fx+ i 1) (ash lpm -1))))))))
3030                           (construct-proc ($closure-code x)
3031                             (let ([n ($closure-length x)])
3032                               (let f ([i 0])
3033                                 (if (fx= i n)
3034                                     next-proc
3035                                     (construct-proc ($closure-ref x i) (f (fx+ i 1))))))))]
3036                      [($code? x)
3037                       (construct-proc ($code-name x) ($code-info x) ($code-pinfo* x)
3038                         (let ([n ($code-reloc-size x)])
3039                           (let loop ([i 0] [addr 0])
3040                             (if (fx= i n)
3041                                 next-proc
3042                                 (let ([r ($get-reloc x i)])
3043                                   (if (not r)
3044                                       next-proc
3045                                       (let ([type (logand (bitwise-arithmetic-shift-right r (constant reloc-type-offset)) (constant reloc-type-mask))])
3046                                         (if (logtest r (constant reloc-extended-format))
3047                                             (let ([addr (fx+ addr ($get-reloc x (fx+ i 2)))])
3048                                               (construct-proc ($get-code-obj type x addr ($get-reloc x (fx+ i 1)))
3049                                                 (loop (fx+ i 3) addr)))
3050                                             (let ([addr (fx+ addr (logand (bitwise-arithmetic-shift-right r (constant reloc-code-offset-offset)) (constant reloc-code-offset-mask)))])
3051                                               (construct-proc
3052                                                 ($get-code-obj type x addr
3053                                                   (logand (bitwise-arithmetic-shift-right r (constant reloc-item-offset-offset)) (constant reloc-item-offset-mask)))
3054                                                 (loop (fx+ i 1) addr)))))))))))]
3055                      [(port? x)
3056                       (construct-proc ($port-handler x) ($port-info x) (port-name x)
3057                         (let ([th (lambda () (if (output-port? x) (construct-proc (port-output-buffer x) next-proc) next-proc))])
3058                           (if (input-port? x) (construct-proc (port-input-buffer x) (th)) (th))))]
3059                      [(thread? x)
3060                       (construct-proc (thread->objects x) (thread->stack-objects x) next-proc)]
3061                      [($tlc? x) (construct-proc ($tlc-ht x) ($tlc-keyval x) ($tlc-next x) next-proc)]
3062                      [else ($oops who "missing case for ~s" x)])])
3063              ; check if this node is what we're looking for
3064              (if (pred x)
3065                  (begin (set! saved-next-proc next-proc) path)
3066                  (next-proc)))))
3067        (rec find-next (lambda () (saved-next-proc)))))))
3068
3069(let ()
3070  (define filter-generation
3071    (lambda (who g)
3072      (unless (or (and (fixnum? g) (fx<= 0 g (collect-maximum-generation))) (eq? g 'static))
3073        ($oops who "invalid generation ~s" g))
3074      (if (eq? g 'static) (constant static-generation) g)))
3075
3076  (set-who! make-object-finder
3077    (case-lambda
3078      [(pred)
3079       (unless (procedure? pred) ($oops who "~s is not a procedure" pred))
3080       ($make-object-finder pred (oblist) (collect-maximum-generation))]
3081      [(pred x)
3082       (unless (procedure? pred) ($oops who "~s is not a procedure" pred))
3083       ($make-object-finder pred x (collect-maximum-generation))]
3084      [(pred x g)
3085       (unless (procedure? pred) ($oops who "~s is not a procedure" pred))
3086       ($make-object-finder pred x (filter-generation who g))]))
3087
3088  (set-who! compute-size
3089    (case-lambda
3090      [(x) ($compute-size x (collect-maximum-generation))]
3091      [(x g) ($compute-size x (filter-generation who g))]))
3092
3093  (set-who! compute-size-increments
3094    (let ([count_size_increments (foreign-procedure "(cs)count_size_increments" (ptr int) ptr)])
3095      (rec compute-size-increments
3096        (case-lambda
3097         [(x*) (compute-size-increments x* (collect-maximum-generation))]
3098         [(x* g)
3099          (unless (list? x*) ($oops who "~s is not a list" x*))
3100          (let ([g (filter-generation who g)])
3101            (count_size_increments x* g))]))))
3102
3103  (set-who! compute-composition
3104    (case-lambda
3105      [(x) ($compute-composition x (collect-maximum-generation))]
3106      [(x g) ($compute-composition x (filter-generation who g))])))
3107
3108(define object-counts (foreign-procedure "(cs)object_counts" () ptr))
3109
3110(define object-backreferences (foreign-procedure "(cs)object_backreferences" () ptr))
3111
3112)
3113