lib/_repl.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_repl.scm"
   4
   5 ;;; Copyright (c) 1994-2011 by Marc Feeley, All Rights Reserved.
   6
   7 ;;;============================================================================
   8
   9 (##include "header.scm")
  10
  11 ;;;============================================================================
  12
  13 ;;; Decompilation of a piece of code
  14
  15 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  16
  17 (##define-macro (mk-degen params . def)
  18   `(let () (##declare (not inline)) (lambda ($code ,@params) ,@def)))
  19
  20 (##define-macro (degen proc . args)
  21   `(,proc $code ,@args))
  22
  23 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  24
  25 (define-prim (##extract-container $code rte)
  26   (let loop ((c (macro-code-cte $code)) (r rte))
  27     (cond ((##cte-top? c)
  28            #f)
  29           ((##cte-frame? c)
  30            (let ((vars (##cte-frame-vars c)))
  31              (if (and (##pair? vars)
  32                       (let ((var (##car vars)))
  33                         (and (##var-i? var)
  34                              (##eq? (##var-i-name var) (macro-self-var)))))
  35                  (macro-rte-ref r 1)
  36                  (loop (##cte-parent-cte c) (macro-rte-up r)))))
  37           (else
  38            (loop (##cte-parent-cte c) r)))))
  39
  40 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  41
  42 (define-prim (##begin? x) (and (##pair? x) (##eq? (##car x) 'begin)))
  43 (define-prim (##cond? x)  (and (##pair? x) (##eq? (##car x) 'cond)))
  44 (define-prim (##and? x)   (and (##pair? x) (##eq? (##car x) 'and)))
  45 (define-prim (##or? x)    (and (##pair? x) (##eq? (##car x) 'or)))
  46 (define-prim (##void-constant? x)
  47   (and (##pair? x)
  48        (##eq? (##car x) 'quote)
  49        (##eq? (##cadr x) (##void))))
  50
  51 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  52
  53 (define-prim ##degen-top
  54   (mk-degen ()
  55     (##decomp (^ 0))))
  56
  57 (define-prim ##degen-cst
  58   (mk-degen ()
  59     (let ((val (^ 0)))
  60       (##inverse-eval val))))
  61
  62 (define-prim ##degen-loc-ref-x-y
  63   (mk-degen (up over)
  64     (degen ##degen-up-over up over)))
  65
  66 (define-prim ##degen-up-over
  67   (mk-degen (up over)
  68     (let loop1 ((c (macro-code-cte $code)) (up up))
  69       (cond ((##cte-frame? c)
  70              (if (##fixnum.= up 0)
  71                  (let loop2 ((vars (##cte-frame-vars c)) (i over))
  72                    (if (##fixnum.< i 2)
  73                        (let ((var (##car vars)))
  74                          (if (##var-i? var)
  75                              (##var-i-name var)
  76                              (##var-c-name var)))
  77                        (loop2 (##cdr vars) (##fixnum.- i 1))))
  78                  (loop1 (##cte-parent-cte c) (##fixnum.- up 1))))
  79             (else
  80              (loop1 (##cte-parent-cte c) up))))))
  81
  82 (define-prim ##degen-loc-ref
  83   (mk-degen ()
  84     (degen ##degen-loc-ref-x-y (^ 0) (^ 1))))
  85
  86 (define-prim ##degen-glo-ref
  87   (mk-degen ()
  88     (##global-var->identifier (^ 0))))
  89
  90 (define-prim ##degen-loc-set
  91   (mk-degen ()
  92     (##list 'set! (degen ##degen-up-over (^ 1) (^ 2))
  93                   (##decomp (^ 0)))))
  94
  95 (define-prim ##degen-glo-set
  96   (mk-degen ()
  97     (##list 'set! (##global-var->identifier (^ 1))
  98                   (##decomp (^ 0)))))
  99
 100 (define-prim ##degen-glo-def
 101   (mk-degen ()
 102     (##list 'define (##global-var->identifier (^ 1))
 103                     (##decomp (^ 0)))))
 104
 105 (define-prim ##degen-if2
 106   (mk-degen ()
 107     (##list 'if (##decomp (^ 0))
 108                 (##decomp (^ 1)))))
 109
 110 (define-prim ##degen-if3
 111   (mk-degen ()
 112     (##list 'if (##decomp (^ 0))
 113                 (##decomp (^ 1))
 114                 (##decomp (^ 2)))))
 115
 116 (define-prim ##degen-seq
 117   (mk-degen ()
 118     (let ((val1 (##decomp (^ 0)))
 119           (val2 (##decomp (^ 1))))
 120       (if (##begin? val2)
 121         (##cons 'begin (##cons val1 (##cdr val2)))
 122         (##list 'begin val1 val2)))))
 123
 124 (define-prim ##degen-quasi-list->vector
 125   (mk-degen ()
 126     (##list 'quasiquote
 127             (##list->vector
 128              (##degen-quasi-unquote-splicing-cdr
 129               (##decomp (^ 0)))))))
 130
 131 (define-prim ##degen-quasi-append
 132   (mk-degen ()
 133     (##degen-quasi-append-aux
 134      (##degen-quasi-unquote-splicing (##decomp (^ 0)))
 135      (##decomp (^ 1)))))
 136
 137 (define-prim ##degen-quasi-cons
 138   (mk-degen ()
 139     (##degen-quasi-append-aux
 140      (##degen-quasi-unquote (##decomp (^ 0)))
 141      (##decomp (^ 1)))))
 142
 143 (define-prim (##degen-quasi-append-aux a b)
 144   (##list 'quasiquote
 145           (##cons a
 146                   (##degen-quasi-unquote-splicing-cdr b))))
 147
 148 (define-prim (##degen-quasi-unquote expr)
 149   (let ((x (##degen-quasi-optimize expr)))
 150     (if x
 151         (##car x)
 152         (##list 'unquote expr))))
 153
 154 (define-prim (##degen-quasi-unquote-splicing-cdr expr)
 155   (let ((x (##degen-quasi-optimize expr)))
 156     (if x
 157         (##car x)
 158         (##list (##degen-quasi-unquote-splicing expr)))))
 159
 160 (define-prim (##degen-quasi-unquote-splicing expr)
 161   (##list 'unquote-splicing expr))
 162
 163 (define-prim (##degen-quasi-optimize expr)
 164   (let ((x (##degen-quasi-extract expr 'quasiquote)))
 165     (if x
 166         x
 167         (let ((y (##degen-quasi-extract expr 'quote)))
 168           (if (and y (##not (##pair? (##car y)))) ;; in case of embedded unquotes
 169               y
 170               #f)))))
 171
 172 (define-prim (##degen-quasi-extract expr tag)
 173   (and ;; #f ;; uncomment to disable optimization
 174        (##pair? expr)
 175        (##eq? (##car expr) tag)
 176        (let ((x (##cdr expr)))
 177          (and (##pair? x)
 178               (##null? (##cdr x))
 179               (##list (##car x))))))
 180
 181 (define-prim ##degen-cond-if
 182   (mk-degen ()
 183     (let ((val1 (##decomp (^ 0)))
 184           (val2 (##decomp (^ 1)))
 185           (val3 (##decomp (^ 2))))
 186       (##build-cond
 187         (if (##begin? val2)
 188           (##cons val1 (##cdr val2))
 189           (##list val1 val2))
 190         val3))))
 191
 192 (define-prim ##degen-cond-or
 193   (mk-degen ()
 194     (let ((val1 (##decomp (^ 0)))
 195           (val2 (##decomp (^ 1))))
 196       (##build-cond (##list val1) val2))))
 197
 198 (define-prim ##degen-cond-send
 199   (mk-degen ()
 200     (let ((val1 (##decomp (^ 0)))
 201           (val2 (##decomp (^ 1)))
 202           (val3 (##decomp (^ 2))))
 203       (##build-cond (##list val1 '=> val2) val3))))
 204
 205 (define-prim (##build-cond clause rest)
 206   (cond ((##cond? rest)
 207          (##cons 'cond (##cons clause (##cdr rest))))
 208         ((##begin? rest)
 209          (##cons 'cond (##list clause (##cons 'else (##cdr rest)))))
 210         ((##void-constant? rest)
 211          (##list 'cond clause))
 212         (else
 213          (##list 'cond clause (##list 'else rest)))))
 214
 215 (define-prim ##degen-or
 216   (mk-degen ()
 217     (let ((val1 (##decomp (^ 0)))
 218           (val2 (##decomp (^ 1))))
 219       (if (##or? val2)
 220         (##cons 'or (##cons val1 (##cdr val2)))
 221         (##list 'or val1 val2)))))
 222
 223 (define-prim ##degen-and
 224   (mk-degen ()
 225     (let ((val1 (##decomp (^ 0)))
 226           (val2 (##decomp (^ 1))))
 227       (if (##and? val2)
 228         (##cons 'and (##cons val1 (##cdr val2)))
 229         (##list 'and val1 val2)))))
 230
 231 (define-prim ##degen-case
 232   (mk-degen ()
 233     (let ((val1 (##decomp (^ 0)))
 234           (val2 (##decomp (^ 1))))
 235       (##cons 'case (##cons val1 val2)))))
 236
 237 (define-prim ##degen-case-clause
 238   (mk-degen ()
 239     (let ((val1 (##decomp (^ 0)))
 240           (val2 (##decomp (^ 1))))
 241       (##cons (if (##begin? val1)
 242                 (##cons (^ 2) (##cdr val1))
 243                 (##list (^ 2) val1))
 244               val2))))
 245
 246 (define-prim ##degen-case-else
 247   (mk-degen ()
 248     (let ((val (##decomp (^ 0))))
 249       (if (##void-constant? val)
 250         '()
 251         (##list (if (##begin? val)
 252                   (##cons 'else (##cdr val))
 253                   (##list 'else val)))))))
 254
 255 (define-prim ##degen-let
 256   (mk-degen ()
 257     (let ((n (macro-code-length $code)))
 258       (let loop ((i (##fixnum.- n 2)) (vals '()))
 259         (if (##fixnum.< 0 i)
 260           (loop (##fixnum.- i 1)
 261                 (##cons (##decomp (macro-code-ref $code i)) vals))
 262           (let ((body
 263                  (##decomp (^ 0)))
 264                 (bindings
 265                  (##make-bindings (macro-code-ref $code (##fixnum.- n 1))
 266                                   vals)))
 267             (if (##begin? body)
 268               (##cons 'let (##cons bindings (##cdr body)))
 269               (##list 'let bindings body))))))))
 270
 271 (define-prim (##make-bindings l1 l2)
 272   (if (##pair? l1)
 273     (##cons (##list (##car l1) (##car l2))
 274             (##make-bindings (##cdr l1) (##cdr l2)))
 275     '()))
 276
 277 (define-prim ##degen-letrec
 278   (mk-degen ()
 279     (let ((n (macro-code-length $code)))
 280       (let loop ((i (##fixnum.- n 2)) (vals '()))
 281         (if (##fixnum.< 0 i)
 282           (loop (##fixnum.- i 1)
 283                 (##cons (##decomp (macro-code-ref $code i)) vals))
 284           (let ((body
 285                  (##decomp (^ 0)))
 286                 (bindings
 287                  (##make-bindings (macro-code-ref $code (##fixnum.- n 1))
 288                                   vals)))
 289             (if (##begin? body)
 290               (##cons 'letrec (##cons bindings (##cdr body)))
 291               (##list 'letrec bindings body))))))))
 292
 293 (define-prim ##degen-prc-req
 294   (mk-degen ()
 295     (let* ((n (macro-code-length $code))
 296            (body (##decomp (^ 0)))
 297            (params (macro-code-ref $code (##fixnum.- n 1))))
 298       (if (##begin? body)
 299         (##cons 'lambda (##cons params (##cdr body)))
 300         (##list 'lambda params body)))))
 301
 302 (define-prim ##degen-prc-rest
 303   (mk-degen ()
 304     (let ((body (##decomp (^ 0)))
 305           (params (##make-params (^ 3) #t #f '())))
 306       (if (##begin? body)
 307         (##cons 'lambda (##cons params (##cdr body)))
 308         (##list 'lambda params body)))))
 309
 310 (define-prim ##degen-prc
 311   (mk-degen ()
 312     (let ((n (macro-code-length $code)))
 313       (let loop ((i (##fixnum.- n 8)) (inits '()))
 314         (if (##not (##fixnum.< i 1))
 315           (loop (##fixnum.- i 1)
 316                 (##cons (##decomp (macro-code-ref $code i)) inits))
 317           (let ((body
 318                  (##decomp (^ 0)))
 319                 (params
 320                  (##make-params
 321                    (macro-code-ref $code (##fixnum.- n 1))
 322                    (macro-code-ref $code (##fixnum.- n 4))
 323                    (macro-code-ref $code (##fixnum.- n 3))
 324                    inits)))
 325             (if (##begin? body)
 326               (##cons 'lambda (##cons params (##cdr body)))
 327               (##list 'lambda params body))))))))
 328
 329 (define-prim (##make-params parms rest? keys inits)
 330   (let* ((nb-parms
 331           (##length parms))
 332          (nb-inits
 333           (##length inits))
 334          (nb-reqs
 335           (##fixnum.- nb-parms (##fixnum.+ nb-inits (if rest? 1 0))))
 336          (nb-opts
 337           (##fixnum.- nb-inits (if keys (##vector-length keys) 0))))
 338
 339     (define (build-reqs)
 340       (let loop ((parms parms)
 341                  (i nb-reqs))
 342         (if (##fixnum.= i 0)
 343           (build-opts parms)
 344           (let ((parm (##car parms)))
 345             (##cons parm
 346                     (loop (##cdr parms)
 347                           (##fixnum.- i 1)))))))
 348
 349     (define (build-opts parms)
 350       (if (##fixnum.= nb-opts 0)
 351         (build-rest-and-keys parms inits)
 352         (##cons #!optional
 353                 (let loop ((parms parms)
 354                            (i nb-opts)
 355                            (inits inits))
 356                   (if (##fixnum.= i 0)
 357                     (build-rest-and-keys parms inits)
 358                     (let ((parm (##car parms))
 359                           (init (##car inits)))
 360                       (##cons (if (##eq? init #f) parm (##list parm init))
 361                               (loop (##cdr parms)
 362                                     (##fixnum.- i 1)
 363                                     (##cdr inits)))))))))
 364
 365     (define (build-rest-and-keys parms inits)
 366       (if (##eq? rest? 'dsssl)
 367         (##cons #!rest
 368                 (##cons (##car parms)
 369                         (build-keys (##cdr parms) inits)))
 370         (build-keys parms inits)))
 371
 372     (define (build-keys parms inits)
 373       (if (##not keys)
 374         (build-rest-at-end parms)
 375         (##cons #!key
 376                 (let loop ((parms parms)
 377                            (i (##vector-length keys))
 378                            (inits inits))
 379                   (if (##fixnum.= i 0)
 380                     (build-rest-at-end parms)
 381                     (let ((parm (##car parms))
 382                           (init (##car inits)))
 383                       (##cons (if (##eq? init #f) parm (##list parm init))
 384                               (loop (##cdr parms)
 385                                     (##fixnum.- i 1)
 386                                     (##cdr inits)))))))))
 387
 388     (define use-dotted-rest-parameter-when-possible? #t)
 389
 390     (define (build-rest-at-end parms)
 391       (if (##eq? rest? #t)
 392         (if use-dotted-rest-parameter-when-possible?
 393           (##car parms)
 394           (##cons #!rest (##cons (##car parms) '())))
 395         '()))
 396
 397     (build-reqs)))
 398
 399 (define-prim ##degen-app0
 400   (mk-degen ()
 401     (##list (##decomp (^ 0)))))
 402
 403 (define-prim ##degen-app1
 404   (mk-degen ()
 405     (##list (##decomp (^ 0))
 406             (##decomp (^ 1)))))
 407
 408 (define-prim ##degen-app2
 409   (mk-degen ()
 410     (##list (##decomp (^ 0))
 411             (##decomp (^ 1))
 412             (##decomp (^ 2)))))
 413
 414 (define-prim ##degen-app3
 415   (mk-degen ()
 416     (##list (##decomp (^ 0))
 417             (##decomp (^ 1))
 418             (##decomp (^ 2))
 419             (##decomp (^ 3)))))
 420
 421 (define-prim ##degen-app4
 422   (mk-degen ()
 423     (##list (##decomp (^ 0))
 424             (##decomp (^ 1))
 425             (##decomp (^ 2))
 426             (##decomp (^ 3))
 427             (##decomp (^ 4)))))
 428
 429 (define-prim ##degen-app
 430   (mk-degen ()
 431     (let ((n (macro-code-length $code)))
 432       (let loop ((i (##fixnum.- n 1)) (vals '()))
 433         (if (##not (##fixnum.< i 0))
 434           (loop (##fixnum.- i 1)
 435                 (##cons (##decomp (macro-code-ref $code i)) vals))
 436           vals)))))
 437
 438 (define-prim ##degen-delay
 439   (mk-degen ()
 440     (##list 'delay (##decomp (^ 0)))))
 441
 442 (define-prim ##degen-future
 443   (mk-degen ()
 444     (##list 'future (##decomp (^ 0)))))
 445
 446 (define-prim ##degen-require
 447   (mk-degen ()
 448     (##decomp (^ 1))))
 449
 450 ;;;----------------------------------------------------------------------------
 451
 452 (define ##decomp-dispatch-table #f)
 453
 454 (define-prim (##setup-decomp-dispatch-table)
 455   (set! ##decomp-dispatch-table
 456     (##list
 457       (##cons ##cprc-top         ##degen-top)
 458
 459       (##cons ##cprc-cst         ##degen-cst)
 460
 461       (##cons ##cprc-loc-ref-0-1 (mk-degen () (degen ##degen-loc-ref-x-y 0 1)))
 462       (##cons ##cprc-loc-ref-0-2 (mk-degen () (degen ##degen-loc-ref-x-y 0 2)))
 463       (##cons ##cprc-loc-ref-0-3 (mk-degen () (degen ##degen-loc-ref-x-y 0 3)))
 464       (##cons ##cprc-loc-ref-1-1 (mk-degen () (degen ##degen-loc-ref-x-y 1 1)))
 465       (##cons ##cprc-loc-ref-1-2 (mk-degen () (degen ##degen-loc-ref-x-y 1 2)))
 466       (##cons ##cprc-loc-ref-1-3 (mk-degen () (degen ##degen-loc-ref-x-y 1 3)))
 467       (##cons ##cprc-loc-ref-2-1 (mk-degen () (degen ##degen-loc-ref-x-y 2 1)))
 468       (##cons ##cprc-loc-ref-2-2 (mk-degen () (degen ##degen-loc-ref-x-y 2 2)))
 469       (##cons ##cprc-loc-ref-2-3 (mk-degen () (degen ##degen-loc-ref-x-y 2 3)))
 470       (##cons ##cprc-loc-ref     ##degen-loc-ref)
 471       (##cons ##cprc-loc-ref-box ##degen-loc-ref)
 472       (##cons ##cprc-glo-ref     ##degen-glo-ref)
 473
 474       (##cons ##cprc-loc-set     ##degen-loc-set)
 475       (##cons ##cprc-loc-set-box ##degen-loc-set)
 476       (##cons ##cprc-glo-set     ##degen-glo-set)
 477       (##cons ##cprc-glo-def     ##degen-glo-def)
 478
 479       (##cons ##cprc-if2         ##degen-if2)
 480       (##cons ##cprc-if3         ##degen-if3)
 481       (##cons ##cprc-seq         ##degen-seq)
 482       (##cons ##cprc-quasi-list->vector ##degen-quasi-list->vector)
 483       (##cons ##cprc-quasi-append ##degen-quasi-append)
 484       (##cons ##cprc-quasi-cons  ##degen-quasi-cons)
 485       (##cons ##cprc-cond-if     ##degen-cond-if)
 486       (##cons ##cprc-cond-or     ##degen-cond-or)
 487       (##cons ##cprc-cond-send-red ##degen-cond-send)
 488       (##cons ##cprc-cond-send-sub ##degen-cond-send)
 489
 490       (##cons ##cprc-or          ##degen-or)
 491       (##cons ##cprc-and         ##degen-and)
 492
 493       (##cons ##cprc-case        ##degen-case)
 494       (##cons ##cprc-case-clause ##degen-case-clause)
 495       (##cons ##cprc-case-else   ##degen-case-else)
 496
 497       (##cons ##cprc-let         ##degen-let)
 498       (##cons ##cprc-letrec      ##degen-letrec)
 499
 500       (##cons ##cprc-prc-req0    ##degen-prc-req)
 501       (##cons ##cprc-prc-req1    ##degen-prc-req)
 502       (##cons ##cprc-prc-req2    ##degen-prc-req)
 503       (##cons ##cprc-prc-req3    ##degen-prc-req)
 504       (##cons ##cprc-prc-req     ##degen-prc-req)
 505       (##cons ##cprc-prc-rest    ##degen-prc-rest)
 506       (##cons ##cprc-prc         ##degen-prc)
 507
 508       (##cons ##cprc-app0-red    ##degen-app0)
 509       (##cons ##cprc-app1-red    ##degen-app1)
 510       (##cons ##cprc-app2-red    ##degen-app2)
 511       (##cons ##cprc-app3-red    ##degen-app3)
 512       (##cons ##cprc-app4-red    ##degen-app4)
 513       (##cons ##cprc-app-red     ##degen-app)
 514       (##cons ##cprc-app0-sub    ##degen-app0)
 515       (##cons ##cprc-app1-sub    ##degen-app1)
 516       (##cons ##cprc-app2-sub    ##degen-app2)
 517       (##cons ##cprc-app3-sub    ##degen-app3)
 518       (##cons ##cprc-app4-sub    ##degen-app4)
 519       (##cons ##cprc-app-sub     ##degen-app)
 520
 521       (##cons ##cprc-delay       ##degen-delay)
 522       (##cons ##cprc-future      ##degen-future)
 523
 524       (##cons ##cprc-require     ##degen-require)
 525 )))
 526
 527 (##setup-decomp-dispatch-table)
 528
 529 ;;;----------------------------------------------------------------------------
 530
 531 ;;; Pretty-printer that decompiles procedures.
 532
 533 (define-prim (pp
 534               obj
 535               #!optional
 536               (port (macro-absent-obj)))
 537   (macro-force-vars (obj port)
 538     (let ((p
 539            (if (##eq? port (macro-absent-obj))
 540                (##repl-output-port)
 541                port)))
 542       (macro-check-output-port p 2 (pp obj p)
 543         (##pretty-print
 544          (if (##procedure? obj)
 545              (##decompile obj)
 546              obj)
 547          p)))))
 548
 549 (define-prim (##decomp $code)
 550   (let ((cprc (macro-code-cprc $code)))
 551     (let ((x (##assq cprc ##decomp-dispatch-table)))
 552       (if x
 553         (degen (##cdr x))
 554         '?))))
 555
 556 (define-prim (##decompile proc)
 557
 558   (define (decomp p)
 559     (let ((src-info (##subprocedure-source-info p)))
 560       (cond ((##source? src-info)
 561              (source->expression src-info))
 562             ((or (##locat? src-info)
 563                  (##not src-info))
 564              proc)
 565             (else
 566              src-info))))
 567
 568   (define (compiler-source-code src)
 569     (##source-code src))
 570
 571   (define (source->expression src)
 572
 573     (define (list->expression l)
 574       (cond ((##pair? l)
 575              (##cons (source->expression (##car l))
 576                      (list->expression (##cdr l))))
 577             ((##null? l)
 578              '())
 579             (else
 580              (source->expression l))))
 581
 582     (define (vector->expression v)
 583       (let* ((len (##vector-length v))
 584              (x (##make-vector len 0)))
 585         (let loop ((i (##fixnum.- len 1)))
 586           (if (##not (##fixnum.< i 0))
 587             (begin
 588               (##vector-set! x i (source->expression (##vector-ref v i)))
 589               (loop (##fixnum.- i 1)))))
 590         x))
 591
 592     (let ((code (compiler-source-code src)))
 593       (cond ((##pair? code)   (list->expression code))
 594             ((##vector? code) (vector->expression code))
 595             (else             code))))
 596
 597   (let loop ((p proc))
 598     (cond ((##interp-procedure? p)
 599            (let* (($code (##interp-procedure-code p))
 600                   (cprc (macro-code-cprc $code)))
 601              (if (##eq? cprc ##interp-procedure-wrapper)
 602                (loop (^ 1))
 603                (##decomp $code))))
 604           ((##closure? p)
 605            (decomp (##closure-code p)))
 606           (else
 607            (decomp p)))))
 608
 609 (define-prim (##procedure-locat proc)
 610
 611   (define (locat p)
 612     (let ((src-info (##subprocedure-source-info p)))
 613       (cond ((##source? src-info)
 614              (compiler-source-locat src-info))
 615             ((##locat? src-info)
 616              src-info)
 617             (else
 618              #f))))
 619
 620   (define (compiler-source-locat src)
 621     (##source-locat src))
 622
 623   (let loop ((p proc))
 624     (cond ((##interp-procedure? p)
 625            (let* (($code (##interp-procedure-code p))
 626                   (cprc (macro-code-cprc $code)))
 627              (if (##eq? cprc ##interp-procedure-wrapper)
 628                (loop (^ 1))
 629                (##code-locat $code))))
 630           ((##closure? p)
 631            (locat (##closure-code p)))
 632           (else
 633            (locat p)))))
 634
 635 (define-prim (##code-locat $code)
 636   (let ((locat-or-position (macro-code-locat $code)))
 637     (if (or (##locat? locat-or-position) (##not locat-or-position))
 638       locat-or-position
 639       (let loop ((parent (macro-code-link $code)))
 640         (if parent
 641           (let ((locat-or-position-parent (macro-code-locat parent)))
 642             (if (##locat? locat-or-position-parent)
 643               (##make-locat (##locat-container locat-or-position-parent)
 644                             locat-or-position)
 645               (loop (macro-code-link parent))))
 646           #f)))))
 647
 648 (define-prim (##subprocedure-source-info proc)
 649   (let ((info (##subprocedure-info proc)))
 650     (if info
 651         (##vector-ref info 1)
 652         #f)))
 653
 654 (define-prim (##subprocedure-info proc)
 655   (let* ((id (##subprocedure-id proc))
 656          (parent-info (##subprocedure-parent-info proc)))
 657     (if parent-info
 658       (let ((v (##vector-ref parent-info 0)))
 659         (let loop ((i (##fixnum.- (##vector-length v) 1)))
 660           (if (##fixnum.< i 0)
 661             #f
 662             (let ((x (##vector-ref v i)))
 663               (if (##fixnum.= id (##vector-ref x 0))
 664                 x
 665                 (loop (##fixnum.- i 1)))))))
 666       #f)))
 667
 668 ;;;============================================================================
 669
 670 ;;; Utilities
 671
 672 ;;;----------------------------------------------------------------------------
 673
 674 (define-prim (##procedure-friendly-name p)
 675   (or (##procedure-name p)
 676       p))
 677
 678 (define-prim (##procedure-name p)
 679   (and (##procedure? p)
 680        (or (and (##interp-procedure? p)
 681                 (let* (($code (##interp-procedure-code p))
 682                        (rte (##interp-procedure-rte p)))
 683                   (##object->lexical-var->identifier
 684                    (macro-code-cte $code)
 685                    rte
 686                    p)))
 687            (##object->global-var->identifier p))))
 688
 689 (define-prim (##object->lexical-var->identifier cte rte obj)
 690   (let loop1 ((c cte)
 691               (r rte))
 692     (cond ((##cte-top? c)
 693            #f)
 694           ((##cte-frame? c)
 695            (let loop2 ((vars (##cte-frame-vars c))
 696                        (i 1))
 697              (if (##pair? vars)
 698                  (let ((var (##car vars)))
 699                    (if (and (##not (##hidden-local-var? var))
 700                             (let ((val-or-box (##vector-ref r i)))
 701                               (##eq? obj
 702                                      (if (and (##var-c? var)
 703                                               (##var-c-boxed? var))
 704                                          (##unbox val-or-box)
 705                                          val-or-box))))
 706                        var
 707                        (loop2 (##cdr vars)
 708                               (##fixnum.+ i 1))))
 709                  (loop1 (##cte-parent-cte c)
 710                         (macro-rte-up r)))))
 711           (else
 712            (loop1 (##cte-parent-cte c)
 713                   r)))))
 714
 715 ;;;----------------------------------------------------------------------------
 716
 717 ;; Internal variables and parameters are uninteresting for the user.
 718
 719 (define-prim (##hidden-local-var? var)
 720   (and ;; (##var-i? var) test is redundant
 721        (or (##eq? var (macro-self-var))
 722            (##eq? var (macro-selector-var))
 723            (##eq? var (macro-do-loop-var)))))
 724
 725 (define-prim (##hidden-parameter? param)
 726   (or (##eq? param ##trace-depth)
 727       (##eq? param ##current-user-interrupt-handler)))
 728
 729 ;;;----------------------------------------------------------------------------
 730
 731 ;;; Access to structure of closures for interpreter procedures.
 732
 733 ;; Layout of closed variables for closures created by ##cprc-prcXXX and
 734 ;; ##interp-procedure-wrapper:
 735 ;;
 736 ;;   slot 1: $code
 737 ;;   slot 2: proc
 738 ;;   slot 3: rte
 739
 740 (define ##interp-procedure-code-pointers
 741   (let (($code (macro-make-code #f #f #f (##no-stepper) ()))
 742         (rte #f))
 743     (##list (##closure-code (##cprc-prc-req0 $code rte))
 744             (##closure-code (##cprc-prc-req1 $code rte))
 745             (##closure-code (##cprc-prc-req2 $code rte))
 746             (##closure-code (##cprc-prc-req3 $code rte))
 747             (##closure-code (##cprc-prc-req  $code rte))
 748             (##closure-code (##cprc-prc-rest $code rte))
 749             (##closure-code (##cprc-prc      $code rte))
 750             (##closure-code (##interp-procedure-wrapper $code rte)))))
 751
 752 (define-prim (##interp-procedure? x)
 753   (and (##procedure? x)
 754        (##closure? x)
 755        (##memq (##closure-code x) ##interp-procedure-code-pointers)))
 756
 757 (define-prim (##interp-procedure-code x) ;; return "$code" closed variable of x
 758   (##closure-ref x 1))
 759
 760 (define-prim (##interp-procedure-rte x) ;; return "rte" closed variable of x
 761   (##closure-ref x 3))
 762
 763 ;;;----------------------------------------------------------------------------
 764
 765 ;;; Access to continuations
 766
 767 (define-prim (##continuation-parent cont)
 768   (##subprocedure-parent (##continuation-ret cont)))
 769
 770 (define ##show-all-continuations? #f)
 771 (set! ##show-all-continuations? #f)
 772
 773 (define-prim (##hidden-continuation? cont)
 774   (if ##show-all-continuations?
 775     #f
 776     (let ((parent (##continuation-parent cont)))
 777       (or (##eq? parent ##interp-procedure-wrapper);;;;;;;;;;;;;;;;;;
 778           (##eq? parent ##dynamic-wind)
 779           (##eq? parent ##dynamic-env-bind)
 780           (##eq? parent ##kernel-handlers)
 781           (##eq? parent ##execute-modules)
 782           (##eq? parent ##repl-debug)
 783           (##eq? parent ##repl-debug-main)
 784           (##eq? parent ##repl-within)
 785           (##eq? parent ##eval-within)
 786           (##eq? parent ##with-no-result-expected)
 787           (##eq? parent ##with-no-result-expected-toplevel)
 788           (##eq? parent ##check-heap)
 789           (##eq? parent ##nontail-call-for-leap)
 790           (##eq? parent ##nontail-call-for-step)
 791           (##eq? parent ##trace-generate)
 792           (##eq? parent ##thread-interrupt!)
 793           (##eq? parent ##thread-call)))))
 794
 795 (define-prim (##interp-subproblem-continuation? cont)
 796   (let ((parent (##continuation-parent cont)))
 797     (or (##eq? parent ##subproblem-apply0)
 798         (##eq? parent ##subproblem-apply1)
 799         (##eq? parent ##subproblem-apply2)
 800         (##eq? parent ##subproblem-apply3)
 801         (##eq? parent ##subproblem-apply4)
 802         (##eq? parent ##subproblem-apply))))
 803
 804 (define-prim (##interp-internal-continuation? cont)
 805   (let ((parent (##continuation-parent cont)))
 806     (or (##eq? parent ##step-handler)
 807         (##eq? parent ##repl-within-proc)
 808         (##assq parent ##decomp-dispatch-table))))
 809
 810 (define-prim (##interp-continuation? cont)
 811   (or (##interp-subproblem-continuation? cont)
 812       (##interp-internal-continuation? cont)))
 813
 814 (define-prim (##continuation-creator cont) ;; returns #f if creator is REPL
 815   (and cont
 816        (if (##interp-continuation? cont)
 817          (let (($code (##interp-continuation-code cont))
 818                (rte (##interp-continuation-rte cont)))
 819            (##extract-container $code rte))
 820          (##continuation-parent cont))))
 821
 822 (define-prim (##continuation-locat cont) ;; returns #f if location unknown
 823   (and cont
 824        (if (##interp-continuation? cont)
 825          (##code-locat (##interp-continuation-code cont))
 826          (##procedure-locat (##continuation-ret cont)))))
 827
 828 (define-prim (##interp-continuation-code cont)
 829   (##local->value (##continuation-locals cont '$code)))
 830
 831 (define-prim (##interp-continuation-rte cont)
 832   (##local->value (##continuation-locals cont 'rte)))
 833
 834 (define-prim (##local->value x)
 835   (let ((var-c (##car x))
 836         (val-or-box (##cdr x)))
 837     (if (##var-c-boxed? var-c)
 838         (##unbox val-or-box)
 839         val-or-box)))
 840
 841 (define-prim (##interesting-continuation? cont)
 842   (or ##show-all-continuations?
 843       (##interp-subproblem-continuation? cont)
 844       (and (##not (##interp-internal-continuation? cont))
 845            (##not (##hidden-continuation? cont)))))
 846
 847 (define-prim (##continuation-first-frame cont all-frames?)
 848   (and cont
 849        (if (or all-frames?
 850                (##not (##hidden-continuation? cont)))
 851            cont
 852            (##continuation-next-frame cont all-frames?))))
 853
 854 (define-prim (##continuation-next-frame cont all-frames?)
 855   (and cont
 856        (let loop ((cont cont))
 857          (let ((next (##continuation-next cont)))
 858            (and next
 859                 (if (or all-frames?
 860                         (##interesting-continuation? next))
 861                     next
 862                     (loop next)))))))
 863
 864 (define-prim (##continuation-count-frames cont all-frames?)
 865   (let loop ((cont cont) (n 0))
 866     (if cont
 867         (loop (##continuation-next cont)
 868               (if (or all-frames?
 869                       (##interesting-continuation? cont))
 870                   (##fixnum.+ n 1)
 871                   n))
 872         n)))
 873
 874 (define-prim (##continuation-locals cont #!optional (var (macro-absent-obj)))
 875   (##subprocedure-locals (##continuation-ret cont) cont var))
 876
 877 (define-prim (##subprocedure-locals
 878               proc
 879               #!optional
 880               (cont (macro-absent-obj))
 881               (var (macro-absent-obj)))
 882   (let* ((parent-info (##subprocedure-parent-info proc))
 883          (info (##subprocedure-info proc)))
 884     (if (and parent-info info)
 885         (let ((var-descrs (##vector-ref parent-info 1)))
 886           (let loop1 ((j 2) (result '()))
 887             (if (##fixnum.< j (##vector-length info))
 888                 (let* ((descr
 889                         (##vector-ref info j))
 890                        (slot-index
 891                         (##fixnum.quotient descr 32768))
 892                        (var-descr-index
 893                         (##fixnum.quotient
 894                          (##fixnum.modulo descr 32768)
 895                          2))
 896                        (var-descr
 897                         (##vector-ref var-descrs var-descr-index))
 898                        (val-or-box1
 899                         (if (##eq? cont (macro-absent-obj))
 900                             #f
 901                             (##continuation-ref cont slot-index))))
 902
 903                   (define (get-var1)
 904                     (##cons (##var-c var-descr
 905                                      (##fixnum.=
 906                                       (##fixnum.modulo descr 2)
 907                                       1))
 908                             val-or-box1))
 909
 910                   (if (##pair? var-descr)
 911
 912                       (let loop2 ((lst var-descr) (result result))
 913                         (if (##pair? lst)
 914                             (let* ((descr
 915                                     (##car lst))
 916                                    (slot-index
 917                                     (##fixnum.quotient descr 32768))
 918                                    (var-descr-index
 919                                     (##fixnum.quotient
 920                                      (##fixnum.modulo descr 32768)
 921                                      2))
 922                                    (var-descr
 923                                     (##vector-ref var-descrs var-descr-index)))
 924
 925                               (define (get-var2)
 926                                 (##cons (##var-c var-descr
 927                                                  (##fixnum.=
 928                                                   (##fixnum.modulo descr 2)
 929                                                   1))
 930                                         (##closure-ref val-or-box1
 931                                                        slot-index)))
 932
 933                               (cond ((##eq? cont (macro-absent-obj))
 934                                      (loop2 (##cdr lst)
 935                                             (##cons var-descr
 936                                                     result)))
 937                                     ((##eq? var (macro-absent-obj))
 938                                      (loop2 (##cdr lst)
 939                                             (##cons (get-var2)
 940                                                     result)))
 941                                     (else
 942                                      (if (##eq? var var-descr)
 943                                          (get-var2)
 944                                          (loop2 (##cdr lst)
 945                                                 result)))))
 946                             (loop1 (##fixnum.+ j 1)
 947                                    result)))
 948
 949                       (cond ((##eq? cont (macro-absent-obj))
 950                              (loop1 (##fixnum.+ j 1)
 951                                     (##cons var-descr
 952                                             result)))
 953                             ((##eq? var (macro-absent-obj))
 954                              (loop1 (##fixnum.+ j 1)
 955                                     (##cons (get-var1)
 956                                             result)))
 957                             (else
 958                              (if (##eq? var var-descr)
 959                                  (get-var1)
 960                                  (loop1 (##fixnum.+ j 1)
 961                                         result))))))
 962                 result)))
 963         #f)))
 964
 965 ;;;----------------------------------------------------------------------------
 966
 967 (define-prim (##cmd-? port)
 968   (##write-string
 969 ",?              : Summary of comma commands
 970 ,h   | ,(h X)   : Help on procedure of last error or procedure/macro named X
 971 ,q              : Terminate the process
 972 ,qt             : Terminate the current thread
 973 ,t              : Jump to toplevel REPL
 974 ,d              : Jump to enclosing REPL
 975 ,c   | ,(c X)   : Continue the computation with stepping off
 976 ,s   | ,(s X)   : Continue the computation with stepping on (step)
 977 ,l   | ,(l X)   : Continue the computation with stepping on (leap)
 978 ,N              : Move to specific continuation frame (N>=0)
 979 ,N+  | ,N-      : Move forward/backward by N continuation frames (N>=0)
 980 ,+   | ,-       : Like ,1+ and ,1-
 981 ,++  | ,--      : Like ,N+ and ,N- with N = nb. of frames at head of backtrace
 982 ,y              : Display one-line summary of current frame
 983 ,i              : Display procedure attached to current frame
 984 ,b   | ,(b X)   : Display backtrace of current continuation or X (cont/thread)
 985 ,be  | ,(be X)  : Like ,b and ,(b X) but also display environment
 986 ,bed | ,(bed X) : Like ,be and ,(be X) but also display dynamic environment
 987 ,e   | ,(e X)   : Display environment of current frame or X (proc/cont/thread)
 988 ,ed  | ,(ed X)  : Like ,e and ,(e X) but also display dynamic environment
 989 ,st  | ,(st X)  : Display current thread group, or X (thread/thread group)
 990 ,(v X)          : Start a REPL visiting X (proc/cont/thread)
 991 " port))
 992
 993 ;;;,(p [N M])    : Configure REPL's pretty printer (N=max level, M=max length)
 994
 995 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 996
 997 (define ##backtrace-default-max-head #f)
 998 (set! ##backtrace-default-max-head 10)
 999
1000 (define ##backtrace-default-max-tail #f)
1001 (set! ##backtrace-default-max-tail 4)
1002
1003 (define ##frame-locat-display? #f)
1004 (set! ##frame-locat-display? #t)
1005
1006 (define ##frame-call-display? #f)
1007 (set! ##frame-call-display? #t)
1008
1009 (define-prim (##cmd-b cont port depth display-env?)
1010   (##display-continuation-backtrace
1011    cont
1012    port
1013    display-env?
1014    #f
1015    ##backtrace-default-max-head
1016    ##backtrace-default-max-tail
1017    depth))
1018
1019 (define-prim (##display-continuation-backtrace
1020               cont
1021               port
1022               display-env?
1023               all-frames?
1024               max-head
1025               max-tail
1026               depth)
1027   (let loop ((i 0)
1028              (j (##fixnum.- (##continuation-count-frames cont all-frames?) 1))
1029              (cont (##continuation-first-frame cont all-frames?)))
1030     (and cont
1031          (begin
1032            (cond ((or (##fixnum.< i max-head) (##fixnum.< j max-tail)
1033                       (and (##fixnum.= i max-head) (##fixnum.= j max-tail)))
1034                   (##display-continuation-frame
1035                    cont
1036                    port
1037                    display-env?
1038                    #f
1039                    (##fixnum.+ depth i)))
1040                  ((##fixnum.= i max-head)
1041                   (##write-string "..." port)
1042                   (##newline port)))
1043            (loop (##fixnum.+ i 1)
1044                  (##fixnum.- j 1)
1045                  (##continuation-next-frame cont all-frames?))))))
1046
1047 (define-prim (display-continuation-backtrace
1048               cont
1049               #!optional
1050               (port (macro-absent-obj))
1051               (all-frames? (macro-absent-obj))
1052               (display-env? (macro-absent-obj))
1053               (max-head (macro-absent-obj))
1054               (max-tail (macro-absent-obj))
1055               (depth (macro-absent-obj)))
1056   (macro-force-vars (cont port all-frames? display-env? max-head max-tail depth)
1057     (let ((p
1058            (if (##eq? port (macro-absent-obj))
1059                (macro-current-output-port)
1060                port))
1061           (de
1062            (if (##eq? display-env? (macro-absent-obj))
1063                #f
1064                display-env?))
1065           (af
1066            (if (##eq? all-frames? (macro-absent-obj))
1067                #f
1068                all-frames?))
1069           (mh
1070            (if (##eq? max-head (macro-absent-obj))
1071                ##backtrace-default-max-head
1072                max-head))
1073           (mt
1074            (if (##eq? max-tail (macro-absent-obj))
1075                ##backtrace-default-max-tail
1076                max-tail))
1077           (d
1078            (if (##eq? depth (macro-absent-obj))
1079                0
1080                depth)))
1081       (macro-check-continuation cont 1 (display-continuation-backtrace cont port display-env? all-frames? max-head max-tail depth)
1082         (macro-check-character-output-port p 2 (display-continuation-backtrace cont port display-env? all-frames? max-head max-tail depth)
1083           (macro-check-fixnum mh 5 (display-continuation-backtrace cont port display-env? all-frames? max-head max-tail depth)
1084             (macro-check-fixnum mt 6 (display-continuation-backtrace cont port display-env? all-frames? max-head max-tail depth)
1085               (macro-check-fixnum d 7 (display-continuation-backtrace cont port display-env? all-frames? max-head max-tail depth)
1086                 (##display-continuation-backtrace cont p de af mh mt d)))))))))
1087
1088 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1089
1090 (define-prim (##cmd-y cont port pinpoint? depth)
1091   (##display-continuation-frame
1092    cont
1093    port
1094    #f
1095    pinpoint?
1096    depth))
1097
1098 (define-prim (##display-continuation-frame
1099               cont
1100               port
1101               display-env?
1102               pinpoint?
1103               depth)
1104
1105   (define (tab col)
1106     (let* ((current (##output-port-column port))
1107            (n (##fixnum.- col current)))
1108       (##display-spaces (##fixnum.max n 1) port)))
1109
1110   (and cont
1111        (let ((port-width (##output-port-width port)))
1112
1113          (define depth-width    4)
1114          (define creator-width 24)
1115          (define locat-width   24)
1116          (define call-width    27)
1117
1118          (let* ((extra
1119                  (##fixnum.max
1120                   0
1121                   (##fixnum.quotient
1122                    (##fixnum.- port-width
1123                                (##fixnum.+
1124                                 depth-width
1125                                 creator-width
1126                                 locat-width
1127                                 call-width))
1128                    3)))
1129                 (col3
1130                  (##fixnum.+ depth-width
1131                              creator-width
1132                              extra))
1133                 (col4
1134                  (##fixnum.+ col3
1135                              locat-width
1136                              extra))
1137                 (locat-display?
1138                  ##frame-locat-display?)
1139                 (call-display?
1140                  ##frame-call-display?))
1141            (##write depth port)
1142            (tab depth-width)
1143            (let ((creator (##continuation-creator cont)))
1144              (if creator
1145                  (##write (##procedure-friendly-name creator) port)
1146                  (##write-string "(interaction)" port)))
1147            (if locat-display?
1148                (begin
1149                  (tab col3)
1150                  (let ((locat (##continuation-locat cont)))
1151                    (##display-locat locat pinpoint? port))))
1152            (if call-display?
1153                (let ((call
1154                       (if (##interp-continuation? cont)
1155                           (let* (($code (##interp-continuation-code cont))
1156                                  (cprc (macro-code-cprc $code)))
1157                             (if (##eq? cprc ##interp-procedure-wrapper)
1158                                 #f
1159                                 (##decomp $code)))
1160                           (let* ((ret (##continuation-ret cont))
1161                                  (call (##decompile ret)))
1162                             (if (##eq? call ret)
1163                                 #f
1164                                 call)))))
1165                  (if call
1166                      (begin
1167                        (tab (if locat-display? col4 col3))
1168                        (##write-string
1169                         (##object->string
1170                          call
1171                          (##fixnum.- port-width
1172                                      (##output-port-column port)))
1173                         port)))))
1174            (##newline port)
1175            (##display-continuation-env
1176             cont
1177             port
1178             (##fixnum.+ 4 depth-width)
1179             display-env?)))))
1180
1181 (define-prim (##display-spaces n port)
1182   (if (##fixnum.< 0 n)
1183     (let ((m (if (##fixnum.< 40 n) 40 n)))
1184       (##write-substring "                                        " 0 m port)
1185       (##display-spaces (##fixnum.- n m) port)
1186       n)))
1187
1188 (define-prim (##display-locat locat pinpoint? port)
1189   (if locat ;; locat is #f if location unknown
1190     (let* ((container (##locat-container locat))
1191            (path (##container->path container)))
1192       (if path
1193         (##write (##path-normalize path
1194                                    ##repl-location-relative
1195                                    ##repl-location-origin
1196                                    #f)
1197                  port)
1198         (##write-string (##container->id container) port))
1199       (let* ((filepos (##position->filepos (##locat-position locat)))
1200              (line (##fixnum.+ (##filepos-line filepos) 1))
1201              (col (##fixnum.+ (##filepos-col filepos) 1)))
1202         (##write-string "@" port)
1203         (##write line port)
1204         (##write-string (if pinpoint? "." ":") port)
1205         (##write col port)))))
1206
1207 (define ##repl-location-relative #f)
1208 (set! ##repl-location-relative 'shortest)
1209
1210 (define ##repl-location-origin #f)
1211 (set! ##repl-location-origin #f)
1212
1213 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1214
1215 (define-prim (##inverse-eval-in-env obj cte)
1216   (if (##procedure? obj)
1217     (let ((id (##object->global-var->identifier obj)))
1218
1219       (define (default)
1220         (let ((x (##decompile obj)))
1221           (if (##procedure? x)
1222             (##inverse-eval x)
1223             x)))
1224
1225       (if id
1226         (let ((ind (##cte-lookup cte id)))
1227           (if (##eq? (##vector-ref ind 0) 'not-found)
1228             id
1229             (default)))
1230         (default)))
1231
1232     (##inverse-eval obj)))
1233
1234 (define-prim (##inverse-eval obj)
1235   (if (##self-eval? obj)
1236     obj
1237     (##list 'quote obj)))
1238
1239 (define (##display-var-val var val-or-box cte indent port)
1240   (cond ((##var-i? var)
1241          (##display-var-val-aux (##var-i-name var)
1242                                 val-or-box
1243                                 #t
1244                                 cte
1245                                 indent
1246                                 port))
1247         ((##var-c-boxed? var)
1248          (##display-var-val-aux (##var-c-name var)
1249                                 (##unbox val-or-box)
1250                                 #t
1251                                 cte
1252                                 indent
1253                                 port))
1254         (else
1255          (##display-var-val-aux (##var-c-name var)
1256                                 val-or-box
1257                                 #f
1258                                 cte
1259                                 indent
1260                                 port))))
1261
1262 (define (##display-var-val-aux var val mutable? cte indent port)
1263   (##display-spaces indent port)
1264   (##write var port)
1265   (##write-string (if mutable? " = " " == ") port)
1266   (##write-string
1267    (##object->string
1268     (if (##cte-top? cte)
1269         (##inverse-eval-in-env val cte)
1270         (##inverse-eval-in-env val (##cte-parent-cte cte)))
1271     (##fixnum.- (##output-port-width port)
1272                 (##output-port-column port)))
1273    port)
1274   (##newline port))
1275
1276 (define (##display-rte cte rte indent port)
1277   (let loop1 ((c cte)
1278               (r rte))
1279     (cond ((##cte-top? c))
1280           ((##cte-frame? c)
1281            (let loop2 ((vars (##cte-frame-vars c))
1282                        (vals (##cdr (##vector->list r))))
1283              (if (##pair? vars)
1284                  (let ((var (##car vars)))
1285                    (if (##not (##hidden-local-var? var))
1286                        (let ((val-or-box (##car vals)))
1287                          (##display-var-val var val-or-box c indent port)))
1288                    (loop2 (##cdr vars)
1289                           (##cdr vals)))
1290                  (loop1 (##cte-parent-cte c)
1291                         (macro-rte-up r)))))
1292           (else
1293            (loop1 (##cte-parent-cte c)
1294                   r)))))
1295
1296 (define (##display-vars lst cte indent port)
1297   (let loop ((lst lst))
1298     (if (##pair? lst)
1299         (let* ((loc (##car lst))
1300                (var (##car loc))
1301                (val (##cdr loc)))
1302           (##display-var-val var val cte indent port)
1303           (loop (##cdr lst))))))
1304
1305 (define (##display-locals lst cte indent port)
1306   (and lst
1307        (##display-vars lst cte indent port)))
1308
1309 (define (##display-parameters lst cte indent port)
1310   (let loop ((lst lst))
1311     (if (##pair? lst)
1312         (let* ((param-val (##car lst))
1313                (param (##car param-val))
1314                (val (##cdr param-val)))
1315           (if (##not (##hidden-parameter? param))
1316               (let ((x (##inverse-eval-in-env param cte)))
1317                 (##display-var-val-aux (##list x) val #t cte indent port)))
1318           (loop (##cdr lst))))))
1319
1320 (define-prim (##display-continuation-environment cont port indent)
1321   (if (##interp-continuation? cont)
1322       (let (($code (##interp-continuation-code cont))
1323             (rte (##interp-continuation-rte cont)))
1324         (##display-rte (macro-code-cte $code) rte indent port))
1325       (##display-locals (##continuation-locals cont)
1326                         ##interaction-cte
1327                         indent
1328                         port))
1329   (##void))
1330
1331 (define-prim (display-continuation-environment
1332               cont
1333               #!optional
1334               (port (macro-absent-obj))
1335               (indent (macro-absent-obj)))
1336   (macro-force-vars (cont port indent)
1337     (let ((p
1338            (if (##eq? port (macro-absent-obj))
1339                (macro-current-output-port)
1340                port))
1341           (i
1342            (if (##eq? indent (macro-absent-obj))
1343                0
1344                indent)))
1345       (macro-check-continuation cont 1 (display-continuation-environment cont port indent)
1346         (macro-check-character-output-port p 2 (display-continuation-environment cont p indent)
1347           (macro-check-fixnum i 3 (display-continuation-environment cont p i)
1348             (##display-continuation-environment cont p i)))))))
1349
1350 (define-prim (##display-continuation-dynamic-environment cont port indent)
1351   (##display-parameters
1352    (##dynamic-env->list (macro-continuation-denv cont))
1353    (if (##interp-continuation? cont)
1354        (let (($code (##interp-continuation-code cont)))
1355          (macro-code-cte $code))
1356        ##interaction-cte)
1357    indent
1358    port)
1359   (##void))
1360
1361 (define-prim (display-continuation-dynamic-environment
1362               cont
1363               #!optional
1364               (port (macro-absent-obj))
1365               (indent (macro-absent-obj)))
1366   (macro-force-vars (cont port indent)
1367     (let ((p
1368            (if (##eq? port (macro-absent-obj))
1369                (macro-current-output-port)
1370                port))
1371           (i
1372            (if (##eq? indent (macro-absent-obj))
1373                0
1374                indent)))
1375       (macro-check-continuation cont 1 (display-continuation-dynamic-environment cont port indent)
1376         (macro-check-character-output-port p 2 (display-continuation-dynamic-environment cont p indent)
1377           (macro-check-fixnum i 3 (display-continuation-dynamic-environment cont p i)
1378             (##display-continuation-dynamic-environment cont p i)))))))
1379
1380 (define ##display-dynamic-environment?
1381   (##make-parameter #f))
1382
1383 (define display-dynamic-environment?
1384   ##display-dynamic-environment?)
1385
1386 (define-prim (##display-continuation-env cont port indent display-env?)
1387   (if display-env?
1388       (let ((c (##continuation-first-frame cont #f)))
1389         (if c
1390             (##display-continuation-environment c port indent))
1391         (if (or (##eq? display-env? 'dynamic)
1392                 (##display-dynamic-environment?))
1393             (##display-continuation-dynamic-environment cont port indent)))))
1394
1395 (define-prim (##cmd-e proc-or-cont port display-env?)
1396   (and proc-or-cont
1397        (if (##continuation? proc-or-cont)
1398            (##display-continuation-env proc-or-cont port 0 display-env?)
1399            (##display-procedure-environment proc-or-cont port 0))))
1400
1401 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1402
1403 (define-prim (##display-procedure-environment proc port indent)
1404   (cond ((##interp-procedure? proc)
1405          (let* (($code (##interp-procedure-code proc))
1406                 (rte (##interp-procedure-rte proc)))
1407            (##display-rte (macro-code-cte $code) rte indent port)))
1408         ((##closure? proc)
1409          (error "Can't access compiled procedure's environment")));;;;;;;;;;;
1410   (##void))
1411
1412 (define-prim (display-procedure-environment
1413               proc
1414               #!optional
1415               (port (macro-absent-obj))
1416               (indent (macro-absent-obj)))
1417   (macro-force-vars (proc port indent)
1418     (let ((p
1419            (if (##eq? port (macro-absent-obj))
1420                (macro-current-output-port)
1421                port))
1422           (i
1423            (if (##eq? indent (macro-absent-obj))
1424                0
1425                indent)))
1426       (macro-check-procedure proc 1 (display-procedure-environment proc port indent)
1427         (macro-check-character-output-port p 2 (display-procedure-environment proc p indent)
1428           (macro-check-fixnum i 3 (display-procedure-environment proc p i)
1429             (##display-procedure-environment proc p i)))))))
1430
1431 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1432
1433 (define-prim (##cmd-i cont port)
1434   (and cont
1435        (let ((creator (##continuation-creator cont)))
1436          (if creator
1437            (let ((decomp-creator (##decompile creator)))
1438              (##write creator port)
1439              (if (##eq? creator decomp-creator)
1440                (##newline port)
1441                (begin
1442                  (##write-string " =" port)
1443                  (##newline port)
1444                  (##pretty-print decomp-creator port))))
1445            (begin
1446              (##write-string "(interaction)" port)
1447              (##newline port))))))
1448
1449 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1450
1451 (define-prim (##cmd-st thread-or-tgroup port)
1452   (if (macro-thread? thread-or-tgroup)
1453       (##display-thread-state thread-or-tgroup port)
1454       (##display-thread-group-state thread-or-tgroup port))
1455   (##void))
1456
1457 (define-prim (##display-thread-state thread port)
1458   (let ((now (##current-time-point)))
1459     (##display-thread-state-relative thread port now)))
1460
1461 (define-prim (##display-thread-state-relative thread port time-point)
1462
1463   (define (tab col)
1464     (let* ((current (##output-port-column port))
1465            (n (##fixnum.- col current)))
1466       (##display-spaces (##fixnum.max n 1) port)))
1467
1468   (define (write-timeout to)
1469     (##write-string " " port)
1470     (let ((expiry (##flonum.- (macro-time-point to) time-point)))
1471       (##write (##flonum./ (##flonum.round (##flonum.* 10.0 expiry)) 10.0)
1472                port))
1473     (##write-string "s" port))
1474
1475   (let ((port-width (##output-port-width port)))
1476
1477     (define thread-width 14)
1478
1479     (let ((extra
1480            (##fixnum.max
1481             0
1482             (##fixnum.quotient
1483              (##fixnum.- port-width thread-width)
1484              5))))
1485       (##write thread port)
1486       (tab (##fixnum.+ thread-width extra))
1487       (let ((ts (##thread-state thread)))
1488         (cond ((macro-thread-state-uninitialized? ts)
1489                (##write-string "UNINITIALIZED" port))
1490               ((macro-thread-state-initialized? ts)
1491                (##write-string "INITIALIZED" port))
1492               ((macro-thread-state-normally-terminated? ts)
1493                (##write-string "NORMALLY TERMINATED" port))
1494               ((macro-thread-state-abnormally-terminated? ts)
1495                (##write-string "ABNORMALLY TERMINATED" port))
1496               ((macro-thread-state-active? ts)
1497                (let ((wf (macro-thread-state-active-waiting-for ts))
1498                      (to (macro-thread-state-active-timeout ts)))
1499                  (cond (wf
1500                         (##write-string "WAITING " port)
1501                         (##write wf port)
1502                         (if to
1503                             (write-timeout to)))
1504                        (to
1505                         (##write-string "SLEEPING" port)
1506                         (write-timeout to))
1507                        (else
1508                         (##write-string "RUNNING" port)))))
1509               (else
1510                (##write ts port))))
1511       (##newline port))))
1512
1513 (define-prim (##display-thread-group-state tgroup port)
1514   (let* ((threads (##tgroup->thread-vector tgroup))
1515          (now (##current-time-point)))
1516     (let loop ((i 0))
1517       (if (##fixnum.< i (##vector-length threads))
1518           (let ((thread (##vector-ref threads i)))
1519             (##display-thread-state-relative thread port now)
1520             (loop (##fixnum.+ i 1)))
1521           i))))
1522
1523 (define-prim (##top tgroup port)
1524
1525   (define interval 1.0)
1526
1527   (define (up n)
1528     (##write-string "\033[" port)
1529     (##write n port)
1530     (##write-string "A\033[J" port))
1531
1532   (let ((start-time-point (##current-time-point)))
1533     (let loop ((last start-time-point))
1534       (##write-string "*** THREAD LIST:\n" port)
1535       (let* ((n (##fixnum.+ 1 (##display-thread-group-state tgroup port)))
1536              (next (##flonum.+ last interval))
1537              (now (##current-time-point))
1538              (diff (##flonum.- next now)))
1539         (if (##flonum.negative? diff)
1540             (begin
1541               (up n)
1542               (loop now))
1543             (begin
1544               (##thread-sleep! diff)
1545               (up n)
1546               (loop next)))))))
1547
1548 (define-prim (top
1549               #!optional
1550               (tgroup (macro-absent-obj))
1551               (port (macro-absent-obj)))
1552   (macro-force-vars (port)
1553     (let ((tg
1554            (if (##eq? tgroup (macro-absent-obj))
1555                (macro-thread-tgroup (macro-current-thread))
1556                tgroup))
1557           (p
1558            (if (##eq? port (macro-absent-obj))
1559                (##repl-output-port)
1560                port)))
1561       (macro-check-tgroup tg 1 (top tgroup port)
1562         (macro-check-character-output-port p 2 (top tgroup port)
1563           (##top tg p))))))
1564
1565 ;;;----------------------------------------------------------------------------
1566
1567 ;;; Tracing and single stepping.
1568
1569 (define-prim (##interp-procedure-entry-hook proc)
1570   (let (($code (##interp-procedure-code proc)))
1571     (macro-code-ref $code (##fixnum.- (macro-code-length $code) 2))))
1572
1573 (define-prim (##interp-procedure-entry-hook-set! proc hook)
1574   (let (($code (##interp-procedure-code proc)))
1575     (macro-code-set! $code (##fixnum.- (macro-code-length $code) 2) hook)))
1576
1577 (define-prim (##interp-procedure-default-entry-hook proc)
1578   (let ((hook (##interp-procedure-entry-hook proc)))
1579     (if (and hook
1580              (##closure? hook)
1581              (##eq? (##subprocedure-parent (##closure-code hook))
1582                     ##make-default-entry-hook))
1583       hook
1584       #f)))
1585
1586 (define-prim (##make-default-entry-hook)
1587   (let ((settings (##vector #f #f)))
1588     (lambda (proc args execute)
1589       (if (##vector-ref settings 0)
1590         (##step-on)) ;; turn on single-stepping
1591       (if (##vector-ref settings 1)
1592         (##trace-generate
1593          (##make-call-form proc
1594                            (##argument-list-remove-absent! args '())
1595                            ##max-fixnum)
1596          execute
1597          #f)
1598         (execute)))))
1599
1600 (define-prim (##make-call-form proc args max-args)
1601
1602   (define (inverse-eval-args i lst)
1603     (if (##pair? lst)
1604       (if (##fixnum.< max-args i)
1605         '(...)
1606         (##cons (##inverse-eval (##car lst))
1607                 (inverse-eval-args (##fixnum.+ i 1) (##cdr lst))))
1608       '()))
1609
1610   (##cons (##procedure-friendly-name proc)
1611           (inverse-eval-args 1 args)))
1612
1613 (define ##trace-depth (##make-parameter 0))
1614
1615 (define-prim (##trace-generate form execute leap?)
1616
1617   (define max-depth 10)
1618
1619   (define (bars width output-port)
1620     (let loop ((i 0))
1621       (if (##fixnum.< i width)
1622         (begin
1623           (##write-string
1624             (if (##fixnum.= (##fixnum.remainder i 2) 0) "|" " ")
1625             output-port)
1626           (loop (##fixnum.+ i 1))))))
1627
1628   (define (bars-width depth)
1629     (let ((d (if (##fixnum.< max-depth depth) max-depth depth)))
1630       (if (##fixnum.< 0 d) (##fixnum.- (##fixnum.* d 2) 1) 0)))
1631
1632   (define (indent depth output-port)
1633     (let ((w (bars-width depth)))
1634       (if (##fixnum.< max-depth depth)
1635         (let ((depth-str (##number->string depth 10)))
1636           (bars (##fixnum.- w (##fixnum.+ (##string-length depth-str) 2))
1637                 output-port)
1638           (##write-string "[" output-port)
1639           (##write-string depth-str output-port)
1640           (##write-string "]" output-port))
1641         (bars w output-port))
1642       w))
1643
1644   (define (output-to-repl proc)
1645     (let ((old (##current-user-interrupt-handler)))
1646       (##parameterize
1647        ##current-user-interrupt-handler
1648        ##defer-user-interrupts
1649        (lambda ()
1650          (##repl proc)
1651          (##current-user-interrupt-handler old)))))
1652
1653   (##continuation-capture
1654    (lambda (cont)
1655      (let* ((parent
1656              (##continuation-parent cont))
1657             (increase-depth?
1658              (and (##not (##eq? ##nontail-call-for-leap parent))
1659                   (##not (##eq? ##nontail-call-for-step parent))))
1660             (current-depth
1661              (##trace-depth))
1662             (depth
1663              (if increase-depth?
1664                (##fixnum.+ current-depth 1)
1665                current-depth)))
1666
1667        (define (nest wrapper)
1668          (let ((result
1669                 (##parameterize
1670                  ##trace-depth
1671                  depth
1672                  (lambda () (wrapper execute)))))
1673
1674            (output-to-repl
1675             (lambda (first output-port)
1676               (let ((width
1677                      (##fixnum.+ (indent depth output-port) 1)))
1678                 (##write-string " " output-port)
1679                 (##write-string
1680                  (##object->string
1681                   result
1682                   (##fixnum.- (##output-port-width output-port) width))
1683                  output-port)
1684                 (##newline output-port)
1685                 #t)))
1686
1687            result))
1688
1689        (output-to-repl
1690         (lambda (first output-port)
1691           (let ((width
1692                  (##fixnum.+ (indent depth output-port) 3)))
1693             (##write-string " > " output-port)
1694             (##write-string
1695              (##object->string
1696               form
1697               (##fixnum.- (##output-port-width output-port) width))
1698              output-port)
1699             (##newline output-port)
1700             #t)))
1701
1702        (if leap?
1703          (cond ((##eq? ##nontail-call-for-leap parent)
1704                 (execute))
1705                ((##eq? ##nontail-call-for-step parent)
1706                 (##nontail-call-for-leap execute))
1707                (else
1708                 (nest ##nontail-call-for-leap)))
1709          (cond ((##eq? ##nontail-call-for-leap parent)
1710                 (execute))
1711                ((##eq? ##nontail-call-for-step parent)
1712                 (execute))
1713                (else
1714                 (nest ##nontail-call-for-step))))))))
1715
1716 (define-prim (##nontail-call-for-leap execute)
1717   (let ((result (execute)))
1718     (##step-on)
1719     result))
1720
1721 (define-prim (##nontail-call-for-step execute)
1722   (##first-argument (execute)))
1723
1724 (define ##trace-list '())
1725
1726 (define-prim (##trace proc)
1727
1728   (define (setup hook)
1729     (let ((settings (##closure-ref hook 1)))
1730       (##vector-set! settings 1 #t)
1731       (if (##not (##memq proc ##trace-list))
1732         (set! ##trace-list (##cons proc ##trace-list)))))
1733
1734   (let ((hook (##interp-procedure-default-entry-hook proc)))
1735     (if hook
1736       (setup hook)
1737       (let ((new-hook (##make-default-entry-hook)))
1738         (##interp-procedure-entry-hook-set! proc new-hook)
1739         (setup new-hook)))))
1740
1741 (define-prim (##untrace proc)
1742   (let ((hook (##interp-procedure-default-entry-hook proc)))
1743     (if hook
1744       (let ((settings (##closure-ref hook 1)))
1745         (##vector-set! settings 1 #f)
1746         (if (##not (##vector-ref settings 0))
1747           (##interp-procedure-entry-hook-set! proc #f))))
1748     (set! ##trace-list (##remove proc ##trace-list))))
1749
1750 (define-prim (trace . args)
1751   (if (##pair? args)
1752     (##for-each-interp-procedure
1753      trace
1754      args
1755      ##trace
1756      args)
1757     ##trace-list))
1758
1759 (define-prim (untrace . args)
1760   (##for-each-interp-procedure
1761    untrace
1762    args
1763    ##untrace
1764    (if (##pair? args) args ##trace-list)))
1765
1766 (define ##break-list '())
1767
1768 (define-prim (##break proc)
1769
1770   (define (setup hook)
1771     (let ((settings (##closure-ref hook 1)))
1772       (##vector-set! settings 0 #t)
1773       (if (##not (##memq proc ##break-list))
1774         (set! ##break-list (##cons proc ##break-list)))))
1775
1776   (let ((hook (##interp-procedure-default-entry-hook proc)))
1777     (if hook
1778       (setup hook)
1779       (let ((new-hook (##make-default-entry-hook)))
1780         (##interp-procedure-entry-hook-set! proc new-hook)
1781         (setup new-hook)))))
1782
1783 (define-prim (##unbreak proc)
1784   (let ((hook (##interp-procedure-default-entry-hook proc)))
1785     (if hook
1786       (let ((settings (##closure-ref hook 1)))
1787         (##vector-set! settings 0 #f)
1788         (if (##not (##vector-ref settings 1))
1789           (##interp-procedure-entry-hook-set! proc #f))))
1790     (set! ##break-list (##remove proc ##break-list))))
1791
1792 (define-prim (break . args)
1793   (if (##pair? args)
1794     (##for-each-interp-procedure
1795      break
1796      args
1797      ##break
1798      args)
1799     ##break-list))
1800
1801 (define-prim (unbreak . args)
1802   (##for-each-interp-procedure
1803    unbreak
1804    args
1805    ##unbreak
1806    (if (##pair? args) args ##break-list)))
1807
1808 (define-prim (##step-on)
1809   (##declare (not interrupts-enabled))
1810   (let* ((stepper (##current-stepper))
1811          (handlers (##vector-ref stepper 0)))
1812     (let loop ((i (##vector-length handlers)))
1813       (if (##not (##fixnum.< i 1))
1814         (let ((i-1 (##fixnum.- i 1)))
1815           (##vector-set! stepper i (##vector-ref handlers i-1))
1816           (loop i-1))))
1817     (##void)))
1818
1819 (define-prim (##step-off)
1820   (##declare (not interrupts-enabled))
1821   (let* ((stepper (##current-stepper))
1822          (handlers (##vector-ref stepper 0)))
1823     (let loop ((i (##vector-length handlers)))
1824       (if (##not (##fixnum.< i 1))
1825         (let ((i-1 (##fixnum.- i 1)))
1826           (##vector-set! stepper i #f)
1827           (loop i-1))))
1828     (##void)))
1829
1830 (define-prim (step)
1831   (##step-on))
1832
1833 (define-prim (##step-level-set! n)
1834   (##declare (not interrupts-enabled))
1835   (let* ((stepper (##current-stepper))
1836          (handlers (##vector-ref stepper 0)))
1837     (let loop ((i (##vector-length handlers)))
1838       (if (##not (##fixnum.< i 1))
1839         (let ((i-1 (##fixnum.- i 1)))
1840           (##vector-set! handlers i-1
1841             (if (##fixnum.< i-1 n)
1842               (##vector-ref ##step-handlers i-1)
1843               #f))
1844           (loop i-1))))
1845     (##void)))
1846
1847 (define-prim (step-level-set! n)
1848   (macro-force-vars (n)
1849     (macro-check-fixnum-range-incl n 1 0 7 (step-level-set! n)
1850       (##step-level-set! n))))
1851
1852 (define ##step-handlers (macro-make-step-handlers))
1853
1854 (set! ##main-stepper (macro-make-main-stepper))
1855
1856 (define ##repl-display-environment?
1857   (##make-parameter #f))
1858
1859 (define repl-display-environment?
1860   ##repl-display-environment?)
1861
1862 (define-prim (display-environment-set! display?)
1863   ;; DEPRECATED
1864   (##repl-display-environment? (if display? #t #f))
1865   (##void))
1866
1867 (define-prim (##step-handler leapable? $code rte execute-body . other)
1868   (##declare (not interrupts-enabled) (environment-map))
1869   (##step-off) ;; turn off single-stepping
1870   (##step-handler-continue
1871    (##step-handler-get-command $code rte)
1872    leapable?
1873    $code
1874    rte
1875    execute-body
1876    other))
1877
1878 (define-prim (##step-handler-continuation? cont)
1879   (##eq? (##continuation-parent cont) ##step-handler))
1880
1881 (define-prim (##with-no-result-expected-continuation? cont)
1882   (##eq? (##continuation-parent cont) ##with-no-result-expected))
1883
1884 (define-prim (##with-no-result-expected-toplevel-continuation? cont)
1885   (##eq? (##continuation-parent cont) ##with-no-result-expected-toplevel))
1886
1887 (define-prim (##step-handler-get-command $code rte)
1888   (##repl
1889    (lambda (first output-port)
1890      (##display-situation
1891       "STOPPED"
1892       (##extract-container $code rte)
1893       (##code-locat $code)
1894       output-port)
1895      (##newline output-port)
1896      #f)))
1897
1898 (define-prim (##step-handler-continue cmd leapable? $code rte execute-body other)
1899
1900   ;; cmd is one of the symbols "c", "s" or "l" or a one element vector
1901
1902   (define (execute)
1903     (##apply execute-body (##cons $code (##cons rte other))))
1904
1905   (cond ((##eq? cmd 'c)
1906          (execute))
1907         ((and (##eq? cmd 'l) leapable?)
1908          (##trace-generate (##decomp $code) execute #t))
1909         ((or (##eq? cmd 'l) (##eq? cmd 's))
1910          (##step-on)
1911          (##trace-generate (##decomp $code) execute #f))
1912         (else
1913          (##vector-ref cmd 0))))
1914
1915 (define-prim (##for-each-interp-procedure prim args fn procs)
1916   (let loop ((lst1 procs) (lst2 '()) (arg-num 1))
1917     (if (##pair? lst1)
1918       (let ((proc (##car lst1)))
1919         (if (##procedure? proc)
1920           (if (##interp-procedure? proc)
1921             (loop (##cdr lst1)
1922                   (##cons proc lst2)
1923                   (##fixnum.+ arg-num 1))
1924             (let ((id (##object->global-var->identifier proc)))
1925               (if id ;; procedure is bound to a global variable
1926                 (begin
1927                   (##repl
1928                    (lambda (first output-port)
1929                      (##write-string
1930                       "*** WARNING -- Rebinding global variable \""
1931                       output-port)
1932                      (##write id output-port)
1933                      (##write-string
1934                       "\" to an interpreted procedure\n"
1935                       output-port)
1936                      #t))
1937                   (let ((new-proc
1938                          (##make-interp-procedure proc)))
1939                     (##global-var-set! (##make-global-var id) new-proc)
1940                     (loop (##cdr lst1)
1941                           (##cons new-proc lst2)
1942                           (##fixnum.+ arg-num 1))))
1943                 (##fail-check-interpreted-procedure arg-num '() prim args))))
1944           (##fail-check-interpreted-procedure arg-num '() prim args)))
1945       (begin
1946         (##for-each fn (##reverse lst2))
1947         (##void)))))
1948
1949 (define-fail-check-type interpreted-procedure 'interpreted-procedure)
1950
1951 (define-prim ##interp-procedure-wrapper
1952   (macro-make-cprc ;; this is never actually called to evaluate code
1953    (letrec ((proc
1954              (lambda args
1955
1956                (define (execute)
1957                  (let (($code $code)
1958                        (rte (macro-make-rte rte proc args)))
1959 ;;;*********                   (break-if-stepping-level>= 0)
1960                    (##apply (^ 1) args)))
1961
1962                (let ((entry-hook (^ 0)))
1963                  (if entry-hook
1964                    (entry-hook
1965                     proc
1966                     args
1967                     (lambda () (execute)))
1968                    (execute))))))
1969      proc)))
1970
1971 (define-prim (##make-interp-procedure proc)
1972   (let* ((cte
1973           (##make-top-cte))
1974          (src
1975           #f)
1976          (stepper
1977           (##current-stepper))
1978          ($code
1979           (macro-make-code ##interp-procedure-wrapper cte src stepper ()
1980             #f
1981             proc))
1982          (rte
1983           #f))
1984     (##interp-procedure-wrapper $code rte)))
1985
1986 (define-prim (##remove elem lst)
1987   (let loop ((lst1 lst) (lst2 '()))
1988     (if (##pair? lst1)
1989       (let ((x (##car lst1)))
1990         (if (##eq? x elem)
1991           (##append (##reverse lst2) (##cdr lst1))
1992           (loop (##cdr lst1) (##cons x lst2))))
1993       lst)))
1994
1995 ;;;============================================================================
1996
1997 ;;; Read eval print loop channels.
1998
1999 (implement-type-repl-channel)
2000
2001 (define-prim (##thread-repl-channel-get! thread)
2002   (or (macro-thread-repl-channel thread)
2003       (let ((repl-channel (##thread-make-repl-channel thread)))
2004         (macro-thread-repl-channel-set! thread repl-channel)
2005         (macro-thread-repl-channel thread))))
2006
2007 (define (##default-thread-make-repl-channel thread)
2008     ##stdio/console-repl-channel)
2009
2010 (define ##thread-make-repl-channel #f)
2011 (set! ##thread-make-repl-channel ##default-thread-make-repl-channel)
2012
2013 (define ##stdio/console-repl-channel
2014   (let* ((settings
2015           (##set-debug-settings! 0 0))
2016          (x
2017           (##fixnum.arithmetic-shift-right
2018            (##fixnum.bitwise-and
2019             settings
2020             (macro-debug-settings-repl-mask))
2021            (macro-debug-settings-repl-shift))))
2022     (cond ((##fixnum.= x (macro-debug-settings-repl-stdio))
2023            (##make-repl-channel-ports ##stdin-port ##stdout-port))
2024           (else
2025            (##make-repl-channel-ports ##console-port ##console-port)))))
2026
2027 (define-prim (##repl-input-port)
2028   (let* ((ct (macro-current-thread))
2029          (channel (##thread-repl-channel-get! ct)))
2030     (macro-repl-channel-input-port channel)))
2031
2032 (define-prim (repl-input-port)
2033   (##repl-input-port))
2034
2035 (define-prim (##repl-output-port)
2036   (let* ((ct (macro-current-thread))
2037          (channel (##thread-repl-channel-get! ct)))
2038     (macro-repl-channel-output-port channel)))
2039
2040 (define-prim (repl-output-port)
2041   (##repl-output-port))
2042
2043 (define-prim (##repl-channel-acquire-ownership!)
2044   (let* ((ct (macro-current-thread))
2045          (channel (##thread-repl-channel-get! ct)))
2046     (macro-mutex-lock! (macro-repl-channel-owner-mutex channel) #f ct)
2047     (if (##not (##eq? (macro-repl-channel-last-owner channel) ct))
2048       (begin
2049         (macro-repl-channel-last-owner-set! channel ct)
2050         (##repl-channel-display-monoline-message
2051          (lambda (output-port)
2052            (##write-string "------------- REPL is now in " output-port)
2053            (##write ct output-port)
2054            (##write-string " -------------" output-port)))
2055         #t)
2056       #f)))
2057
2058 (define-prim (##repl-channel-release-ownership!)
2059   (let ((channel (##thread-repl-channel-get! (macro-current-thread))))
2060     (macro-mutex-unlock! (macro-repl-channel-owner-mutex channel))))
2061
2062 (define-prim (##repl-channel-input-port)
2063   (let ((channel (##thread-repl-channel-get! (macro-current-thread))))
2064     (macro-repl-channel-input-port channel)))
2065
2066 (define-prim (##repl-channel-output-port)
2067   (let ((channel (##thread-repl-channel-get! (macro-current-thread))))
2068     (macro-repl-channel-output-port channel)))
2069
2070 (define-prim (##repl-channel-read-command level depth)
2071   (let ((channel (##thread-repl-channel-get! (macro-current-thread))))
2072     ((macro-repl-channel-read-command channel) channel level depth)))
2073
2074 (define-prim (##repl-channel-write-results results)
2075   (let ((channel (##thread-repl-channel-get! (macro-current-thread))))
2076     ((macro-repl-channel-write-results channel) channel results)))
2077
2078 (define-prim (##repl-channel-display-monoline-message writer)
2079   (let ((channel (##thread-repl-channel-get! (macro-current-thread))))
2080     ((macro-repl-channel-display-monoline-message channel) channel writer)))
2081
2082 (define-prim (##repl-channel-display-multiline-message writer)
2083   (let ((channel (##thread-repl-channel-get! (macro-current-thread))))
2084     ((macro-repl-channel-display-multiline-message channel) channel writer)))
2085
2086 (define-prim (##repl-channel-display-continuation cont depth)
2087   (let ((channel (##thread-repl-channel-get! (macro-current-thread))))
2088     ((macro-repl-channel-display-continuation channel) channel cont depth)))
2089
2090 (define-prim (##repl-channel-pinpoint-continuation cont)
2091   (let ((channel (##thread-repl-channel-get! (macro-current-thread))))
2092     ((macro-repl-channel-pinpoint-continuation channel) channel cont)))
2093
2094 (define-prim (##repl-channel-really-exit?)
2095   (let ((channel (##thread-repl-channel-get! (macro-current-thread))))
2096     ((macro-repl-channel-really-exit? channel) channel)))
2097
2098 (define-prim (##repl-channel-newline)
2099   (let ((channel (##thread-repl-channel-get! (macro-current-thread))))
2100     ((macro-repl-channel-newline channel) channel)))
2101
2102 (##define-macro (macro-repl-result-history-max-max-length)
2103   10)
2104
2105 (##define-macro (macro-repl-result-history-default-max-length)
2106   3)
2107
2108 (define-prim (##make-empty-repl-result-history)
2109   (##vector (macro-repl-result-history-default-max-length)))
2110
2111 (##define-macro (macro-repl-result-history-length result-history)
2112   `(##fixnum.- (##vector-length ,result-history) 1))
2113
2114 (##define-macro (macro-repl-result-history-max-length result-history)
2115   `(##vector-ref ,result-history 0))
2116
2117 (##define-macro (macro-repl-result-history-ref result-history i)
2118   `(##vector-ref ,result-history (##fixnum.+ ,i 1)))
2119
2120 (define-prim (##repl-channel-result-history-add channel result)
2121   (let loop ()
2122     (let* ((result-history (macro-repl-channel-result-history channel))
2123            (len (macro-repl-result-history-length result-history))
2124            (max-len (macro-repl-result-history-max-length result-history))
2125            (new-len (##fixnum.min (##fixnum.+ len 1) max-len)))
2126       (if (##fixnum.< 0 new-len)
2127           (let ((v (##make-vector (##fixnum.+ new-len 1) max-len)))
2128             (##subvector-move! result-history 1 new-len v 2)
2129             (##vector-set! v 1 result)
2130             (let ()
2131               (##declare (not interrupts-enabled))
2132               (if (##not (##eq? (macro-repl-channel-result-history channel)
2133                                 result-history))
2134                   (loop) ;; some other thread changed it before us... try again
2135                   (begin
2136                     (macro-repl-channel-result-history-set! channel v)
2137                     (##void)))))
2138           (##void)))))
2139
2140 (define-prim (##repl-channel-result-history-max-length-set! channel max-len)
2141   (let loop ()
2142     (let* ((result-history (macro-repl-channel-result-history channel))
2143            (len (macro-repl-result-history-length result-history))
2144            (new-len (##fixnum.min len max-len))
2145            (v (##make-vector (##fixnum.+ new-len 1) max-len)))
2146       (##subvector-move! result-history 1 (##fixnum.+ new-len 1) v 1)
2147       (let ()
2148         (##declare (not interrupts-enabled))
2149         (if (##not (##eq? (macro-repl-channel-result-history channel)
2150                           result-history))
2151             (loop) ;; some other thread changed it before us... try again
2152             (begin
2153               (macro-repl-channel-result-history-set! channel v)
2154               (##void)))))))
2155
2156 (define-prim (##repl-result-history-ref index)
2157   (let* ((channel (##thread-repl-channel-get! (macro-current-thread)))
2158          (result-history (macro-repl-channel-result-history channel)))
2159     (macro-check-fixnum-range
2160      index
2161      1
2162      0
2163      (macro-repl-result-history-length result-history)
2164      (repl-result-history-ref index)
2165      (macro-repl-result-history-ref result-history index))))
2166
2167 (define-prim (repl-result-history-ref index)
2168   (##repl-result-history-ref index))
2169
2170 (define-prim (##repl-result-history-max-length-set! max-len)
2171   (let* ((channel (##thread-repl-channel-get! (macro-current-thread)))
2172          (result-history (macro-repl-channel-result-history channel)))
2173     (macro-check-fixnum-range-incl
2174      max-len
2175      1
2176      0
2177      (macro-repl-result-history-max-max-length)
2178      (repl-result-history-max-length-set! max-len)
2179      (##repl-channel-result-history-max-length-set! channel max-len))))
2180
2181 (define-prim (repl-result-history-max-length-set! max-len)
2182   (##repl-result-history-max-length-set! max-len))
2183
2184 (implement-type-repl-channel-ports)
2185
2186 (define-prim (##make-repl-channel-ports input-port output-port)
2187   (macro-make-repl-channel-ports
2188
2189    (##make-mutex 'channel-arbiter)
2190    (macro-current-thread)
2191    input-port
2192    output-port
2193    (##make-empty-repl-result-history)
2194
2195    ##repl-channel-ports-read-command
2196    ##repl-channel-ports-write-results
2197    ##repl-channel-ports-display-monoline-message
2198    ##repl-channel-ports-display-multiline-message
2199    ##repl-channel-ports-display-continuation
2200    ##repl-channel-ports-pinpoint-continuation
2201    ##repl-channel-ports-really-exit?
2202    ##repl-channel-ports-newline
2203
2204    (let ((history-initialized? #f))
2205      (lambda (channel)
2206
2207        (if (##not history-initialized?)
2208            (let ((input-port (macro-repl-channel-input-port channel)))
2209
2210              (define (in-homedir filename)
2211                (let ((homedir (##path-expand "~")))
2212                  (##string-append homedir filename)))
2213
2214              (set! history-initialized? #t)
2215
2216              (if (##tty? input-port)
2217                  (let ((path-or-settings
2218                         (##list path:
2219                                 (in-homedir ".gambc_history")
2220                                 char-encoding:
2221                                 'UTF-8)))
2222
2223                    (##open-file-generic
2224                     (macro-direction-in)
2225                     #f
2226                     (lambda (port)
2227                       (if (##port? port)
2228                           (let ((history (##read-line port #f #f ##max-fixnum)))
2229                             (##close-port port)
2230                             (if (##string? history)
2231                                 (##tty-history-set! input-port history)))))
2232                     open-input-file
2233                     (##cons eol-encoding: (##cons 'cr-lf path-or-settings)))
2234
2235                    (##add-exit-job!
2236                     (lambda ()
2237                       (##open-file-generic
2238                        (macro-direction-out)
2239                        #f
2240                        (lambda (port)
2241                          (if (##port? port)
2242                              (let ((history (##tty-history input-port)))
2243                                (##display history port)
2244                                (##close-port port))))
2245                        open-output-file
2246                        path-or-settings)))))))
2247
2248        (let ((result
2249               (let ((input-port (macro-repl-channel-input-port channel)))
2250                 (##read-expr-from-port input-port))))
2251          (let ((output-port (macro-repl-channel-output-port channel)))
2252            (##output-port-column-set! output-port 1))
2253          result)))))
2254
2255 (define-prim (##repl-channel-ports-read-command channel level depth)
2256
2257   (define prompt "> ")
2258
2259   (let ((output-port (macro-repl-channel-output-port channel)))
2260     (if (##fixnum.< 0 level)
2261         (##write level output-port))
2262     (if (##fixnum.< 0 depth)
2263         (begin
2264           (##write-string "\\" output-port)
2265           (##write depth output-port)))
2266     (##write-string prompt output-port)
2267     (##force-output output-port))
2268
2269   ((macro-repl-channel-ports-read-expr channel) channel))
2270
2271 (define-prim (##repl-channel-ports-write-results channel results)
2272   (let ((output-port (macro-repl-channel-output-port channel)))
2273     (##for-each
2274      (lambda (obj)
2275        (if (##not (##eq? obj (##void)))
2276            (begin
2277              (##repl-channel-result-history-add channel obj)
2278              (##pretty-print obj output-port))))
2279      results)))
2280
2281 (define-prim (##repl-channel-ports-display-monoline-message channel writer)
2282   (let ((output-port (macro-repl-channel-output-port channel)))
2283     (writer output-port)
2284     (##newline output-port)))
2285
2286 (define-prim (##repl-channel-ports-display-multiline-message channel writer)
2287   (let ((output-port (macro-repl-channel-output-port channel)))
2288     (writer output-port)))
2289
2290 (define-prim (##repl-channel-ports-display-continuation channel cont depth)
2291   (if (##repl-display-environment?)
2292       (##repl-channel-display-multiline-message
2293        (lambda (output-port)
2294          (##cmd-e cont output-port #t)))))
2295
2296 (define-prim (##repl-channel-ports-pinpoint-continuation channel cont)
2297   #f)
2298
2299 (define-prim (##repl-channel-ports-really-exit? channel)
2300   (let ((input-port (macro-repl-channel-input-port channel))
2301         (output-port (macro-repl-channel-output-port channel)))
2302     (##write-string "*** EOF again to exit" output-port)
2303     (##newline output-port)
2304     (##force-output output-port)
2305     (##not (##char? (##peek-char input-port)))))
2306
2307 (define-prim (##repl-channel-ports-newline channel)
2308   (let ((output-port (macro-repl-channel-output-port channel)))
2309     (##newline output-port)))
2310
2311 ;;;============================================================================
2312
2313 ;;; Read eval print loop.
2314
2315 ;;;----------------------------------------------------------------------------
2316
2317 ;;; Evaluation within a specific continuation.
2318
2319 (implement-type-repl-context)
2320
2321 (define-prim (##thread-repl-context-get!)
2322   (or (macro-current-repl-context)
2323       (let ((repl-context
2324              (##make-initial-repl-context)))
2325         (macro-current-repl-context-set! repl-context)
2326         (macro-current-repl-context))))
2327
2328 (define-prim (##make-initial-repl-context)
2329   (macro-make-repl-context -1 0 #f #f #f #f #f))
2330
2331 (define ##repl #f)
2332 (set! ##repl
2333   (lambda (#!optional (write-reason #f) (reason #f) (toplevel? #f))
2334
2335     (define (repl)
2336       (##continuation-capture
2337        (lambda (cont)
2338          (##repl-within cont write-reason reason))))
2339
2340     (if toplevel?
2341         (##with-no-result-expected-toplevel (lambda () (repl)))
2342         (repl))))
2343
2344 (define-prim (##repl-debug #!optional (write-reason #f) (toplevel? #f))
2345   (let* ((old-setting
2346           (##set-debug-settings!
2347            (##fixnum.+ (macro-debug-settings-error-mask)
2348                        (macro-debug-settings-user-intr-mask))
2349            (##fixnum.+ (macro-debug-settings-error-repl)
2350                        (macro-debug-settings-user-intr-repl))))
2351          (results
2352           (##repl write-reason #f toplevel?)))
2353     (##set-debug-settings!
2354      (macro-debug-settings-error-mask)
2355      old-setting)
2356     results))
2357
2358 (define-prim (##repl-debug-main)
2359
2360   (##current-input-port (##repl-input-port))
2361   (##current-output-port (##repl-output-port))
2362   (##current-error-port (##repl-output-port))
2363
2364   (##repl-debug
2365    (lambda (first output-port)
2366
2367      (##define-macro (attrs kind)
2368
2369        (define style-normal    0)
2370        (define style-bold      1)
2371        (define style-underline 2)
2372        (define style-reverse   4)
2373
2374        (define color-black   0)
2375        (define color-red     1)
2376        (define color-green   2)
2377        (define color-yellow  3)
2378        (define color-blue    4)
2379        (define color-magenta 5)
2380        (define color-cyan    6)
2381        (define color-white   7)
2382        (define default-color 8)
2383
2384        (define (make-text-attr style fg bg)
2385          (+ (* style 256) fg (* bg 16)))
2386
2387        (case kind
2388          ((banner)
2389           (make-text-attr style-bold   default-color color-cyan))
2390          ((input)
2391           (make-text-attr style-bold   default-color default-color))
2392          (else
2393           (make-text-attr style-normal default-color default-color))))
2394
2395      (if (##tty? output-port)
2396        (##tty-text-attributes-set! output-port (attrs input) (attrs banner)))
2397
2398      (##write-string "Gambit " output-port)
2399      (##write-string (##system-version-string) output-port)
2400
2401      (if (##tty? output-port)
2402        (##tty-text-attributes-set! output-port (attrs input) (attrs output)))
2403
2404      (##newline output-port)
2405      (##newline output-port)
2406      #f)
2407    #t)
2408
2409   (##exit))
2410
2411 (define-prim (##repl-context-display-continuation repl-context)
2412   (##repl-channel-display-continuation
2413    (macro-repl-context-cont repl-context)
2414    (macro-repl-context-depth repl-context)))
2415
2416 (define-prim (##repl-within cont write-reason reason)
2417   (let* ((prev-repl-context
2418           (##thread-repl-context-get!))
2419          (repl-context
2420           (macro-make-repl-context
2421            (##fixnum.+ (macro-repl-context-level prev-repl-context) 1)
2422            0
2423            cont
2424            cont
2425            reason
2426            prev-repl-context
2427            #f)))
2428
2429     (##repl-channel-acquire-ownership!)
2430
2431     (if (and (##procedure? write-reason)
2432              (##repl-context-with-clean-exception-handling
2433               repl-context
2434               (lambda ()
2435                 (##repl-channel-display-multiline-message
2436                  (lambda (output-port)
2437                    (let ((first (##repl-first-interesting cont)))
2438                      (##declare (not safe)) ;; avoid procedure check on the call
2439                      ;; write-reason returns #f if REPL is to be started
2440                      (write-reason first output-port)))))))
2441
2442       (##repl-channel-release-ownership!)
2443
2444       (##repl-context-restart-pinpointing-continuation repl-context #f))))
2445
2446 (define-prim (##repl-context-restart-pinpointing-continuation
2447               repl-context
2448               show-frame?)
2449   (##repl-context-restart-exec
2450    repl-context
2451    (lambda ()
2452      (let ((cont
2453             (##repl-first-interesting
2454              (macro-repl-context-cont repl-context))))
2455        (if (and (##not (##repl-channel-pinpoint-continuation cont))
2456                 show-frame?)
2457            (##repl-channel-display-multiline-message
2458             (lambda (output-port)
2459               (##cmd-y cont
2460                        output-port
2461                        #t
2462                        (macro-repl-context-depth repl-context)))))
2463        (##repl-context-display-continuation repl-context)))))
2464
2465 (define-prim (##repl-context-restart repl-context)
2466   (##repl-context-restart-exec
2467    repl-context
2468    (lambda ()
2469      (##repl-context-display-continuation repl-context))))
2470
2471 (define-prim (##repl-context-restart-exec repl-context thunk)
2472   (##continuation-graft ;; get rid of any useless continuation frames
2473    (macro-repl-context-cont repl-context)
2474    (lambda ()
2475      (##repl-context-with-clean-exception-handling
2476       repl-context
2477       (lambda ()
2478         (##parameterize
2479          ##current-user-interrupt-handler
2480          ##void ;; ignore user interrupts
2481          (lambda ()
2482            (macro-dynamic-bind repl-context
2483              repl-context
2484              (lambda ()
2485                (thunk)
2486                (##repl-context-prompt repl-context))))))))))
2487
2488 (define-prim (##default-repl-context-prompt repl-context)
2489
2490   (define (read-command)
2491     (let ((src
2492            (##repl-channel-read-command
2493             (macro-repl-context-level repl-context)
2494             (macro-repl-context-depth repl-context))))
2495       (cond ((##eof-object? src)
2496              src)
2497             (else
2498              (let ((code (##source-code src)))
2499                (if (and (##pair? code)
2500                         (##eq? (##source-code (##car code)) 'six.prefix))
2501                    (let ((rest (##cdr code)))
2502                      (if (and (##pair? rest)
2503                               (##null? (##cdr rest)))
2504                          (##car rest)
2505                          src))
2506                    src))))))
2507
2508   (##step-off) ;; turn off single-stepping
2509
2510   (##repl-context-command repl-context (read-command)))
2511
2512 (define ##repl-context-prompt #f)
2513 (set! ##repl-context-prompt ##default-repl-context-prompt)
2514
2515 (define-prim (##default-repl-context-command repl-context src)
2516   (cond ((##eof-object? src)
2517          (##repl-channel-newline)
2518          (if (##fixnum.< 0 (macro-repl-context-level repl-context))
2519              (##repl-cmd-d repl-context))
2520          (if (##repl-channel-really-exit?)
2521              (##repl-cmd-q repl-context))
2522          (##repl-context-prompt repl-context))
2523         (else
2524          (let ((code (##source-code src)))
2525            (if (and (##pair? code)
2526                     (##eq? (##source-code (##car code)) 'unquote)
2527                     (##pair? (##cdr code))
2528                     (##null? (##cddr code)))
2529                (let* ((cmd-src (##cadr code))
2530                       (cmd (##source-code cmd-src))
2531                       (x (##assq cmd ##repl-commands-no-args))
2532                       (handler (and x (##cdr x))))
2533                  (cond
2534                   (handler
2535                    (handler repl-context))
2536                   ((and (##fixnum? cmd)
2537                         (##not (##fixnum.< cmd 0)))
2538                    (##repl-context-goto-depth repl-context cmd))
2539                   ((and (##pair? cmd)
2540                         (##pair? (##cdr cmd))
2541                         (##null? (##cddr cmd)))
2542                    (let* ((cmd2-src (##car cmd))
2543                           (cmd2 (##source-code cmd2-src))
2544                           (x (##assq cmd2 ##repl-commands-with-1-arg))
2545                           (handler (and x (##cdr x))))
2546                      (cond
2547                       (handler
2548                        (handler (##cadr cmd) repl-context))
2549                       (else
2550                        (##repl-cmd-unknown src repl-context)))))
2551                   ((##symbol? cmd)
2552                    (let* ((s (##symbol->string cmd))
2553                           (len (##string-length s))
2554                           (c (and (##fixnum.< 0 len)
2555                                   (##string-ref s (##fixnum.- len 1)))))
2556
2557                      (define (move-frame n)
2558                        (##repl-context-goto-depth
2559                         repl-context
2560                         (##fixnum.+
2561                          (macro-repl-context-depth repl-context)
2562                          (if (##char=? c #\+)
2563                              n
2564                              (##fixnum.- 0 n)))))
2565
2566                      (if (or (##char=? c #\+)
2567                              (##char=? c #\-))
2568                          (cond ((##fixnum.= len 1)
2569                                 (move-frame 1))
2570                                ((and (##fixnum.= len 2)
2571                                      (##char=? c (##string-ref s 0)))
2572                                 (move-frame ##backtrace-default-max-head))
2573                                (else
2574                                 (let ((n (##string->number
2575                                           (##substring s
2576                                                        0
2577                                                        (##fixnum.- len 1))
2578                                           10)))
2579                                   (if (and (##fixnum? n)
2580                                            (##not (##fixnum.< n 0)))
2581                                       (move-frame n)
2582                                       (##repl-cmd-unknown src repl-context)))))
2583                          (##repl-cmd-unknown src repl-context))))
2584                   (else
2585                    (##repl-cmd-unknown src repl-context))))
2586                (##repl-cmd-eval-print src repl-context))))))
2587
2588 (define ##repl-context-command #f)
2589 (set! ##repl-context-command ##default-repl-context-command)
2590
2591 (define-prim (##repl-context-goto-depth repl-context n)
2592   (##repl-context-restart-pinpointing-continuation
2593    (##repl-context-get-context repl-context n)
2594    #t))
2595
2596 (define-prim (##repl-context-get-context repl-context n)
2597   (let loop ((context repl-context))
2598     (let ((depth (macro-repl-context-depth context)))
2599       (cond ((##fixnum.< n depth)
2600              (let ((prev-depth (macro-repl-context-prev-depth context)))
2601                (if prev-depth
2602                    (loop prev-depth)
2603                    context)))
2604             ((##fixnum.< depth n)
2605              (let* ((cont
2606                      (##repl-first-interesting
2607                       (macro-repl-context-cont context)))
2608                     (next
2609                      (##continuation-next-frame cont #f)))
2610                (if next
2611                    (loop (macro-make-repl-context
2612                           (macro-repl-context-level context)
2613                           (##fixnum.+ depth 1)
2614                           next
2615                           (macro-repl-context-initial-cont context)
2616                           (macro-repl-context-reason context)
2617                           (macro-repl-context-prev-level context)
2618                           context))
2619                    context)))
2620             (else
2621              context)))))
2622
2623 (define-prim (##repl-context-cont-in-step-handler? repl-context)
2624   (let ((cont (macro-repl-context-cont repl-context)))
2625     (##step-handler-continuation? cont)))
2626
2627 (define-prim (##repl-context-cont-in-with-no-result-expected? repl-context)
2628   (let ((cont (macro-repl-context-cont repl-context)))
2629     (or (##with-no-result-expected-continuation? cont)
2630         (##with-no-result-expected-toplevel-continuation? cont))))
2631
2632 (define-prim (##repl-context-with-clean-exception-handling repl-context thunk)
2633   (##with-exception-catcher
2634    (lambda (exc)
2635      (##continuation-graft ;; get rid of any useless continuation frames
2636       (macro-repl-context-cont repl-context)
2637       (lambda ()
2638         (##repl-channel-release-ownership!)
2639         (macro-raise exc))))
2640    thunk))
2641
2642 (define-prim (##repl-context-return repl-context results)
2643   (##repl-channel-release-ownership!)
2644   (##continuation-return
2645    (macro-repl-context-cont repl-context)
2646    results))
2647
2648 (define-prim (##repl-first-interesting cont)
2649   (##continuation-first-frame cont #f))
2650
2651 (define-prim (##repl-cmd-eval-print src repl-context)
2652
2653   (##repl-channel-release-ownership!)
2654
2655   (##continuation-capture
2656    (lambda (return)
2657      (##eval-within
2658       src
2659       (macro-repl-context-cont repl-context)
2660       repl-context
2661       (lambda (results)
2662         (##call-with-values
2663          (lambda ()
2664            results)
2665          (lambda results
2666            (##repl-channel-write-results results)
2667            (##continuation-return return #f)))))))
2668
2669   (##repl-channel-acquire-ownership!)
2670
2671   (##repl-context-prompt repl-context))
2672
2673 (define-prim (##repl-cmd-unknown src repl-context)
2674   (##repl-channel-display-monoline-message
2675    (lambda (output-port)
2676      (##write (##desourcify src) output-port)
2677      (##write-string " is an unknown command" output-port)))
2678   (##repl-context-prompt repl-context))
2679
2680 (define-prim (##repl-cmd-invalid msg repl-context)
2681   (##repl-channel-display-monoline-message
2682    (lambda (output-port)
2683      (##write-string msg output-port)))
2684   (##repl-context-prompt repl-context))
2685
2686 (define-prim (##repl-cmd-? repl-context)
2687   (##repl-channel-display-multiline-message ##cmd-?)
2688   (##repl-context-prompt repl-context))
2689
2690 (define-prim (##repl-cmd-h repl-context)
2691   (let* ((reason
2692           (macro-repl-context-reason repl-context))
2693          (proc-and-args
2694           (and reason
2695                (##exception-procedure-and-arguments reason)))
2696          (proc
2697           (and proc-and-args
2698                (##car proc-and-args))))
2699     (if proc
2700         (##help proc)))
2701   (##repl-context-prompt repl-context))
2702
2703 (define-prim (##repl-cmd-d repl-context)
2704   (if (##fixnum.< 0 (macro-repl-context-level repl-context))
2705       (##repl-context-restart (macro-repl-context-prev-level repl-context))
2706       (##repl-context-prompt repl-context)))
2707
2708 (define-prim (##repl-cmd-t repl-context)
2709   (let loop ((context repl-context))
2710     (if (##fixnum.< 0 (macro-repl-context-level context))
2711         (loop (macro-repl-context-prev-level context))
2712         (##repl-context-restart context))))
2713
2714 (define-prim (##repl-cmd-q repl-context)
2715   (##repl-channel-release-ownership!)
2716   (##continuation-graft
2717    (macro-repl-context-cont repl-context)
2718    (lambda ()
2719      (##exit))))
2720
2721 (define-prim (##repl-cmd-qt repl-context)
2722   (##repl-channel-release-ownership!)
2723   (##continuation-graft
2724    (macro-repl-context-cont repl-context)
2725    (lambda ()
2726      (##thread-terminate! (macro-current-thread)))))
2727
2728 (define-prim (##repl-cmd-st repl-context)
2729   (##repl-channel-display-multiline-message
2730    (lambda (output-port)
2731      (##cmd-st (macro-thread-tgroup (macro-current-thread))
2732                output-port)))
2733   (##repl-context-prompt repl-context))
2734
2735 (define-prim (##repl-cmd-b repl-context)
2736   (##repl-cmd-b-be-bed #f repl-context))
2737
2738 (define-prim (##repl-cmd-be repl-context)
2739   (##repl-cmd-b-be-bed #t repl-context))
2740
2741 (define-prim (##repl-cmd-bed repl-context)
2742   (##repl-cmd-b-be-bed 'dynamic repl-context))
2743
2744 (define-prim (##repl-cmd-b-be-bed display-env? repl-context)
2745   (##repl-channel-display-multiline-message
2746    (lambda (output-port)
2747      (##cmd-b (##repl-first-interesting
2748                (macro-repl-context-cont repl-context))
2749               output-port
2750               (macro-repl-context-depth repl-context)
2751               display-env?)))
2752   (##repl-context-prompt repl-context))
2753
2754 (define-prim (##repl-cmd-i repl-context)
2755   (##repl-channel-display-multiline-message
2756    (lambda (output-port)
2757      (##cmd-i (##repl-first-interesting
2758                (macro-repl-context-cont repl-context))
2759               output-port)))
2760   (##repl-context-prompt repl-context))
2761
2762 (define-prim (##repl-cmd-y repl-context)
2763   (##repl-channel-display-multiline-message
2764    (lambda (output-port)
2765      (##cmd-y (##repl-first-interesting
2766                (macro-repl-context-cont repl-context))
2767               output-port
2768               #t
2769               (macro-repl-context-depth repl-context))))
2770   (##repl-context-prompt repl-context))
2771
2772 (define-prim (##repl-cmd-e repl-context)
2773   (##repl-cmd-e-ed #t repl-context))
2774
2775 (define-prim (##repl-cmd-ed repl-context)
2776   (##repl-cmd-e-ed 'dynamic repl-context))
2777
2778 (define-prim (##repl-cmd-e-ed display-env? repl-context)
2779   (##repl-channel-display-multiline-message
2780    (lambda (output-port)
2781      (##cmd-e (macro-repl-context-cont repl-context)
2782               output-port
2783               display-env?)))
2784   (##repl-context-prompt repl-context))
2785
2786 (define-prim (##repl-cmd-c repl-context)
2787   (##repl-cmd-c-s-l 'c repl-context))
2788
2789 (define-prim (##repl-cmd-s repl-context)
2790   (##repl-cmd-c-s-l 's repl-context))
2791
2792 (define-prim (##repl-cmd-l repl-context)
2793   (##repl-cmd-c-s-l 'l repl-context))
2794
2795 (define-prim (##repl-cmd-c-s-l cmd repl-context)
2796   (if (or (##repl-context-cont-in-step-handler? repl-context)
2797           (##repl-context-cont-in-with-no-result-expected? repl-context))
2798       (##repl-context-return repl-context cmd)
2799       (##repl-cmd-invalid
2800        "Continuation expects a result -- use ,(c X) or ,(s X) or ,(l X)"
2801        repl-context)))
2802
2803 (define ##repl-commands-no-args #f)
2804 (set! ##repl-commands-no-args
2805   (##list (##cons '?   ##repl-cmd-?)
2806           (##cons 'h   ##repl-cmd-h)
2807           (##cons 'd   ##repl-cmd-d)
2808           (##cons 't   ##repl-cmd-t)
2809           (##cons 'q   ##repl-cmd-q)
2810           (##cons 'qt  ##repl-cmd-qt)
2811           (##cons 'st  ##repl-cmd-st)
2812           (##cons 'b   ##repl-cmd-b)
2813           (##cons 'be  ##repl-cmd-be)
2814           (##cons 'bed ##repl-cmd-bed)
2815           (##cons 'i   ##repl-cmd-i)
2816           (##cons 'y   ##repl-cmd-y)
2817           (##cons 'e   ##repl-cmd-e)
2818           (##cons 'ed  ##repl-cmd-ed)
2819           (##cons 'c   ##repl-cmd-c)
2820           (##cons 's   ##repl-cmd-s)
2821           (##cons 'l   ##repl-cmd-l)
2822           ))
2823
2824 (define-prim (##repl-cmd-h-with-1-arg arg repl-context)
2825   (##help (##source-code arg))
2826   (##repl-context-prompt repl-context))
2827
2828 (define-prim (##repl-cmd-c-with-1-arg arg repl-context)
2829   (##repl-cmd-c-s-l-with-1-arg 'c arg repl-context))
2830
2831 (define-prim (##repl-cmd-s-with-1-arg arg repl-context)
2832   (##repl-cmd-c-s-l-with-1-arg 's arg repl-context))
2833
2834 (define-prim (##repl-cmd-l-with-1-arg arg repl-context)
2835   (##repl-cmd-c-s-l-with-1-arg 'l arg repl-context))
2836
2837 (define-prim (##repl-cmd-c-s-l-with-1-arg cmd arg repl-context)
2838   (if (##repl-context-cont-in-with-no-result-expected? repl-context)
2839       (##repl-cmd-invalid
2840        "Continuation expects no result -- use ,c or ,s or ,l"
2841        repl-context)
2842       (begin
2843         (##repl-channel-release-ownership!)
2844         (##eval-within
2845          arg
2846          (macro-repl-context-cont repl-context)
2847          repl-context
2848          (if (##repl-context-cont-in-step-handler? repl-context)
2849              (lambda (results)
2850                (##repl-channel-acquire-ownership!)
2851                (##repl-context-return
2852                 repl-context
2853                 (##vector results)))
2854              (lambda (results)
2855                (##repl-channel-acquire-ownership!)
2856                (##repl-context-return
2857                 repl-context
2858                 results)))))))
2859
2860 (define-prim (##repl-cmd-b-with-1-arg arg repl-context)
2861   (##repl-cmd-b-be-bed-e-ed-v-with-1-arg 'b arg repl-context))
2862
2863 (define-prim (##repl-cmd-be-with-1-arg arg repl-context)
2864   (##repl-cmd-b-be-bed-e-ed-v-with-1-arg 'be arg repl-context))
2865
2866 (define-prim (##repl-cmd-bed-with-1-arg arg repl-context)
2867   (##repl-cmd-b-be-bed-e-ed-v-with-1-arg 'bed arg repl-context))
2868
2869 (define-prim (##repl-cmd-e-with-1-arg arg repl-context)
2870   (##repl-cmd-b-be-bed-e-ed-v-with-1-arg 'e arg repl-context))
2871
2872 (define-prim (##repl-cmd-ed-with-1-arg arg repl-context)
2873   (##repl-cmd-b-be-bed-e-ed-v-with-1-arg 'ed arg repl-context))
2874
2875 (define-prim (##repl-cmd-v-with-1-arg arg repl-context)
2876   (##repl-cmd-b-be-bed-e-ed-v-with-1-arg 'v arg repl-context))
2877
2878 (define-prim (##repl-cmd-b-be-bed-e-ed-v-with-1-arg cmd arg repl-context)
2879   (##repl-channel-release-ownership!)
2880   (##eval-within
2881    arg
2882    (macro-repl-context-cont repl-context)
2883    repl-context
2884    (lambda (results)
2885      (let ((val results))
2886
2887        (define (handle proc-or-cont depth)
2888          (if (##eq? cmd 'v)
2889              (if (##continuation? proc-or-cont)
2890                  (let ((cont
2891                         (##repl-first-interesting
2892                          proc-or-cont)))
2893                    (##repl-within cont #f #f))
2894                  (let ((proc
2895                         proc-or-cont))
2896                    (##repl-within-proc
2897                     proc
2898                     (macro-repl-context-cont
2899                      repl-context))))
2900              (begin
2901                (##repl-channel-display-multiline-message
2902                 (lambda (output-port)
2903                   (if (or (##eq? cmd 'e)
2904                           (##eq? cmd 'ed))
2905                       (##cmd-e proc-or-cont
2906                                output-port
2907                                (if (##eq? cmd 'ed)
2908                                    'dynamic
2909                                    #t))
2910                       (let ((cont
2911                              (##repl-first-interesting
2912                               proc-or-cont)))
2913                         (##cmd-b cont
2914                                  output-port
2915                                  depth
2916                                  (if (##eq? cmd 'bed)
2917                                      'dynamic
2918                                      (##eq? cmd 'be)))))))
2919                (##repl-channel-acquire-ownership!)
2920                (##repl-context-prompt repl-context))))
2921
2922        (cond ((and (##fixnum? val)
2923                    (##not (##fixnum.< val 0)))
2924               (let* ((rc
2925                       (##repl-context-get-context
2926                        repl-context
2927                        val))
2928                      (depth
2929                       (macro-repl-context-depth rc))
2930                      (cont
2931                       (macro-repl-context-cont rc)))
2932                 (handle cont depth)))
2933              ((##continuation? val)
2934               (handle val 0))
2935              ((and (##not (or (##eq? cmd 'b)
2936                               (##eq? cmd 'be)
2937                               (##eq? cmd 'bed)))
2938                    (##procedure? val))
2939               (handle val 0))
2940              ((macro-thread? val)
2941               (if (##eq? cmd 'v)
2942                   (begin
2943                     (##thread-interrupt!
2944                      val
2945                      (lambda ()
2946                        (##handle-interrupt #f)))
2947                     (##thread-yield!)
2948                     (##repl-channel-acquire-ownership!)
2949                     (##repl-context-prompt repl-context))
2950                   (let ((cont
2951                          (##thread-continuation-capture
2952                           val)))
2953                     (handle cont 0))))
2954              (else
2955               (##repl-channel-acquire-ownership!)
2956               (##repl-cmd-invalid
2957                (cond ((or (##eq? cmd 'b)
2958                           (##eq? cmd 'be)
2959                           (##eq? cmd 'bed))
2960                       "CONTINUATION or THREAD expected")
2961                      (else
2962                       "PROCEDURE, CONTINUATION or THREAD expected"))
2963                repl-context)))))))
2964
2965 (define-prim (##repl-cmd-st-with-1-arg arg repl-context)
2966   (##repl-channel-release-ownership!)
2967   (##eval-within
2968    arg
2969    (macro-repl-context-cont repl-context)
2970    repl-context
2971    (lambda (results)
2972      (let ((val results))
2973
2974        (define (handle thread-or-tgroup)
2975          (##repl-channel-acquire-ownership!)
2976          (##repl-channel-display-multiline-message
2977           (lambda (output-port)
2978             (##cmd-st thread-or-tgroup
2979                       output-port)))
2980          (##repl-context-prompt repl-context))
2981
2982        (cond ((macro-tgroup? val)
2983               (handle val))
2984              ((macro-thread? val)
2985               (handle val))
2986              (else
2987               (##repl-channel-acquire-ownership!)
2988               (##repl-cmd-invalid
2989                "THREAD or THREAD-GROUP expected"
2990                repl-context)))))))
2991
2992 (define ##repl-commands-with-1-arg #f)
2993 (set! ##repl-commands-with-1-arg
2994   (##list (##cons 'h   ##repl-cmd-h-with-1-arg)
2995           (##cons 'c   ##repl-cmd-c-with-1-arg)
2996           (##cons 's   ##repl-cmd-s-with-1-arg)
2997           (##cons 'l   ##repl-cmd-l-with-1-arg)
2998           (##cons 'b   ##repl-cmd-b-with-1-arg)
2999           (##cons 'be  ##repl-cmd-be-with-1-arg)
3000           (##cons 'bed ##repl-cmd-bed-with-1-arg)
3001           (##cons 'e   ##repl-cmd-e-with-1-arg)
3002           (##cons 'ed  ##repl-cmd-ed-with-1-arg)
3003           (##cons 'v   ##repl-cmd-v-with-1-arg)
3004           (##cons 'st  ##repl-cmd-st-with-1-arg)
3005           ))
3006
3007 (define-prim (##repl-within-proc proc cont)
3008   (cond ((##interp-procedure? proc)
3009          (##continuation-capture
3010           (lambda (cont2)
3011
3012             (define (repl)
3013               (##continuation-capture
3014                (lambda (cont3)
3015                  (##continuation-graft
3016                   cont2
3017                   (lambda ()
3018                     (##repl-within cont3 #f #f))))))
3019
3020             (##continuation-graft
3021              cont
3022              (lambda ()
3023                (let* (($code (##interp-procedure-code proc))
3024                       (rte (##interp-procedure-rte proc)))
3025                  (##declare (not interrupts-enabled) (environment-map))
3026                  (let ((result (repl)))
3027                    (##first-argument result $code rte))))))))
3028         (else
3029          (error "Can't access compiled procedure's environment"))));;;;;;;;
3030
3031 (define-prim (##eval-within src cont repl-context receiver)
3032
3033   (define (run c rte)
3034     (##continuation-graft
3035      cont
3036      (lambda ()
3037        (macro-dynamic-bind repl-context
3038         repl-context
3039         (lambda ()
3040           (receiver
3041            (let ((rte rte))
3042              (macro-code-run c))))))))
3043
3044   (let ((src2 (##sourcify src (##make-source #f #f))))
3045     (cond ((##interp-continuation? cont)
3046            (let* (($code (##interp-continuation-code cont))
3047                   (cte (macro-code-cte $code))
3048                   (rte (##interp-continuation-rte cont)))
3049              (run (##compile-inner cte src2) rte)))
3050           ((##with-no-result-expected-toplevel-continuation? cont)
3051            (run (##compile-top ##interaction-cte src2) #f))
3052           (else
3053            (let* ((locals (##continuation-locals cont))
3054                   (cte (##cte-frame (##cte-top-cte ##interaction-cte)
3055                                     (##map ##car locals)))
3056                   (rte (macro-make-rte-from-list #f (##map ##cdr locals))))
3057              (run (##compile-inner cte src2) rte))))))
3058
3059 ;;;----------------------------------------------------------------------------
3060
3061 (define-prim (##repl-exception-handler-hook exc other-handler)
3062   (##declare (not interrupts-enabled))
3063   (let ((settings (##set-debug-settings! 0 0)))
3064     (if (and (##not (##eq? (macro-current-thread) (macro-primordial-thread)))
3065              (##fixnum.= (macro-debug-settings-uncaught-primordial)
3066                          (macro-debug-settings-uncaught settings)))
3067       (other-handler exc)
3068       (##repl
3069        (lambda (first output-port)
3070          (let ((quit? (##fixnum.= (macro-debug-settings-error settings)
3071                                   (macro-debug-settings-error-quit))))
3072            (if (and quit?
3073                     (##fixnum.= (macro-debug-settings-level settings) 0))
3074              (##exit-with-exception exc)
3075              (begin
3076                (##display-exception-in-context exc first output-port)
3077                (if quit?
3078                  (##exit-with-exception exc)
3079                  #f)))))
3080        exc))))
3081
3082 (define-prim (##default-user-interrupt-handler)
3083   (let* ((settings (##set-debug-settings! 0 0))
3084          (settings-user-intr (macro-debug-settings-user-intr settings))
3085          (defer? (##fixnum.= settings-user-intr
3086                              (macro-debug-settings-user-intr-defer))))
3087     (if defer?
3088         (set! ##deferred-user-interrupt? #t)
3089         (let ((quit? (##fixnum.= settings-user-intr
3090                                  (macro-debug-settings-user-intr-quit))))
3091           (if (and quit?
3092                    (##fixnum.= (macro-debug-settings-level settings) 0))
3093               (##exit-abnormally)
3094               (##handle-interrupt quit?))))))
3095
3096 (define-prim (##handle-interrupt quit?)
3097   (##with-no-result-expected
3098    (lambda ()
3099      (##repl
3100       (lambda (first output-port)
3101         (##display-situation
3102          "INTERRUPTED"
3103          (##continuation-creator first)
3104          (##continuation-locat first)
3105          output-port)
3106         (##newline output-port)
3107         (if quit?
3108             (##exit-abnormally)
3109             #f))))))
3110
3111 (set! ##primordial-exception-handler-hook ##repl-exception-handler-hook)
3112
3113 (if (##fixnum.= (macro-debug-settings-error (##set-debug-settings! 0 0))
3114                 (macro-debug-settings-error-single-step))
3115   (##step-on))
3116
3117 (##current-user-interrupt-handler ##default-user-interrupt-handler)
3118
3119 (define-prim (##exception->kind exc)
3120   (cond (#f;;;;;;;;;;;;;;
3121          "INTERRUPT")
3122         (else
3123          "ERROR")))
3124
3125 (define-prim (##exception->procedure exc cont)
3126   (cond ((macro-expression-parsing-exception? exc)
3127          #f)
3128         ((macro-datum-parsing-exception? exc)
3129          #f)
3130         ((and (macro-nonprocedure-operator-exception? exc)
3131               (macro-nonprocedure-operator-exception-code exc))
3132          (##extract-container
3133           (macro-nonprocedure-operator-exception-code exc)
3134           (macro-nonprocedure-operator-exception-rte exc)))
3135         (else
3136          (##continuation-creator cont))))
3137
3138 (define-prim (##exception->locat exc cont)
3139
3140   (define (source-loc source)
3141     (##source-locat source))
3142
3143   (define (code-loc code)
3144     (##code-locat code))
3145
3146   (cond ((macro-expression-parsing-exception? exc)
3147          (source-loc (macro-expression-parsing-exception-source exc)))
3148         ((macro-datum-parsing-exception? exc)
3149          (let ((re (macro-datum-parsing-exception-readenv exc)))
3150            (##readenv->locat re)))
3151         ((and (macro-nonprocedure-operator-exception? exc)
3152               (macro-nonprocedure-operator-exception-code exc))
3153          =>
3154          code-loc)
3155         (else
3156          (##continuation-locat cont))))
3157
3158 (define-prim (##display-situation kind proc locat port)
3159   (##write-string "*** " port)
3160   (##write-string kind port)
3161   (if (or proc locat)
3162     (##write-string " IN " port))
3163   (if proc
3164     (##write (##procedure-friendly-name proc) port))
3165   (if locat
3166     (begin
3167       (if proc
3168         (##write-string ", " port))
3169       (##display-locat locat #t port))))
3170
3171 (define-prim (##display-exception-in-context exc cont port)
3172   (##display-situation
3173    (##exception->kind exc)
3174    (##exception->procedure exc cont)
3175    (##exception->locat exc cont)
3176    port)
3177   (##write-string " -- " port)
3178   (##display-exception exc port))
3179
3180 (define-prim (display-exception-in-context
3181               exc
3182               cont
3183               #!optional
3184               (port (macro-absent-obj)))
3185   (macro-force-vars (exc cont port)
3186     (let ((p
3187            (if (##eq? port (macro-absent-obj))
3188                (macro-current-output-port)
3189                port)))
3190       (macro-check-continuation cont 2 (display-exception-in-context exc cont port)
3191         (macro-check-character-output-port p 3 (display-exception-in-context exc cont p)
3192           (##display-exception-in-context exc cont p))))))
3193
3194 (define-prim (##default-display-exception exc port)
3195
3196   (define max-displayed-args 15)
3197
3198   (define (display-call)
3199     (let* ((proc-and-args
3200             (##exception-procedure-and-arguments exc))
3201            (proc
3202             (and proc-and-args (##car proc-and-args))))
3203       (if proc
3204           (display-call* proc (##cdr proc-and-args)))))
3205
3206   (define (display-call* proc args)
3207     (let* ((call
3208             (##make-call-form proc args max-displayed-args))
3209            (width
3210             (##output-port-width port))
3211            (str
3212             (##object->string call width)))
3213       (if (##fixnum.< (##string-length str) width)
3214         (begin
3215           (##write-string str port)
3216           (##newline port))
3217         (let loop ((i 0) (lst call))
3218           (##write-string (if (##fixnum.= i 0) "(" " ") port)
3219           (let* ((last?
3220                   (##null? (##cdr lst)))
3221                  (w
3222                   (##fixnum.- width 2))
3223                  (s
3224                   (##object->string (##car lst) w)))
3225             (##write-string s port)
3226             (if last?
3227               (begin
3228                 (if (##fixnum.= (##string-length s) w) (##newline port))
3229                 (##write-string ")" port)
3230                 (##newline port))
3231               (begin
3232                 (##newline port)
3233                 (loop (##fixnum.+ i 1) (##cdr lst)))))))))
3234
3235   (define-prim (write-items items)
3236     (let loop ((lst items))
3237       (if (##pair? lst)
3238         (begin
3239           (##write-string " " port)
3240           (##write (##car lst) port)
3241           (loop (##cdr lst))))))
3242
3243   (define-prim (display-arg-num arg-num)
3244     (if (##fixnum.< 0 arg-num)
3245       (begin
3246         (##write-string "(Argument " port)
3247         (##write arg-num port)
3248         (##write-string ") " port))))
3249
3250   (define-prim (display-exception exc)
3251
3252     (define (err-code->string code)
3253       (let ((x (##os-err-code->string code)))
3254         (if (##string? x)
3255           x
3256           "Error code could not be converted to a string")))
3257
3258     (cond ((macro-abandoned-mutex-exception? exc)
3259            (##write-string "MUTEX was abandoned" port)
3260            (##newline port))
3261
3262           ((macro-sfun-conversion-exception? exc)
3263            (##write-string
3264             (or (macro-sfun-conversion-exception-message exc)
3265                 (err-code->string
3266                  (macro-sfun-conversion-exception-code exc)))
3267             port)
3268            (##newline port)
3269            (display-call))
3270
3271           ((macro-cfun-conversion-exception? exc)
3272            (##write-string
3273             (or (macro-cfun-conversion-exception-message exc)
3274                 (err-code->string
3275                  (macro-cfun-conversion-exception-code exc)))
3276             port)
3277            (##newline port)
3278            (display-call))
3279
3280           ((macro-datum-parsing-exception? exc)
3281            (let ((x
3282                   (##assq (macro-datum-parsing-exception-kind exc)
3283                           ##datum-parsing-exception-names)))
3284              (##write-string
3285               (if x (##cdr x) "Unknown datum parsing exception")
3286               port))
3287            (write-items (macro-datum-parsing-exception-parameters exc))
3288            (##newline port))
3289
3290           ((macro-deadlock-exception? exc)
3291            (##write-string "Deadlock detected" port)
3292            (##newline port))
3293
3294           ((macro-divide-by-zero-exception? exc)
3295            (##write-string "Divide by zero" port)
3296            (##newline port)
3297            (display-call))
3298
3299           ((macro-fixnum-overflow-exception? exc)
3300            (##write-string "FIXNUM overflow" port)
3301            (##newline port)
3302            (display-call))
3303
3304           ((macro-error-exception? exc)
3305            (##display (macro-error-exception-message exc) port)
3306            (let* ((width
3307                    (##output-port-width port))
3308                   (sep
3309                    " ")
3310                   (params
3311                    (##map (lambda (p)
3312                             (let ((s (##object->truncated-string p width)))
3313                               (if (##fixnum.= (##string-length s) width)
3314                                 (begin
3315                                   (set! sep "\n")
3316                                   (##string->limited-string
3317                                    s
3318                                    (##fixnum.- width 1)))
3319                                 s)))
3320                           (macro-error-exception-parameters exc))))
3321              (##for-each
3322               (lambda (param)
3323                 (##write-string sep port)
3324                 (##write-string param port))
3325               params)
3326              (##newline port)))
3327
3328           ((macro-invalid-hash-number-exception? exc)
3329            (##write-string "Invalid hash number" port)
3330            (##newline port)
3331            (display-call))
3332
3333           ((macro-unbound-table-key-exception? exc)
3334            (##write-string "Unbound table key" port)
3335            (##newline port)
3336            (display-call))
3337
3338           ((macro-unbound-serial-number-exception? exc)
3339            (##write-string "Unbound serial number" port)
3340            (##newline port)
3341            (display-call))
3342
3343           ((macro-unbound-os-environment-variable-exception? exc)
3344            (##write-string "Unbound OS environment variable" port)
3345            (##newline port)
3346            (display-call))
3347
3348           ((macro-unterminated-process-exception? exc)
3349            (##write-string "Process not terminated" port)
3350            (##newline port)
3351            (display-call))
3352
3353           ((macro-nonempty-input-port-character-buffer-exception? exc)
3354            (##write-string "Input port character buffer is not empty" port)
3355            (##newline port)
3356            (display-call))
3357
3358           ((macro-expression-parsing-exception? exc)
3359            (let ((x
3360                   (##assq (macro-expression-parsing-exception-kind exc)
3361                           ##expression-parsing-exception-names)))
3362              (##write-string
3363               (if x (##cdr x) "Unknown expression parsing exception")
3364               port))
3365            (write-items (macro-expression-parsing-exception-parameters exc))
3366            (##newline port)
3367            (let* ((source (macro-expression-parsing-exception-source exc))
3368                   (locat (##source-locat source)))
3369              (if (##not locat)
3370                (##pretty-print (##desourcify source) port))))
3371
3372           ((macro-heap-overflow-exception? exc)
3373            (##write-string "Heap overflow" port)
3374            (##newline port))
3375
3376           ((macro-improper-length-list-exception? exc)
3377            (display-arg-num (macro-improper-length-list-exception-arg-num exc))
3378            (##write-string "List is not of proper length" port)
3379            (##newline port)
3380            (display-call))
3381
3382           ((macro-join-timeout-exception? exc)
3383            (##write-string "'thread-join!' timed out" port)
3384            (##newline port)
3385            (display-call))
3386
3387           ((macro-mailbox-receive-timeout-exception? exc)
3388            (##write-string "mailbox receive timed out" port)
3389            (##newline port)
3390            (display-call))
3391
3392           ((macro-rpc-remote-error-exception? exc)
3393            (##write-string "RPC failed; remote error message follows" port)
3394            (##newline port)
3395            (display-call)
3396            (##write-string (macro-rpc-remote-error-exception-message exc) port))
3397
3398           ((macro-keyword-expected-exception? exc)
3399            (##write-string
3400             "Keyword argument expected"
3401             port)
3402            (##newline port)
3403            (display-call))
3404
3405           ((macro-multiple-c-return-exception? exc)
3406            (##write-string
3407             "Attempt to return to a C function that has already returned"
3408             port)
3409            (##newline port))
3410
3411           ((macro-noncontinuable-exception? exc)
3412            (##write-string "Computation cannot be continued" port)
3413            (##newline port))
3414
3415           ((macro-nonprocedure-operator-exception? exc)
3416            (##write-string
3417             "Operator is not a PROCEDURE"
3418             port)
3419            (##newline port)
3420            (display-call))
3421
3422           ((macro-number-of-arguments-limit-exception? exc)
3423            (##write-string
3424             "Number of arguments exceeds implementation limit"
3425             port)
3426            (##newline port)
3427            (display-call))
3428
3429           ((macro-os-exception? exc)
3430            (let ((message (macro-os-exception-message exc))
3431                  (code (macro-os-exception-code exc)))
3432              (##write-string
3433               (or message
3434                   (if code (err-code->string code) "Unknown OS exception"))
3435               port))
3436            (##newline port)
3437            (display-call))
3438
3439           ((macro-no-such-file-or-directory-exception? exc)
3440            (##write-string "No such file or directory" port)
3441            (##newline port)
3442            (display-call))
3443
3444           ((macro-range-exception? exc)
3445            (display-arg-num (macro-range-exception-arg-num exc))
3446            (##write-string "Out of range" port)
3447            (##newline port)
3448            (display-call))
3449
3450           ((macro-scheduler-exception? exc)
3451            (##write-string "Scheduler reported the exception: " port)
3452            (##write (macro-scheduler-exception-reason exc) port)
3453            (##newline port))
3454
3455           ((macro-stack-overflow-exception? exc)
3456            (##write-string "Stack overflow" port)
3457            (##newline port))
3458
3459           ((macro-initialized-thread-exception? exc)
3460            (##write-string "Thread is initialized" port)
3461            (##newline port)
3462            (display-call))
3463
3464           ((macro-uninitialized-thread-exception? exc)
3465            (##write-string "Thread is not initialized" port)
3466            (##newline port)
3467            (display-call))
3468
3469           ((macro-inactive-thread-exception? exc)
3470            (##write-string "Thread is not active" port)
3471            (##newline port)
3472            (display-call))
3473
3474           ((macro-started-thread-exception? exc)
3475            (##write-string "Thread is started" port)
3476            (##newline port)
3477            (display-call))
3478
3479           ((macro-terminated-thread-exception? exc)
3480            (##write-string "Thread is terminated" port)
3481            (##newline port)
3482            (display-call))
3483
3484           ((macro-type-exception? exc)
3485            (display-arg-num (macro-type-exception-arg-num exc))
3486            (let ((type-id
3487                   (macro-type-exception-type-id exc)))
3488              (if (##type? type-id)
3489                (begin
3490                  (##write-string "Instance of " port)
3491                  (##write type-id port))
3492                (let ((x
3493                       (##assq (macro-type-exception-type-id exc)
3494                               ##type-exception-names)))
3495                  (##write-string (if x (##cdr x) "Unknown type") port))))
3496            (##write-string " expected" port)
3497            (##newline port)
3498            (display-call))
3499
3500           ((macro-unbound-global-exception? exc)
3501            (##write-string "Unbound variable: " port)
3502            (##write (macro-unbound-global-exception-variable exc) port)
3503            (##newline port))
3504
3505           ((macro-uncaught-exception? exc)
3506            (##write-string "Uncaught exception: " port)
3507            (##write (macro-uncaught-exception-reason exc) port)
3508            (##newline port)
3509            (display-call))
3510
3511           ((macro-unknown-keyword-argument-exception? exc)
3512            (##write-string
3513             "Unknown keyword argument passed to procedure"
3514             port)
3515            (##newline port)
3516            (display-call))
3517
3518           ((macro-wrong-number-of-arguments-exception? exc)
3519            (##write-string
3520             "Wrong number of arguments passed to procedure"
3521             port)
3522            (##newline port)
3523            (display-call))
3524
3525           (else
3526            (##write-string "This object was raised: " port)
3527            (##write exc port)
3528            (##newline port))))
3529
3530   (display-exception exc))
3531
3532 (define-prim (##exception-procedure-and-arguments exc)
3533   (cond ((macro-sfun-conversion-exception? exc)
3534          (##cons
3535           (macro-sfun-conversion-exception-procedure exc)
3536           (macro-sfun-conversion-exception-arguments exc)))
3537
3538         ((macro-cfun-conversion-exception? exc)
3539          (##cons
3540           (macro-cfun-conversion-exception-procedure exc)
3541           (macro-cfun-conversion-exception-arguments exc)))
3542
3543         ((macro-divide-by-zero-exception? exc)
3544          (##cons
3545           (macro-divide-by-zero-exception-procedure exc)
3546           (macro-divide-by-zero-exception-arguments exc)))
3547
3548         ((macro-fixnum-overflow-exception? exc)
3549          (##cons
3550           (macro-fixnum-overflow-exception-procedure exc)
3551           (macro-fixnum-overflow-exception-arguments exc)))
3552
3553         ((macro-invalid-hash-number-exception? exc)
3554          (##cons
3555           (macro-invalid-hash-number-exception-procedure exc)
3556           (macro-invalid-hash-number-exception-arguments exc)))
3557
3558         ((macro-unbound-table-key-exception? exc)
3559          (##cons
3560           (macro-unbound-table-key-exception-procedure exc)
3561           (macro-unbound-table-key-exception-arguments exc)))
3562
3563         ((macro-unbound-serial-number-exception? exc)
3564          (##cons
3565           (macro-unbound-serial-number-exception-procedure exc)
3566           (macro-unbound-serial-number-exception-arguments exc)))
3567
3568         ((macro-unbound-os-environment-variable-exception? exc)
3569          (##cons
3570           (macro-unbound-os-environment-variable-exception-procedure exc)
3571           (macro-unbound-os-environment-variable-exception-arguments exc)))
3572
3573         ((macro-unterminated-process-exception? exc)
3574          (##cons
3575           (macro-unterminated-process-exception-procedure exc)
3576           (macro-unterminated-process-exception-arguments exc)))
3577
3578         ((macro-nonempty-input-port-character-buffer-exception? exc)
3579          (##cons
3580           (macro-nonempty-input-port-character-buffer-exception-procedure exc)
3581           (macro-nonempty-input-port-character-buffer-exception-arguments exc)))
3582
3583         ((macro-improper-length-list-exception? exc)
3584          (##cons
3585           (macro-improper-length-list-exception-procedure exc)
3586           (macro-improper-length-list-exception-arguments exc)))
3587
3588         ((macro-join-timeout-exception? exc)
3589          (##cons
3590           (macro-join-timeout-exception-procedure exc)
3591           (macro-join-timeout-exception-arguments exc)))
3592
3593         ((macro-mailbox-receive-timeout-exception? exc)
3594          (##cons
3595           (macro-mailbox-receive-timeout-exception-procedure exc)
3596           (macro-mailbox-receive-timeout-exception-arguments exc)))
3597
3598         ((macro-rpc-remote-error-exception? exc)
3599          (##cons
3600           (macro-rpc-remote-error-exception-procedure exc)
3601           (macro-rpc-remote-error-exception-arguments exc)))
3602
3603         ((macro-keyword-expected-exception? exc)
3604          (##cons
3605           (macro-keyword-expected-exception-procedure exc)
3606           (macro-keyword-expected-exception-arguments exc)))
3607
3608         ((macro-nonprocedure-operator-exception? exc)
3609          (##cons
3610           (macro-nonprocedure-operator-exception-operator exc)
3611           (macro-nonprocedure-operator-exception-arguments exc)))
3612
3613         ((macro-number-of-arguments-limit-exception? exc)
3614          (##cons
3615           (macro-number-of-arguments-limit-exception-procedure exc)
3616           (macro-number-of-arguments-limit-exception-arguments exc)))
3617
3618         ((macro-os-exception? exc)
3619          (##cons
3620           (macro-os-exception-procedure exc)
3621           (macro-os-exception-arguments exc)))
3622
3623         ((macro-no-such-file-or-directory-exception? exc)
3624          (##cons
3625           (macro-no-such-file-or-directory-exception-procedure exc)
3626           (macro-no-such-file-or-directory-exception-arguments exc)))
3627
3628         ((macro-range-exception? exc)
3629          (##cons
3630           (macro-range-exception-procedure exc)
3631           (macro-range-exception-arguments exc)))
3632
3633         ((macro-initialized-thread-exception? exc)
3634          (##cons
3635           (macro-initialized-thread-exception-procedure exc)
3636           (macro-initialized-thread-exception-arguments exc)))
3637
3638         ((macro-uninitialized-thread-exception? exc)
3639          (##cons
3640           (macro-uninitialized-thread-exception-procedure exc)
3641           (macro-uninitialized-thread-exception-arguments exc)))
3642
3643         ((macro-inactive-thread-exception? exc)
3644          (##cons
3645           (macro-inactive-thread-exception-procedure exc)
3646           (macro-inactive-thread-exception-arguments exc)))
3647
3648         ((macro-started-thread-exception? exc)
3649          (##cons
3650           (macro-started-thread-exception-procedure exc)
3651           (macro-started-thread-exception-arguments exc)))
3652
3653         ((macro-terminated-thread-exception? exc)
3654          (##cons
3655           (macro-terminated-thread-exception-procedure exc)
3656           (macro-terminated-thread-exception-arguments exc)))
3657
3658         ((macro-type-exception? exc)
3659          (##cons
3660           (macro-type-exception-procedure exc)
3661           (macro-type-exception-arguments exc)))
3662
3663         ((macro-uncaught-exception? exc)
3664          (##cons
3665           (macro-uncaught-exception-procedure exc)
3666           (macro-uncaught-exception-arguments exc)))
3667
3668         ((macro-unknown-keyword-argument-exception? exc)
3669          (##cons
3670           (macro-unknown-keyword-argument-exception-procedure exc)
3671           (macro-unknown-keyword-argument-exception-arguments exc)))
3672
3673         ((macro-wrong-number-of-arguments-exception? exc)
3674          (##cons
3675           (macro-wrong-number-of-arguments-exception-procedure exc)
3676           (macro-wrong-number-of-arguments-exception-arguments exc)))
3677
3678         (else
3679          #f)))
3680
3681 (define ##display-exception-hook #f)
3682 (set! ##display-exception-hook ##default-display-exception)
3683
3684 (define-prim (##display-exception exc port)
3685   (##display-exception-hook exc port))
3686
3687 (define-prim (display-exception
3688               exc
3689               #!optional
3690               (port (macro-absent-obj)))
3691   (macro-force-vars (exc port)
3692     (let ((p
3693            (if (##eq? port (macro-absent-obj))
3694                (macro-current-output-port)
3695                port)))
3696       (macro-check-character-output-port p 2 (display-exception exc p)
3697         (##display-exception exc p)))))
3698
3699 (define ##type-exception-names #f)
3700 (set! ##type-exception-names
3701   '(
3702     ;; from "_kernel.scm":
3703     (foreign                      . "FOREIGN object")
3704
3705     ;; from "_system.scm":
3706     (hash-algorithm               . "HASH ALGORITHM")
3707
3708     ;; from "_thread.scm":
3709     (continuation                 . "CONTINUATION")
3710     (time                         . "TIME object")
3711     (absrel-time                  . "REAL or TIME object")
3712     (absrel-time-or-false         . "#f or REAL or TIME object")
3713     (thread                       . "THREAD")
3714     (mutex                        . "MUTEX")
3715     (convar                       . "CONDITION VARIABLE")
3716     (tgroup                       . "THREAD GROUP")
3717     (deadlock-exception           . "DEADLOCK-EXCEPTION object")
3718     (join-timeout-exception       . "JOIN-TIMEOUT-EXCEPTION object")
3719     (mailbox-receive-timeout-exception . "MAILBOX-RECEIVE-TIMEOUT-EXCEPTION object")
3720     (abandoned-mutex-exception    . "ABANDONED-MUTEX-EXCEPTION object")
3721     (initialized-thread-exception . "INITIALIZED-THREAD-EXCEPTION object")
3722     (uninitialized-thread-exception . "UNINITIALIZED-THREAD-EXCEPTION object")
3723     (started-thread-exception     . "STARTED-THREAD-EXCEPTION object")
3724     (terminated-thread-exception  . "TERMINATED-THREAD-EXCEPTION object")
3725     (uncaught-exception           . "UNCAUGHT-EXCEPTION object")
3726     (scheduler-exception          . "SCHEDULER-EXCEPTION object")
3727     (noncontinuable-exception     . "NONCONTINUABLE-EXCEPTION object")
3728     (low-level-exception          . "LOW-LEVEL-EXCEPTION object")
3729
3730     ;; from "_std.scm":
3731     (mutable                      . "MUTABLE object")
3732     (pair                         . "PAIR")
3733     (pair-list                    . "PAIR LIST")
3734     (char                         . "CHARACTER")
3735     (char-list                    . "CHARACTER LIST")
3736     (string                       . "STRING")
3737     (string-list                  . "STRING LIST")
3738     (list                         . "LIST")
3739     (symbol                       . "SYMBOL")
3740     (keyword                      . "KEYWORD")
3741     (vector                       . "VECTOR")
3742     (vector-list                  . "VECTOR LIST")
3743     (s8vector                     . "S8VECTOR")
3744     (s8vector-list                . "S8VECTOR LIST")
3745     (u8vector                     . "U8VECTOR")
3746     (u8vector-list                . "U8VECTOR LIST")
3747     (s16vector                    . "S16VECTOR")
3748     (s16vector-list               . "S16VECTOR LIST")
3749     (u16vector                    . "U16VECTOR")
3750     (u16vector-list               . "U16VECTOR LIST")
3751     (s32vector                    . "S32VECTOR")
3752     (s32vector-list               . "S32VECTOR LIST")
3753     (u32vector                    . "U32VECTOR")
3754     (u32vector-list               . "U32VECTOR LIST")
3755     (s64vector                    . "S64VECTOR")
3756     (s64vector-list               . "S64VECTOR LIST")
3757     (u64vector                    . "U64VECTOR")
3758     (u64vector-list               . "U64VECTOR LIST")
3759     (f32vector                    . "F32VECTOR")
3760     (f32vector-list               . "F32VECTOR LIST")
3761     (f64vector                    . "F64VECTOR")
3762     (f64vector-list               . "F64VECTOR LIST")
3763     (procedure                    . "PROCEDURE")
3764
3765     ;; from "_num.scm":
3766     (exact-signed-int8            . "Signed 8 bit exact INTEGER")
3767     (exact-signed-int8-list       . "Signed 8 bit exact INTEGER LIST")
3768     (exact-unsigned-int8          . "Unsigned 8 bit exact INTEGER")
3769     (exact-unsigned-int8-list     . "Unsigned 8 bit exact INTEGER LIST")
3770     (exact-signed-int16           . "Signed 16 bit exact INTEGER")
3771     (exact-signed-int16-list      . "Signed 16 bit exact INTEGER LIST")
3772     (exact-unsigned-int16         . "Unsigned 16 bit exact INTEGER")
3773     (exact-unsigned-int16-list    . "Unsigned 16 bit exact INTEGER LIST")
3774     (exact-signed-int32           . "Signed 32 bit exact INTEGER")
3775     (exact-signed-int32-list      . "Signed 32 bit exact INTEGER LIST")
3776     (exact-unsigned-int32         . "Unsigned 32 bit exact INTEGER")
3777     (exact-unsigned-int32-list    . "Unsigned 32 bit exact INTEGER LIST")
3778     (exact-signed-int64           . "Signed 64 bit exact INTEGER")
3779     (exact-signed-int64-list      . "Signed 64 bit exact INTEGER LIST")
3780     (exact-unsigned-int64         . "Unsigned 64 bit exact INTEGER")
3781     (exact-unsigned-int64-list    . "Unsigned 64 bit exact INTEGER LIST")
3782     (inexact-real                 . "Inexact REAL")
3783     (inexact-real-list            . "Inexact REAL LIST")
3784     (number                       . "NUMBER")
3785     (real                         . "REAL")
3786     (finite-real                  . "Finite REAL")
3787     (rational                     . "RATIONAL")
3788     (integer                      . "INTEGER")
3789     (exact-integer                . "Exact INTEGER")
3790     (fixnum                       . "FIXNUM")
3791     (flonum                       . "FLONUM")
3792     (random-source-state          . "RANDOM-SOURCE state")
3793
3794     ;; from "_nonstd.scm":
3795     (string-or-nonnegative-fixnum . "STRING or nonnegative fixnum")
3796     (will                         . "WILL")
3797     (box                          . "BOX")
3798     (unterminated-process-exception . "UNTERMINATED-PROCESS-EXCEPTION object")
3799
3800     ;; from "_io.scm":
3801     (string-or-ip-address         . "STRING or IP address")
3802     (settings                     . "Port settings")
3803     (vector-or-settings           . "VECTOR or port settings")
3804     (string-or-settings           . "STRING or port settings")
3805     (u8vector-or-settings         . "U8VECTOR or port settings")
3806     (exact-integer-or-string-or-settings . "Exact INTEGER or STRING or port settings")
3807     (port                         . "PORT")
3808     (input-port                   . "INPUT PORT")
3809     (output-port                  . "OUTPUT PORT")
3810     (character-input-port         . "Character INPUT PORT")
3811     (character-output-port        . "Character OUTPUT PORT")
3812     (byte-input-port              . "Byte INPUT PORT")
3813     (byte-output-port             . "Byte OUTPUT PORT")
3814     (device-input-port            . "Device INPUT PORT")
3815     (device-output-port           . "Device OUTPUT PORT")
3816     (vector-input-port            . "Vector INPUT PORT")
3817     (vector-output-port           . "Vector OUTPUT PORT")
3818     (string-input-port            . "String INPUT PORT")
3819     (string-output-port           . "String OUTPUT PORT")
3820     (u8vector-input-port          . "U8vector INPUT PORT")
3821     (u8vector-output-port         . "U8vector OUTPUT PORT")
3822     (file-port                    . "File PORT")
3823     (tty-port                     . "Tty PORT")
3824     (tcp-client-port              . "Tcp client PORT")
3825     (tcp-server-port              . "Tcp server PORT")
3826     (pipe-port                    . "Pipe PORT")
3827     (serial-port                  . "Serial PORT")
3828     (directory-port               . "Directory PORT")
3829     (event-queue-port             . "Event-queue PORT")
3830     (timer-port                   . "Timer PORT")
3831     (readtable                    . "READTABLE")
3832     (hostent                      . "HOSTENT")
3833     (datum-parsing-exception      . "DATUM PARSING EXCEPTION object")
3834     (network-family               . "NETWORK FAMILY")
3835     (network-socket-type          . "NETWORK SOCKET-TYPE")
3836     (network-protocol             . "NETWORK PROTOCOL")
3837
3838     ;; from "_eval.scm":
3839     (expression-parsing-exception . "EXPRESSION PARSING EXCEPTION object")
3840
3841     ;; from "_repl.scm":
3842     (interpreted-procedure        . "Interpreted PROCEDURE")
3843    ))
3844
3845 ;;;;;;;    (psettings                    . "Invalid port settings")
3846 ;;;;;;;    (open-file                    . "Can't open file")
3847
3848
3849 (define ##datum-parsing-exception-names #f)
3850 (set! ##datum-parsing-exception-names
3851   '(
3852     (datum-or-eof-expected          . "Datum or EOF expected")
3853     (datum-expected                 . "Datum expected")
3854     (improperly-placed-dot          . "Improperly placed dot")
3855     (incomplete-form-eof-reached    . "Incomplete form, EOF reached")
3856     (incomplete-form                . "Incomplete form")
3857     (character-out-of-range         . "Character out of range")
3858     (invalid-character-name         . "Invalid '#\\' name:")
3859     (illegal-character              . "Illegal character:")
3860     (s8-expected                    . "Signed 8 bit exact integer expected")
3861     (u8-expected                    . "Unsigned 8 bit exact integer expected")
3862     (s16-expected                   . "Signed 16 bit exact integer expected")
3863     (u16-expected                   . "Unsigned 16 bit exact integer expected")
3864     (s32-expected                   . "Signed 32 bit exact integer expected")
3865     (u32-expected                   . "Unsigned 32 bit exact integer expected")
3866     (s64-expected                   . "Signed 64 bit exact integer expected")
3867     (u64-expected                   . "Unsigned 64 bit exact integer expected")
3868     (inexact-real-expected          . "Inexact real expected")
3869     (invalid-hex-escape             . "Invalid hexadecimal escape")
3870     (invalid-escaped-character      . "Invalid escaped character:")
3871     (open-paren-expected            . "'(' expected")
3872     (invalid-token                  . "Invalid token")
3873     (invalid-sharp-bang-name        . "Invalid '#!' name:")
3874     (duplicate-label-definition     . "Duplicate definition for label:")
3875     (missing-label-definition       . "Missing definition for label:")
3876     (illegal-label-definition       . "Illegal definition of label:")
3877     (invalid-infix-syntax-character . "Invalid infix syntax character")
3878     (invalid-infix-syntax-number    . "Invalid infix syntax number")
3879     (invalid-infix-syntax           . "Invalid infix syntax")
3880    ))
3881
3882 (define ##expression-parsing-exception-names #f)
3883 (set! ##expression-parsing-exception-names
3884   '(
3885     (id-expected                      . "Identifier expected")
3886     (invalid-module-name              . "Invalid module name")
3887     (ill-formed-namespace             . "Ill-formed namespace")
3888     (ill-formed-namespace-prefix      . "Ill-formed namespace prefix")
3889     (namespace-prefix-must-be-string  . "Namespace prefix must be a string")
3890     (macro-used-as-variable           . "Macro name can't be used as a variable:")
3891     (variable-is-immutable            . "Variable is immutable:")
3892     (ill-formed-macro-transformer     . "Macro transformer must be a lambda expression")
3893     (reserved-used-as-variable        . "Reserved identifier can't be used as a variable:")
3894     (ill-formed-special-form          . "Ill-formed special form:")
3895     (cannot-open-file                 . "Can't open file")
3896     (filename-expected                . "Filename expected")
3897     (ill-placed-define                . "Ill-placed 'define'")
3898     (ill-placed-include               . "Ill-placed 'include'")
3899     (ill-placed-define-macro          . "Ill-placed 'define-macro'")
3900     (ill-placed-define-syntax         . "Ill-placed 'define-syntax'")
3901     (ill-placed-declare               . "Ill-placed 'declare'")
3902     (ill-placed-namespace             . "Ill-placed 'namespace'")
3903 ;;    (ill-placed-library               . "Ill-placed 'library'")
3904 ;;    (ill-placed-export                . "Ill-placed 'export'")
3905 ;;    (ill-placed-import                . "Ill-placed 'import'")
3906     (unknown-location                 . "Unknown location")
3907     (ill-formed-expression            . "Ill-formed expression")
3908     (unsupported-special-form         . "Interpreter does not support")
3909     (parameter-must-be-id             . "Parameter must be an identifier")
3910     (parameter-must-be-id-or-default  . "Parameter must be an identifier or default binding")
3911     (duplicate-parameter              . "Duplicate parameter in parameter list")
3912     (duplicate-rest-parameter         . "Duplicate rest parameter in parameter list")
3913     (parameter-expected-after-rest    . "#!rest must be followed by a parameter")
3914     (rest-parm-must-be-last           . "Rest parameter must be last")
3915     (ill-formed-default               . "Ill-formed default binding")
3916     (ill-placed-optional              . "Ill-placed #!optional")
3917     (ill-placed-key                   . "Ill-placed #!key")
3918     (key-expected-after-rest          . "#!key expected after rest parameter")
3919     (ill-placed-default               . "Ill-placed default binding")
3920     (duplicate-variable-definition    . "Duplicate definition of a variable")
3921     (empty-body                       . "Body must contain at least one expression")
3922     (else-clause-not-last             . "Else clause must be last")
3923     (ill-formed-selector-list         . "Ill-formed selector list")
3924     (duplicate-variable-binding       . "Duplicate variable in bindings")
3925     (ill-formed-binding-list          . "Ill-formed binding list")
3926     (ill-formed-call                  . "Ill-formed procedure call")
3927     (ill-formed-cond-expand           . "Ill-formed 'cond-expand'")
3928     (unfulfilled-cond-expand          . "Unfulfilled 'cond-expand'")
3929    ))
3930
3931 ;;;----------------------------------------------------------------------------
3932
3933 (define-prim (##gambc-doc . args)
3934
3935   (define (gambc-doc args)
3936
3937     (define (gen-args args i)
3938       (if (##null? args)
3939           '()
3940           (##cons (arg (##string-append "ARG" (##number->string i 10))
3941                        (##car args))
3942                   (gen-args (##cdr args) (##fixnum.+ i 1)))))
3943
3944     (define (arg name val)
3945       (##string-append "GAMBC_DOC_" name "=" val))
3946
3947     (define (install-dir path)
3948       (parameterize
3949        ((##current-directory
3950          (##path-expand path)))
3951        (##current-directory)))
3952
3953     (let* ((gambcdir-bin
3954             (install-dir "~~bin"))
3955            (gambcdir-doc
3956             (install-dir "~~doc")))
3957       (##open-process-generic
3958        (macro-direction-inout)
3959        #t
3960        (lambda (port)
3961          (let ((status (##process-status port)))
3962            (##close-port port)
3963            status))
3964        open-process
3965        (##list path:
3966                (##string-append gambcdir-bin
3967                                 "gambc-doc"
3968                                 ##os-bat-extension-string-saved)
3969                arguments:
3970                '()
3971                environment:
3972                (##append
3973                 (let ((env (##os-environ)))
3974                   (if (##fixnum? env) '() env))
3975                 (##cons (arg "GAMBCDIR_BIN"
3976                              (##path-strip-trailing-directory-separator
3977                               gambcdir-bin))
3978                         (##cons (arg "GAMBCDIR_DOC"
3979                                      (##path-strip-trailing-directory-separator
3980                                       gambcdir-doc))
3981                                 (gen-args args 1))))
3982                stdin-redirection: #f
3983                stdout-redirection: #f
3984                stderr-redirection: #f))))
3985
3986   (let ((exit-status (gambc-doc args)))
3987     (if (##fixnum.= exit-status 0)
3988         (##void)
3989         (##raise-error-exception
3990          "failed to display the document"
3991          args))))
3992
3993 (define-prim (##escape-link str)
3994   (##apply ##string-append
3995            (##map (lambda (c)
3996                     (cond ((##char=? c #\space) "_")
3997                           ((##char=? c #\#) "%E2%99%AF")
3998                           ((##char=? c #\%) "%25")
3999                           ((##char=? c #\*) "%2A")
4000                           ((##char=? c #\+) "%2B")
4001                           ((##char=? c #\<) "%3C")
4002                           ((##char=? c #\>) "%3E")
4003                           (else             (##string c))))
4004                   (##string->list str))))
4005
4006 (define-prim (##show-help prefix subject)
4007   (##gambc-doc "help"
4008                subject
4009                (##help-browser)
4010                (##escape-link (##string-append prefix subject))))
4011
4012 (define ##help-browser
4013   (##make-parameter
4014    ""
4015    (lambda (val)
4016     (macro-check-string val 1 (##help-browser val)
4017       val))))
4018
4019 (define help-browser
4020   ##help-browser)
4021
4022 (define-prim (##show-definition-of subject)
4023   (let ((s
4024          (cond ((##procedure? subject)
4025                 (##object->string (##procedure-name subject)))
4026                (else
4027                 (##object->string subject)))))
4028     (##show-help "Definition of " s)))
4029
4030 (define-prim (##default-help subject)
4031   (##show-definition-of subject))
4032
4033 (define ##help-hook #f)
4034 (set! ##help-hook ##default-help)
4035
4036 (define-prim (##help subject)
4037   (##help-hook subject))
4038
4039 (define-prim (help subject)
4040   (macro-force-vars (subject)
4041     (##help subject)))
4042
4043 ;;;----------------------------------------------------------------------------
4044
4045 (define-runtime-macro (time expr)
4046   `(##time (lambda () ,expr) ',expr))
4047
4048 (define-prim (##time thunk expr)
4049   (let ((at-start (##process-statistics)))
4050     (let ((result (thunk)))
4051       (let ((at-end (##process-statistics)))
4052
4053         (define (secs->msecs x)
4054           (##inexact->exact (##round (##* x 1000))))
4055
4056         (##repl
4057          (lambda (first output-port)
4058            (let* ((user-time
4059                    (secs->msecs
4060                     (##- (##f64vector-ref at-end 0)
4061                          (##f64vector-ref at-start 0))))
4062                   (sys-time
4063                    (secs->msecs
4064                     (##- (##f64vector-ref at-end 1)
4065                          (##f64vector-ref at-start 1))))
4066                   (cpu-time
4067                    (##+ user-time sys-time))
4068                   (real-time
4069                    (secs->msecs
4070                     (##- (##f64vector-ref at-end 2)
4071                          (##f64vector-ref at-start 2))))
4072                   (gc-user-time
4073                    (secs->msecs
4074                     (##- (##f64vector-ref at-end 3)
4075                          (##f64vector-ref at-start 3))))
4076                   (gc-sys-time
4077                    (secs->msecs
4078                     (##- (##f64vector-ref at-end 4)
4079                          (##f64vector-ref at-start 4))))
4080                   (gc-real-time
4081                    (secs->msecs
4082                     (##- (##f64vector-ref at-end 5)
4083                          (##f64vector-ref at-start 5))))
4084                   (nb-gcs
4085                    (##flonum.->exact-int
4086                     (##- (##f64vector-ref at-end 6)
4087                          (##f64vector-ref at-start 6))))
4088                   (minflt
4089                    (##flonum.->exact-int
4090                     (##- (##f64vector-ref at-end 10)
4091                          (##f64vector-ref at-start 10))))
4092                   (majflt
4093                    (##flonum.->exact-int
4094                     (##- (##f64vector-ref at-end 11)
4095                          (##f64vector-ref at-start 11))))
4096                   (bytes-allocated
4097                    (##flonum.->exact-int
4098                     (##- (##- (##f64vector-ref at-end 7)
4099                               (##f64vector-ref at-start 7))
4100                          (##+ (if (##interp-procedure? thunk)
4101                                 (##f64vector-ref at-end 8) ;; thunk call frame space
4102                                 (macro-inexact-+0))
4103                               (##f64vector-ref at-end 9)))))) ;; at-end structure space
4104
4105              (define (pluralize n msg)
4106                (##write-string "    " output-port)
4107                (if (##= n 0)
4108                  (##write-string "no" output-port)
4109                  (##write n output-port))
4110                (##write-string msg output-port)
4111                (if (##not (##= n 1))
4112                  (##write-string "s" output-port)))
4113
4114              (##write (##list 'time expr) output-port)
4115              (##newline output-port)
4116
4117              (##write-string "    " output-port)
4118              (##write real-time output-port)
4119              (##write-string " ms real time" output-port)
4120              (##newline output-port)
4121
4122              (##write-string "    " output-port)
4123              (##write cpu-time output-port)
4124              (##write-string " ms cpu time (" output-port)
4125              (##write user-time output-port)
4126              (##write-string " user, " output-port)
4127              (##write sys-time output-port)
4128              (##write-string " system)" output-port)
4129              (##newline output-port)
4130
4131              (pluralize nb-gcs " collection")
4132              (if (##not (##= nb-gcs 0))
4133                (begin
4134                  (##write-string " accounting for " output-port)
4135                  (##write gc-real-time output-port)
4136                  (##write-string " ms real time (" output-port)
4137                  (##write gc-user-time output-port)
4138                  (##write-string " user, " output-port)
4139                  (##write gc-sys-time output-port)
4140                  (##write-string " system)" output-port)))
4141              (##newline output-port)
4142
4143              (pluralize bytes-allocated " byte")
4144              (##write-string " allocated" output-port)
4145              (##newline output-port)
4146
4147              (pluralize minflt " minor fault")
4148              (##newline output-port)
4149
4150              (pluralize majflt " major fault")
4151              (##newline output-port)
4152
4153              #t)))
4154
4155         result))))
4156
4157 ;;;----------------------------------------------------------------------------
4158
4159 ;; enable processing of heartbeat interrupts, user interrupts, GC
4160 ;; interrupts, etc.
4161
4162 (##enable-interrupts!)
4163
4164 ;;;============================================================================