home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / gtk-1.2 / repl.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  4.5 KB  |  182 lines
  1. (define-module (gtk-1.2 repl)
  2.   :use-module (gtk-1.2 gtk)
  3.   :use-module (gtk-1.2 gdk)
  4.   :use-module (gtk-1.2 threads))
  5.  
  6. ;; A event driven repl
  7.  
  8. (define eof-object (with-input-from-string "" read))
  9.  
  10. (define-public repl-error-stack car)
  11. (define-public repl-error-args cadr)
  12.  
  13. (define-public (make-event-repl read eval print error-reporter)
  14.   (let ((the-last-stack #f)
  15.     (stack-saved?   #f)
  16.  
  17.     (buffer  "")
  18.     (bufpos  0)
  19.     (readeof #f))
  20.  
  21.     (define (save-stack)
  22.       (cond (stack-saved?)
  23.         ((not (memq 'debug (debug-options-interface)))
  24.          (set! the-last-stack #f)
  25.          (set! stack-saved? #t))
  26.         (else
  27.          (set! the-last-stack (make-stack #t lazy-dispatch 4))
  28.          (set! stack-saved? #t))))
  29.  
  30.     (define (lazy-dispatch . args)
  31.       (save-stack)
  32.       (apply throw args))
  33.     
  34.     (define (catch-stacked thunk handler)
  35.       (set! stack-saved? #f)
  36.       (start-stack #t
  37.            (catch #t
  38.               (lambda ()
  39.                 (lazy-catch #t
  40.                     thunk
  41.                     lazy-dispatch))
  42.               (lambda args
  43.                 (if (= (length args) 5)
  44.                 (handler 
  45.                  (list (if stack-saved?
  46.                        the-last-stack #f)
  47.                        args))
  48.                 (apply throw args))))))
  49.  
  50.     (define (bufeof?)
  51.       (>= bufpos (string-length buffer)))
  52.  
  53.     (define (discardbuf)
  54.       (set! buffer (substring buffer bufpos))
  55.       (set! bufpos 0))
  56.  
  57.     (define bufport (make-soft-port
  58.              (vector #f #f #f
  59.                  (lambda ()
  60.                    (cond ((bufeof?)
  61.                       (set! readeof #t)
  62.                       #f)
  63.                      (else
  64.                       (let ((ch (string-ref buffer bufpos)))
  65.                     (set! bufpos (1+ bufpos))
  66.                     ch))))
  67.                  #f)
  68.              "r"))
  69.  
  70.     (define (tryread)
  71.       (set! readeof #f)
  72.       (set! bufpos 0)
  73.       (let ((val
  74.          (catch-stacked
  75.           (lambda () (read bufport))
  76.           (lambda (data)
  77.         ;; when READ gets an error but has consumed the whole
  78.         ;; buffer, we assume it is some kind of `premature end
  79.         ;; of input` condition.
  80.         (cond ((not readeof)
  81.                (error-reporter data)
  82.                (discardbuf)))
  83.         eof-object))))
  84.     (if (not (eof-object? val))
  85.         (discardbuf))
  86.     val))
  87.  
  88.     (define (evalbuf)
  89.       (let loop ((form (tryread)))
  90.     (if (not (eof-object? form))
  91.         (let* ((throw-args #f)
  92.            (ans (catch-stacked
  93.              (lambda () (eval form (current-module)))
  94.              (lambda args (set! throw-args args)))))
  95.           (if throw-args
  96.           (apply error-reporter throw-args)
  97.           (print ans))
  98.           (loop (tryread))))))
  99.       
  100.     (lambda (op . args)
  101.       (case op
  102.     ((input)
  103.      (set! buffer (string-append buffer (car args)))
  104.      (evalbuf))
  105.     ((pending?)
  106.      (not (bufeof?)))))))
  107.  
  108. (define-public (repl-input repl str)
  109.   (repl 'input str))
  110.  
  111. (define-public (repl-pending? repl)
  112.   (repl 'pending?))
  113.  
  114. (define-public (repl-display-error data . opt-port)
  115.   (let ((port (if (null? opt-port) (current-error-port) (car opt-port))))
  116.     (apply display-error (repl-error-stack data) port 
  117.        (cdr (repl-error-args data)))))
  118.  
  119. (define-public (repl-display-backtrace data . opt-port)
  120.   (let ((port (if (null? opt-port) (current-error-port) (car opt-port))))
  121.     (if (repl-error-stack data)
  122.     (display-backtrace (repl-error-stack data) port))))
  123.  
  124. ;; The Gtk repl that doesn't use threads.
  125.  
  126. (define-public (gtk-event-repl)
  127.   (define inport (current-input-port))
  128.   (define outport (current-output-port))
  129.  
  130.   (define unspecified (if #f #f))
  131.   (define (prompt)
  132.     (display "gtk> " outport)
  133.     (force-output outport))
  134.   (define (print val)
  135.     (cond ((not (eq? unspecified val))
  136.        (write val outport)
  137.        (newline outport)))
  138.     (prompt))
  139.   (define (report data)
  140.     (repl-display-backtrace data outport)
  141.     (repl-display-error data outport)
  142.     (prompt))
  143.   (define (nonblocking-read port)
  144.     (let loop ((res '()))
  145.       (if (char-ready? port)
  146.       (let ((ch (read-char port)))
  147.         (if (eof-object? ch)
  148.         (if (null? res)
  149.             ch 
  150.             (apply string (reverse res)))
  151.         (loop (cons ch res))))
  152.       (apply string (reverse res)))))
  153.  
  154.   (let ((repl (make-event-repl read eval print report)))
  155.     (gtk-input-add inport
  156.            '(read)
  157.            (lambda (source condition)
  158.              (catch 'quit
  159.                 (lambda ()
  160.                   (let ((str (nonblocking-read inport)))
  161.                 (if (eof-object? str)
  162.                     (gtk-exit)
  163.                     (repl-input repl str))))
  164.                 (lambda (key . args)
  165.                   (gtk-exit (if (null? args) 0 (car args)))))))
  166.     (prompt)
  167.     (gtk-main)))
  168.  
  169. ;; The default Gtk repl.
  170.  
  171. (define-public (gtk-repl)
  172.   (cond
  173.    ((feature? 'threads)
  174.     (let ((guile-user (resolve-module '(guile-user))))
  175.       (module-use! guile-user (resolve-interface '(gtk gtk)))
  176.       (module-use! guile-user (resolve-interface '(gtk gdk)))
  177.       (gtk-threads-ensure-handler)
  178.       (add-hook! before-read-hook gdk-flush)
  179.       (top-repl)))
  180.    (else
  181.     (gtk-event-repl))))
  182.