home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / rep.scm < prev    next >
Text File  |  2001-02-27  |  30KB  |  924 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rep.scm,v 14.56 2001/02/27 17:21:01 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Read-Eval-Print Loop
  23. ;;; package: (runtime rep)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define repl:allow-restart-notifications? true)
  28. (define repl:write-result-hash-numbers? true)
  29.  
  30. (define (initialize-package!)
  31.   (set! *nearest-cmdl* false)
  32.   (set! hook/repl-eval default/repl-eval)
  33.   (set! hook/repl-write default/repl-write)
  34.   (set! hook/set-default-environment default/set-default-environment)
  35.   (set! hook/error-decision false)
  36.   (initialize-breakpoint-condition!)
  37.   unspecific)
  38.  
  39. (define (initial-top-level-repl)
  40.   (call-with-current-continuation
  41.    (lambda (continuation)
  42.      (set! root-continuation continuation)
  43.      (repl/start (make-repl false
  44.                 console-i/o-port
  45.                 user-initial-environment
  46.                 user-initial-syntax-table
  47.                 false
  48.                 `((SET-DEFAULT-DIRECTORY
  49.                    ,top-level-repl/set-default-directory))
  50.                 user-initial-prompt)
  51.          (cmdl-message/strings "Cold load finished")))))
  52.  
  53. (define root-continuation)
  54.  
  55. (define (top-level-repl/set-default-directory cmdl pathname)
  56.   cmdl
  57.   ((ucode-primitive set-working-directory-pathname! 1)
  58.    (->namestring pathname)))
  59.  
  60. ;;;; Command Loops
  61.  
  62. (define cmdl-rtd
  63.   (make-record-type "cmdl"
  64.             '(LEVEL PARENT PORT DRIVER STATE OPERATIONS PROPERTIES)))
  65.  
  66. (define cmdl? (record-predicate cmdl-rtd))
  67. (define cmdl/level (record-accessor cmdl-rtd 'LEVEL))
  68. (define cmdl/parent (record-accessor cmdl-rtd 'PARENT))
  69. (define cmdl/port (record-accessor cmdl-rtd 'PORT))
  70. (define set-cmdl/port! (record-updater cmdl-rtd 'PORT))
  71. (define cmdl/driver (record-accessor cmdl-rtd 'DRIVER))
  72. (define cmdl/state (record-accessor cmdl-rtd 'STATE))
  73. (define set-cmdl/state! (record-updater cmdl-rtd 'STATE))
  74. (define cmdl/operations (record-accessor cmdl-rtd 'OPERATIONS))
  75. (define cmdl/properties (record-accessor cmdl-rtd 'PROPERTIES))
  76.  
  77. (define make-cmdl
  78.   (let ((constructor
  79.      (record-constructor
  80.       cmdl-rtd
  81.       '(LEVEL PARENT PORT DRIVER STATE OPERATIONS PROPERTIES))))
  82.     (lambda (parent port driver state operations)
  83.       (if (not (or (false? parent) (cmdl? parent)))
  84.       (error:wrong-type-argument parent "cmdl" 'MAKE-CMDL))
  85.       (if (not (or parent port))
  86.       (error:bad-range-argument port 'MAKE-CMDL))
  87.       (constructor (if parent (+ (cmdl/level parent) 1) 1)
  88.            parent
  89.            (let ((port* (and parent (cmdl/child-port parent))))
  90.              (if port
  91.              (if (eq? port port*)
  92.                  port
  93.                  (make-transcriptable-port port))
  94.              port*))
  95.            driver
  96.            state
  97.            (parse-operations-list operations 'MAKE-CMDL)
  98.            (make-1d-table)))))
  99.  
  100. (define (cmdl/child-port cmdl)
  101.   (or (let ((operation (cmdl/local-operation cmdl 'CHILD-PORT)))
  102.     (and operation
  103.          (operation cmdl)))
  104.       (cmdl/port cmdl)))
  105.  
  106. (define (push-cmdl driver state operations)
  107.   (make-cmdl (nearest-cmdl) #f driver state operations))
  108.  
  109. (define (cmdl/base cmdl)
  110.   (let ((parent (cmdl/parent cmdl)))
  111.     (if parent
  112.     (cmdl/base parent)
  113.     cmdl)))
  114.  
  115. (define (cmdl/set-default-directory cmdl pathname)
  116.   (let ((operation (cmdl/local-operation cmdl 'SET-DEFAULT-DIRECTORY)))
  117.     (if operation
  118.     (operation cmdl pathname)))
  119.   (port/set-default-directory (cmdl/port cmdl) pathname))
  120.  
  121. (define (cmdl/start cmdl message)
  122.   (let ((port (cmdl/port cmdl)))
  123.     (let ((thunk
  124.        (lambda ()
  125.          (fluid-let ((*nearest-cmdl* cmdl)
  126.              (dynamic-handler-frames '())
  127.              (*bound-restarts*
  128.               (if (cmdl/parent cmdl) *bound-restarts* '()))
  129.              (standard-error-hook #f)
  130.              (standard-warning-hook #f)
  131.              (standard-breakpoint-hook #f)
  132.              (*working-directory-pathname*
  133.               *working-directory-pathname*)
  134.              (*default-pathname-defaults*
  135.               *default-pathname-defaults*)
  136.              (*current-input-port* #f)
  137.              (*current-output-port* #f)
  138.              (*notification-output-port* #f)
  139.              (*trace-output-port* #f)
  140.              (*interaction-i/o-port* #f))
  141.            (let loop ((message message))
  142.          (loop
  143.           (bind-abort-restart cmdl
  144.             (lambda ()
  145.               (deregister-all-events)
  146.               (with-interrupt-mask interrupt-mask/all
  147.             (lambda (interrupt-mask)
  148.               interrupt-mask
  149.               (unblock-thread-events)
  150.               (ignore-errors
  151.                (lambda ()
  152.                  ((->cmdl-message message) cmdl)))
  153.               (call-with-current-continuation
  154.                (lambda (continuation)
  155.                  (with-create-thread-continuation continuation
  156.                    (lambda ()
  157.                  ((cmdl/driver cmdl) cmdl))))))))))))))
  158.       (mutex (port/thread-mutex port)))
  159.       (let ((thread (current-thread))
  160.         (owner (thread-mutex-owner mutex)))
  161.     (cond ((and owner (not (eq? thread owner)))
  162.            (signal-thread-event owner
  163.          (let ((signaller
  164.             (or (cmdl/local-operation cmdl 'START-NON-OWNED)
  165.                 (lambda (cmdl thread)
  166.                   cmdl
  167.                   (error "Non-owner thread can't start CMDL:"
  168.                      thread)))))
  169.            (lambda ()
  170.              (unblock-thread-events)
  171.              (signaller cmdl thread))))
  172.            (stop-current-thread))
  173.           ((let ((parent (cmdl/parent cmdl)))
  174.          (and parent
  175.               (cmdl/local-operation parent 'START-CHILD)))
  176.            => (lambda (operation) (operation cmdl thunk)))
  177.           (else
  178.            (with-thread-mutex-locked mutex thunk)))))))
  179.  
  180. (define (bind-abort-restart cmdl thunk)
  181.   (call-with-current-continuation
  182.    (lambda (continuation)
  183.      (with-restart 'ABORT
  184.      (string-append "Return to "
  185.             (if (repl? cmdl)
  186.                 "read-eval-print"
  187.                 "command")
  188.             " level "
  189.             (number->string (cmdl/level cmdl))
  190.             ".")
  191.      (lambda (#!optional message)
  192.        (continuation
  193.         (cmdl-message/append
  194.          (cmdl-message/active
  195.           (lambda (port)
  196.         ;; Inform the port that the default directory has changed.
  197.         (port/set-default-directory port
  198.                         (working-directory-pathname))))
  199.          (if (default-object? message) "Abort!" message))))
  200.      values
  201.        (lambda ()
  202.      (restart/put! (first-bound-restart) cmdl-abort-restart-tag cmdl)
  203.      (thunk))))))
  204.  
  205. (define (cmdl-abort-restart? restart)
  206.   (restart/get restart cmdl-abort-restart-tag))
  207.  
  208. (define *nearest-cmdl*)
  209.  
  210. (define (nearest-cmdl)
  211.   (if (not *nearest-cmdl*) (error "NEAREST-CMDL: no cmdl"))
  212.   *nearest-cmdl*)
  213.  
  214. (define (nearest-cmdl/port)
  215.   (let ((cmdl *nearest-cmdl*))
  216.     (if cmdl
  217.     (cmdl/port cmdl)
  218.     console-i/o-port)))
  219.  
  220. (define (nearest-cmdl/level)
  221.   (let ((cmdl *nearest-cmdl*))
  222.     (if cmdl
  223.     (cmdl/level cmdl)
  224.     0)))
  225.  
  226. ;;;; Operations
  227.  
  228. (define (parse-operations-list operations procedure)
  229.   (if (not (list? operations))
  230.       (error:wrong-type-argument operations "list" procedure))
  231.   (map (lambda (operation)
  232.      (if (not (and (pair? operation)
  233.                (symbol? (car operation))
  234.                (pair? (cdr operation))
  235.                (procedure? (cadr operation))
  236.                (null? (cddr operation))))
  237.          (error:wrong-type-argument operation
  238.                     "operation binding"
  239.                     procedure))
  240.      (cons (car operation) (cadr operation)))
  241.        operations))
  242.  
  243. (define (cmdl/local-operation cmdl name)
  244.   (let ((binding (assq name (cmdl/operations cmdl))))
  245.     (and binding
  246.      (cdr binding))))
  247.  
  248. (define (cmdl/operation cmdl name)
  249.   (let loop ((cmdl cmdl))
  250.     (or (cmdl/local-operation cmdl name)
  251.     (let ((parent (cmdl/parent cmdl)))
  252.       (and parent
  253.            (loop parent))))))
  254.  
  255. (define (cmdl/operation-names cmdl)
  256.   (let cmdl-loop ((cmdl cmdl) (names '()))
  257.     (let loop ((bindings (cmdl/operations cmdl)) (names names))
  258.       (if (null? bindings)
  259.       (let ((parent (cmdl/parent cmdl)))
  260.         (if parent
  261.         (cmdl-loop parent names)
  262.         names))
  263.       (loop (cdr bindings)
  264.         (if (memq (caar bindings) names)
  265.             names
  266.             (cons (caar bindings) names)))))))
  267.  
  268. ;;;; Messages
  269.  
  270. (define (->cmdl-message object)
  271.   (cond ((not object) (cmdl-message/null))
  272.     ((string? object) (cmdl-message/strings object))
  273.     (else object)))
  274.  
  275. (define ((cmdl-message/strings . strings) cmdl)
  276.   (let ((port (cmdl/port cmdl)))
  277.     (port/with-output-terminal-mode port 'COOKED
  278.       (lambda ()
  279.     (for-each (lambda (string)
  280.             (fresh-line port)
  281.             (write-string ";" port)
  282.             (write-string string port))
  283.           strings)))))
  284.  
  285. (define ((cmdl-message/active actor) cmdl)
  286.   (let ((port (cmdl/port cmdl)))
  287.     (port/with-output-terminal-mode port 'COOKED
  288.       (lambda ()
  289.     (actor port)))))
  290.  
  291. (define (cmdl-message/append . messages)
  292.   (do ((messages messages (cdr messages)))
  293.       ((null? messages))
  294.     (set-car! messages (->cmdl-message (car messages))))
  295.   (let ((messages (delq! %cmdl-message/null messages)))
  296.     (cond ((null? messages)
  297.        (cmdl-message/null))
  298.       ((null? (cdr messages))
  299.        (car messages))
  300.       (else
  301.        (lambda (cmdl)
  302.          (for-each (lambda (message) (message cmdl)) messages))))))
  303.  
  304. (define-integrable (cmdl-message/null)
  305.   %cmdl-message/null)
  306.  
  307. (define (%cmdl-message/null cmdl)
  308.   cmdl
  309.   false)
  310.  
  311. ;;;; Interrupts
  312.  
  313. (define (cmdl-interrupt/breakpoint)
  314.   ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/BREAKPOINT)
  315.        breakpoint)))
  316.  
  317. (define (cmdl-interrupt/abort-nearest)
  318.   ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/ABORT-NEAREST)
  319.        abort->nearest)))
  320.  
  321. (define (cmdl-interrupt/abort-previous)
  322.   ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/ABORT-PREVIOUS)
  323.        abort->previous)))
  324.  
  325. (define (cmdl-interrupt/abort-top-level)
  326.   ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/ABORT-TOP-LEVEL)
  327.        abort->top-level)))
  328.  
  329. (define (abort->nearest #!optional message)
  330.   (invoke-abort (let ((restart (find-restart 'ABORT)))
  331.           (if (not restart)
  332.               (error:no-such-restart 'ABORT))
  333.           restart)
  334.         (if (default-object? message) "Abort!" message)))
  335.  
  336. (define (abort->previous #!optional message)
  337.   (invoke-abort (let ((restarts (find-restarts 'ABORT (bound-restarts))))
  338.           (let ((next (find-restarts 'ABORT (cdr restarts))))
  339.             (cond ((not (null? next)) (car next))
  340.               ((not (null? restarts)) (car restarts))
  341.               (else (error:no-such-restart 'ABORT)))))
  342.         (if (default-object? message) "Up!" message)))
  343.  
  344. (define (abort->top-level #!optional message)
  345.   (invoke-abort (let loop ((restarts (find-restarts 'ABORT (bound-restarts))))
  346.           (let ((next (find-restarts 'ABORT (cdr restarts))))
  347.             (cond ((not (null? next)) (loop next))
  348.               ((not (null? restarts)) (car restarts))
  349.               (else (error:no-such-restart 'ABORT)))))
  350.         (if (default-object? message) "Quit!" message)))
  351.  
  352. (define (find-restarts name restarts)
  353.   (let loop ((restarts restarts))
  354.     (if (or (null? restarts)
  355.         (eq? name (restart/name (car restarts))))
  356.     restarts
  357.     (loop (cdr restarts)))))
  358.  
  359. (define (invoke-abort restart message)
  360.   (let ((effector (restart/effector restart)))
  361.     (if (cmdl-abort-restart? restart)
  362.     (effector message)
  363.     (effector))))
  364.  
  365. (define cmdl-abort-restart-tag
  366.   (list 'CMDL-ABORT-RESTART-TAG))
  367.  
  368. ;;;; REP Loops
  369.  
  370. (define (make-repl parent port environment syntax-table
  371.            #!optional condition operations prompt)
  372.   (make-cmdl parent
  373.          port
  374.          repl-driver
  375.          (let ((inherit
  376.             (let ((repl (and parent (skip-non-repls parent))))
  377.               (lambda (argument default name check-arg)
  378.             (if (eq? 'INHERIT argument)
  379.                 (begin
  380.                   (if (not repl)
  381.                   (error "Can't inherit -- no REPL ancestor:"
  382.                      name))
  383.                   (default repl))
  384.                 (check-arg argument 'MAKE-REPL))))))
  385.            (make-repl-state
  386.         (inherit (if (default-object? prompt) 'INHERIT prompt)
  387.              repl/prompt
  388.              'PROMPT
  389.              (lambda (object procedure)
  390.                (if (not (string? object))
  391.                    (error:wrong-type-argument object
  392.                               "string"
  393.                               procedure))
  394.                object))
  395.         (inherit environment
  396.              repl/environment
  397.              'ENVIRONMENT
  398.              ->environment)
  399.         (inherit syntax-table
  400.              repl/syntax-table
  401.              'SYNTAX-TABLE
  402.              guarantee-syntax-table)
  403.         (if (default-object? condition) #f condition)))
  404.          (append (if (default-object? operations) '() operations)
  405.              default-repl-operations)))
  406.  
  407. (define default-repl-operations
  408.   `((START-CHILD ,(lambda (cmdl thunk) cmdl (with-history-disabled thunk)))
  409.     (START-NON-OWNED
  410.      ,(lambda (repl thread)
  411.     (let ((condition (repl/condition repl)))
  412.       (if condition
  413.           (error:derived-thread thread condition)
  414.           (error "Non-owner thread can't start REPL:" thread)))))))
  415.  
  416. (define (push-repl environment syntax-table
  417.            #!optional condition operations prompt)
  418.   (let ((parent (nearest-cmdl)))
  419.     (make-repl parent
  420.            #f
  421.            environment
  422.            syntax-table
  423.            (if (default-object? condition) false condition)
  424.            (if (default-object? operations) '() operations)
  425.            (if (default-object? prompt) 'INHERIT prompt))))
  426.  
  427. (define (repl-driver repl)
  428.   (let ((condition (repl/condition repl)))
  429.     (if (and condition (condition/error? condition))
  430.     (cond ((cmdl/operation repl 'ERROR-DECISION)
  431.            => (lambda (operation)
  432.             (operation repl condition)))
  433.           (hook/error-decision
  434.            (hook/error-decision repl condition)))))
  435.   (let ((reader-history (repl/reader-history repl))
  436.     (printer-history (repl/printer-history repl)))
  437.     (port/set-default-environment (cmdl/port repl) (repl/environment repl))
  438.     (port/set-default-syntax-table (cmdl/port repl) (repl/syntax-table repl))
  439.     (do () (false)
  440.       (let ((s-expression
  441.          (prompt-for-command-expression (cons 'STANDARD (repl/prompt repl))
  442.                         (cmdl/port repl))))
  443.     (repl-history/record! reader-history s-expression)
  444.     (let ((value
  445.            (hook/repl-eval repl
  446.                    s-expression
  447.                    (repl/environment repl)
  448.                    (repl/syntax-table repl))))
  449.       (repl-history/record! printer-history value)
  450.       (hook/repl-write repl s-expression value))))))
  451.  
  452. (define hook/repl-eval)
  453. (define (default/repl-eval repl s-expression environment syntax-table)
  454.   (let ((scode (syntax s-expression syntax-table)))
  455.     (with-repl-eval-boundary repl
  456.       (lambda ()
  457.     (extended-scode-eval scode environment)))))
  458.  
  459. (define (repl-scode-eval repl scode environment)
  460.   (with-repl-eval-boundary repl
  461.     (lambda ()
  462.       (extended-scode-eval scode environment))))
  463.  
  464. (define (with-repl-eval-boundary repl thunk)
  465.   ((ucode-primitive with-stack-marker 3)
  466.    (lambda () (with-new-history thunk))
  467.    with-repl-eval-boundary
  468.    repl))
  469.  
  470. (define hook/repl-write)
  471. (define (default/repl-write repl s-expression object)
  472.   (port/write-result (cmdl/port repl)
  473.              s-expression
  474.              object
  475.              (and repl:write-result-hash-numbers?
  476.               (object-pointer? object)
  477.               (not (interned-symbol? object))
  478.               (not (number? object))
  479.               (object-hash object))))
  480.  
  481. (define (repl/start repl #!optional message)
  482.   (cmdl/start repl
  483.           (make-repl-message repl
  484.                  (if (default-object? message)
  485.                      false
  486.                      message))))
  487.  
  488. (define (make-repl-message repl message)
  489.   (let ((condition (repl/condition repl)))
  490.     (cmdl-message/append
  491.      (or message
  492.      (and condition
  493.           (cmdl-message/strings
  494.            (fluid-let ((*unparser-list-depth-limit* 25)
  495.                (*unparser-list-breadth-limit* 100)
  496.                (*unparser-string-length-limit* 500))
  497.          (condition/report-string condition)))))
  498.      (and condition
  499.       repl:allow-restart-notifications?
  500.       (condition-restarts-message condition))
  501.      repl/set-default-environment)))
  502.  
  503. (define hook/error-decision)
  504.  
  505. (define (repl/set-default-environment repl)
  506.   (let ((parent (cmdl/parent repl))
  507.     (environment (repl/environment repl)))
  508.     (if (not (and parent
  509.           (repl? parent)
  510.           (eq? (repl/environment parent) environment)))
  511.     (let ((operation (cmdl/operation repl 'SET-DEFAULT-ENVIRONMENT)))
  512.       (if operation
  513.           (operation repl environment)
  514.           (hook/set-default-environment repl environment))))))
  515.  
  516. (define hook/set-default-environment)
  517. (define (default/set-default-environment port environment)
  518.   (let ((port (cmdl/port port)))
  519.     (port/with-output-terminal-mode port 'COOKED
  520.       (lambda ()
  521.     (if (not (interpreter-environment? environment))
  522.         (begin
  523.           (fresh-line port)
  524.           (write-string
  525.            ";Warning! this environment is a compiled-code environment:
  526. ; Assignments to most compiled-code bindings are prohibited,
  527. ; as are certain other environment operations."
  528.            port)))
  529.     (let ((package (environment->package environment)))
  530.       (if package
  531.           (begin
  532.         (fresh-line port)
  533.         (write-string ";Package: " port)
  534.         (write (package/name package) port))))))))
  535.  
  536. (define (restart #!optional n)
  537.   (let ((condition (nearest-repl/condition)))
  538.     (let ((restarts
  539.        (filter-restarts
  540.         (if condition
  541.         (condition/restarts condition)
  542.         (bound-restarts)))))
  543.       (let ((n-restarts (length restarts)))
  544.     (if (zero? n-restarts)
  545.         (error "Can't RESTART: no options available."))
  546.     (invoke-restart-interactively
  547.      (list-ref
  548.       restarts
  549.       (- n-restarts
  550.          (if (default-object? n)
  551.          (let ((port (interaction-i/o-port)))
  552.            (fresh-line port)
  553.            (write-string ";Choose an option by number:" port)
  554.            (write-restarts restarts port
  555.              (lambda (index port)
  556.                (write-string ";" port)
  557.                (write-string (string-pad-left (number->string index) 3)
  558.                      port)
  559.                (write-string ":" port)))
  560.            (let loop ()
  561.              (let ((n
  562.                 (prompt-for-evaluated-expression
  563.                  "Option number"
  564.                  (nearest-repl/environment)
  565.                  port)))
  566.                (if (and (exact-integer? n) (<= 1 n n-restarts))
  567.                n
  568.                (begin
  569.                  (beep port)
  570.                  (fresh-line port)
  571.                  (write-string
  572.                   ";Option must be an integer between 1 and "
  573.                   port)
  574.                  (write n-restarts port)
  575.                  (write-string ", inclusive.")
  576.                  (loop))))))
  577.          (begin
  578.            (if (not (exact-integer? n))
  579.                (error:wrong-type-argument n "exact integer" 'RESTART))
  580.            (if (not (<= 1 n n-restarts))
  581.                (error:bad-range-argument n 'RESTART))
  582.            n))))
  583.      condition)))))
  584.  
  585. (define (write-restarts restarts port write-index)
  586.   (newline port)
  587.   (do ((restarts restarts (cdr restarts))
  588.        (index (length restarts) (- index 1)))
  589.       ((null? restarts))
  590.     (write-index index port)
  591.     (write-string " " port)
  592.     (write-restart-report (car restarts) port)
  593.     (newline port)))
  594.  
  595. (define (filter-restarts restarts)
  596.   (let loop ((restarts restarts))
  597.     (if (null? restarts)
  598.     '()
  599.     (let ((rest
  600.            (if (cmdl-abort-restart? (car restarts))
  601.            (list-transform-positive (cdr restarts) cmdl-abort-restart?)
  602.            (loop (cdr restarts)))))
  603.       (if (restart/interactor (car restarts))
  604.           (cons (car restarts) rest)
  605.           rest)))))
  606.  
  607. (define (condition-restarts-message condition)
  608.   (cmdl-message/active
  609.    (lambda (port)
  610.      (fresh-line port)
  611.      (write-string ";To continue, call RESTART with an option number:" port)
  612.      (write-restarts (filter-restarts (condition/restarts condition)) port
  613.        (lambda (index port)
  614.      (write-string "; (RESTART " port)
  615.      (write index port)
  616.      (write-string ") =>" port))))))
  617.  
  618. (define-structure (repl-state
  619.            (conc-name repl-state/)
  620.            (constructor make-repl-state
  621.                 (prompt environment syntax-table condition)))
  622.   prompt
  623.   environment
  624.   syntax-table
  625.   (condition false read-only true)
  626.   (reader-history (make-repl-history repl-reader-history-size))
  627.   (printer-history (make-repl-history repl-printer-history-size)))
  628.  
  629. (define (repl? object)
  630.   (and (cmdl? object)
  631.        (repl-state? (cmdl/state object))))
  632.  
  633. (define-integrable (repl/prompt repl)
  634.   (repl-state/prompt (cmdl/state repl)))
  635.  
  636. (define-integrable (set-repl/prompt! repl prompt)
  637.   (set-repl-state/prompt! (cmdl/state repl) prompt))
  638.  
  639. (define-integrable (repl/environment repl)
  640.   (repl-state/environment (cmdl/state repl)))
  641.  
  642. (define (set-repl/environment! repl environment)
  643.   (set-repl-state/environment! (cmdl/state repl) environment)
  644.   (repl/set-default-environment repl)
  645.   (port/set-default-environment (cmdl/port repl) environment))
  646.  
  647. (define-integrable (repl/syntax-table repl)
  648.   (repl-state/syntax-table (cmdl/state repl)))
  649.  
  650. (define (set-repl/syntax-table! repl syntax-table)
  651.   (set-repl-state/syntax-table! (cmdl/state repl) syntax-table)
  652.   (port/set-default-syntax-table (cmdl/port repl) syntax-table))
  653.  
  654. (define-integrable (repl/condition repl)
  655.   (repl-state/condition (cmdl/state repl)))
  656.  
  657. (define-integrable (repl/reader-history repl)
  658.   (repl-state/reader-history (cmdl/state repl)))
  659.  
  660. (define-integrable (set-repl/reader-history! repl reader-history)
  661.   (set-repl-state/reader-history! (cmdl/state repl) reader-history))
  662.  
  663. (define-integrable (repl/printer-history repl)
  664.   (repl-state/printer-history (cmdl/state repl)))
  665.  
  666. (define-integrable (set-repl/printer-history! repl printer-history)
  667.   (set-repl-state/printer-history! (cmdl/state repl) printer-history))
  668.  
  669. (define (repl/parent repl)
  670.   (skip-non-repls (cmdl/parent repl)))
  671.  
  672. (define (nearest-repl)
  673.   (or (skip-non-repls (nearest-cmdl))
  674.       (error "NEAREST-REPL: no REPLs")))
  675.  
  676. (define (skip-non-repls cmdl)
  677.   (and cmdl
  678.        (if (repl-state? (cmdl/state cmdl))
  679.        cmdl
  680.        (skip-non-repls (cmdl/parent cmdl)))))
  681.  
  682. (define (repl/base repl)
  683.   (let ((parent (repl/parent repl)))
  684.     (if parent
  685.     (repl/base parent)
  686.     repl)))
  687.  
  688. (define (nearest-repl/environment)
  689.   (repl/environment (nearest-repl)))
  690.  
  691. (define (nearest-repl/syntax-table)
  692.   (repl/syntax-table (nearest-repl)))
  693.  
  694. (define (nearest-repl/condition)
  695.   (repl/condition (nearest-repl)))
  696.  
  697. ;;;; History
  698.  
  699. (define repl-reader-history-size 5)
  700. (define repl-printer-history-size 10)
  701.  
  702. (define-structure (repl-history (constructor %make-repl-history)
  703.                 (conc-name repl-history/))
  704.   (size false read-only true)
  705.   elements)
  706.  
  707. (define (make-repl-history size)
  708.   (%make-repl-history size (make-circular-list size '())))
  709.  
  710. (define (repl-history/record! history object)
  711.   (let ((elements (repl-history/elements history)))
  712.     (if (not (null? elements))
  713.     (begin
  714.       (set-car! elements object)
  715.       (set-repl-history/elements! history (cdr elements))))))
  716.  
  717. (define (repl-history/replace-current! history object)
  718.   (let ((elements (repl-history/elements history)))
  719.     (if (not (null? elements))
  720.     (set-car! (list-tail elements (- (repl-history/size history) 1))
  721.           object))))
  722.  
  723. (define (repl-history/read history n)
  724.   (if (not (and (exact-nonnegative-integer? n)
  725.         (< n (repl-history/size history))))
  726.       (error:wrong-type-argument n "history index" 'REPL-HISTORY/READ))
  727.   (list-ref (repl-history/elements history)
  728.         (- (- (repl-history/size history) 1) n)))
  729.  
  730. ;;; User Interface Stuff
  731.  
  732. (define (pe)
  733.   (let ((environment (nearest-repl/environment)))
  734.     (let ((package (environment->package environment)))
  735.       (if package
  736.       (package/name package)
  737.       environment))))
  738.  
  739. (define (ge environment)
  740.   (let ((environment (->environment environment 'GE)))
  741.     (set-repl/environment! (nearest-repl) environment)
  742.     environment))
  743.  
  744. (define (->environment object #!optional procedure)
  745.   (let ((procedure
  746.      (if (or (default-object? procedure) (not procedure))
  747.          '->ENVIRONMENT
  748.          procedure)))
  749.     (cond ((environment? object) object)
  750.       ((package? object) (package/environment object))
  751.       ((procedure? object) (procedure-environment object))
  752.       ((promise? object) (promise-environment object))
  753.       (else
  754.        (let ((package
  755.           (let ((package-name
  756.              (cond ((symbol? object) (list object))
  757.                    ((list? object) object)
  758.                    (else false))))
  759.             (and package-name
  760.              (name->package package-name)))))
  761.          (if (not package)
  762.          (error:wrong-type-argument object "environment" procedure))
  763.          (package/environment package))))))
  764.  
  765. (define (gst syntax-table)
  766.   (guarantee-syntax-table syntax-table 'GST)
  767.   (set-repl/syntax-table! (nearest-repl) syntax-table))
  768.  
  769. (define (re #!optional index)
  770.   (let ((repl (nearest-repl)))
  771.     (hook/repl-eval repl
  772.             (let ((history (repl/reader-history repl)))
  773.               (let ((s-expression
  774.                  (repl-history/read history
  775.                         (if (default-object? index)
  776.                             1
  777.                             index))))
  778.             (repl-history/replace-current! history s-expression)
  779.             s-expression))
  780.             (repl/environment repl)
  781.             (repl/syntax-table repl))))
  782.  
  783. (define (in #!optional index)
  784.   (repl-history/read (repl/reader-history (nearest-repl))
  785.              (if (default-object? index) 1 index)))
  786.  
  787. (define (out #!optional index)
  788.   (repl-history/read (repl/printer-history (nearest-repl))
  789.              (- (if (default-object? index) 1 index) 1)))
  790.  
  791. (define (read-eval-print environment message prompt)
  792.   (repl/start (push-repl environment 'INHERIT false '() prompt) message))
  793.  
  794. (define (ve environment)
  795.   (read-eval-print (->environment environment 'VE) false 'INHERIT))
  796.  
  797. (define (proceed #!optional value)
  798.   (if (default-object? value)
  799.       (continue)
  800.       (use-value value))
  801.   (let ((port (notification-output-port)))
  802.     (fresh-line port)
  803.     (write-string ";Unable to PROCEED" port)))
  804.  
  805. ;;;; Breakpoints
  806.  
  807. (define (bkpt datum . arguments)
  808.   (apply breakpoint-procedure 'CONTINUATION-ENVIRONMENT datum arguments))
  809.  
  810. (define (breakpoint-procedure environment datum . arguments)
  811.   (signal-breakpoint #f
  812.              environment
  813.              (cmdl-message/active
  814.               (lambda (port)
  815.             (fresh-line port)
  816.             (format-error-message datum arguments port)))
  817.              "bkpt>"))
  818.  
  819. (define (breakpoint #!optional message environment continuation)
  820.   (signal-breakpoint (if (default-object? continuation)
  821.              #f
  822.              continuation)
  823.              (if (default-object? environment)
  824.              (nearest-repl/environment)
  825.              environment)
  826.              (if (default-object? message)
  827.              "Break!"
  828.              message)
  829.              "break>"))
  830.  
  831. (define (signal-breakpoint continuation environment message prompt)
  832.   (call-with-current-continuation
  833.    (lambda (restart-continuation)
  834.      (let ((continuation (or continuation restart-continuation)))
  835.        (with-restart 'CONTINUE
  836.        (if (string=? "bkpt>" prompt)
  837.            "Return from BKPT."
  838.            "Continue from breakpoint.")
  839.        (lambda () (restart-continuation unspecific))
  840.        values
  841.      (lambda ()
  842.        (call-with-values
  843.            (lambda ()
  844.          (get-breakpoint-environment continuation environment message))
  845.          (lambda (environment message)
  846.            (%signal-breakpoint continuation
  847.                    environment
  848.                    message
  849.                    prompt)))))))))
  850.  
  851. (define (get-breakpoint-environment continuation environment message)
  852.   (let ((environment
  853.      (if (eq? 'CONTINUATION-ENVIRONMENT environment)
  854.          (continuation/first-subproblem-environment continuation)
  855.          environment)))
  856.     (if (eq? 'NO-ENVIRONMENT environment)
  857.     (values (nearest-repl/environment)
  858.         (cmdl-message/append
  859.          message
  860.          (cmdl-message/strings
  861.           "Breakpoint environment unavailable;"
  862.           "using REPL environment instead.")))
  863.     (values environment message))))
  864.  
  865. (define (continuation/first-subproblem-environment continuation)
  866.   (let ((frame (continuation/first-subproblem continuation)))
  867.     (if frame
  868.     (call-with-values (lambda () (stack-frame/debugging-info frame))
  869.       (lambda (expression environment subexpression)
  870.         expression subexpression
  871.         (if (debugging-info/undefined-environment? environment)
  872.         'NO-ENVIRONMENT
  873.         environment)))
  874.     'NO-ENVIRONMENT)))
  875.  
  876. (define condition-type:breakpoint)
  877. (define condition/breakpoint?)
  878. (define breakpoint/environment)
  879. (define breakpoint/message)
  880. (define breakpoint/prompt)
  881. (define %signal-breakpoint)
  882.  
  883. (define (initialize-breakpoint-condition!)
  884.   (set! condition-type:breakpoint
  885.     (make-condition-type 'BREAKPOINT #f '(ENVIRONMENT MESSAGE PROMPT)
  886.       (lambda (condition port)
  887.         condition
  888.         (write-string "Breakpoint." port))))
  889.   (set! condition/breakpoint?
  890.     (condition-predicate condition-type:breakpoint))
  891.   (set! breakpoint/environment
  892.     (condition-accessor condition-type:breakpoint 'ENVIRONMENT))
  893.   (set! breakpoint/message
  894.     (condition-accessor condition-type:breakpoint 'MESSAGE))
  895.   (set! breakpoint/prompt
  896.     (condition-accessor condition-type:breakpoint 'PROMPT))
  897.   (set! %signal-breakpoint
  898.     (let ((make-condition
  899.            (condition-constructor condition-type:breakpoint
  900.                       '(ENVIRONMENT MESSAGE PROMPT))))
  901.       (lambda (continuation environment message prompt)
  902.         (let ((condition
  903.            (make-condition continuation
  904.                    'BOUND-RESTARTS
  905.                    environment
  906.                    message
  907.                    prompt)))
  908.           (signal-condition condition)
  909.           (standard-breakpoint-handler condition)))))
  910.   unspecific)
  911.  
  912. (define (standard-breakpoint-handler condition)
  913.   (let ((hook standard-breakpoint-hook))
  914.     (if hook
  915.     (fluid-let ((standard-breakpoint-hook #f))
  916.       (hook condition))))
  917.   (repl/start (push-repl (breakpoint/environment condition)
  918.              'INHERIT
  919.              condition
  920.              '()
  921.              (breakpoint/prompt condition))
  922.           (breakpoint/message condition)))
  923.  
  924. (define standard-breakpoint-hook #f)