home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / COMMAND.SCM < prev    next >
Text File  |  1992-07-06  |  15KB  |  539 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file command.scm.
  6.  
  7. ; Command processor
  8.  
  9. (define command-level-type
  10.   (make-record-type 'command-level '(cont env condition)))
  11. (define make-command-level
  12.   (record-constructor command-level-type '(cont env condition)))
  13. (define command-level-cont (record-accessor command-level-type 'cont))
  14. (define command-level-env  (record-accessor command-level-type 'env))
  15. (define command-level-condition
  16.   (record-accessor command-level-type 'condition))
  17.  
  18. ; Command loop state:
  19.  
  20. (define $command-levels (make-fluid '()))
  21.  
  22. (define $input-port    (make-fluid (current-input-port)))
  23. (define $output-port    (make-fluid (current-output-port)))
  24. (define $interactive?   (make-fluid #f))
  25. (define $command-output (make-fluid 'hello))
  26. (define $package-for-commands $package-for-load)
  27.  
  28.  
  29. (define (command-processor resume-arg)
  30.   (let-fluid $output-port (current-output-port)
  31.     (lambda ()
  32.       (let-fluid $input-port (current-input-port)
  33.     (lambda ()
  34.       (let-fluid $interactive? (not (eq? resume-arg 'batch))
  35.         (lambda ()
  36.           (command-loop greet-user #f))))))))
  37.  
  38. ; Command loop
  39.  
  40. (define (command-loop thunk condition)
  41.   (internal-catch
  42.     (lambda (cont env)
  43.       (really-with-handler command-loop-condition-handler
  44.     (lambda ()
  45.       (let-fluid $command-levels
  46.           (cons (make-command-level cont env condition)
  47.             (fluid $command-levels))
  48.         (lambda ()
  49.           (thunk)
  50.           (if condition
  51.           (display-condition-carefully condition (fluid $output-port)))
  52.           (let loop ()
  53.         (let ((command (read-command (command-prompt))))
  54.           (if (eof-object? command)
  55.               (begin (newline)
  56.                  (pop-command-level))
  57.               (execute-command command))
  58.           (loop))))))))))
  59.  
  60. ; Command level control: pop, reset, exit
  61.  
  62. (define (pop-command-level)
  63.   (let ((levels (cdr (fluid $command-levels))))
  64.     (if (null? levels)
  65.     (if (or (not (fluid $interactive?))
  66.         (y-or-n? "Exit Scheme48" #t))
  67.         (exit 0))
  68.     (throw-to-command-level
  69.        (car levels)
  70.        (lambda ()
  71.          (let ((c (command-level-condition (car levels))))
  72.            (command-loop (lambda ()
  73.                    (if c
  74.                    (display "Back to" (fluid $output-port))))
  75.                  c)))))))
  76.  
  77. (define (reset)
  78.   (throw-to-command-level (last (fluid $command-levels))
  79.               (lambda ()
  80.                 (command-loop
  81.                    (lambda ()
  82.                  (newline (fluid $output-port))
  83.                  (write-line "Top level" (fluid $output-port)))
  84.                    #f))))
  85.  
  86. (define (exit . maybe-status)
  87.   (let ((status (if (null? maybe-status)
  88.             0
  89.             (car maybe-status))))
  90.     (throw-to-command-level (last (fluid $command-levels))
  91.                 (lambda () status))))
  92.  
  93. (define (throw-to-command-level level thunk)
  94.   (internal-throw (command-level-cont level)
  95.           (command-level-env level)
  96.           thunk))
  97.  
  98. ; Condition handler
  99.  
  100. (define (command-loop-condition-handler c h)
  101.   (cond ((warning? c)
  102.      (display-condition-carefully c (fluid $output-port))
  103.      (unspecified))            ;proceed
  104.     ((fluid $interactive?)
  105.      (command-loop unspecified c))    ;can proceed via throw-to-command-level
  106.     (else                ;batch mode
  107.      (display-condition-carefully c (fluid $output-port))
  108.      (exit 1))))
  109.  
  110. (define display-condition-carefully
  111.   (let ((display display) (newline newline))
  112.     (lambda (c port)
  113.       (if (error? (ignore-errors (lambda ()
  114.                    (newline port)
  115.                    (display-condition c port)
  116.                    #f)))
  117.       (begin (display "(Error in display-condition.)" port)
  118.          (newline port))))))
  119.  
  120. (define (last x)
  121.   (if (null? (cdr x))
  122.       (car x)
  123.       (last (cdr x))))
  124.  
  125. (define (command-prompt)
  126.   (let ((len (- (length (fluid $command-levels)) 1))
  127.     (p (fluid $package-for-commands)))
  128.     (string-append (if (= len 0)
  129.                ""
  130.                (number->string len))
  131.            (if (or (= len 0)
  132.                (eq? p user-package))
  133.                ""
  134.                " ")
  135.            (if (eq? p user-package)
  136.                ""
  137.                (symbol->string (package-id p)))
  138.            "> ")))
  139.  
  140. (define (greet-user)
  141.   (let ((port (fluid $output-port)))
  142.     (display "Welcome to Scheme48" port)
  143.     (if (fluid $image-info)
  144.     (begin (write-char #\space port)
  145.            (display (fluid $image-info) port)))
  146.     (display "." port)
  147.     (newline port)
  148.     (write-line "Copyright (c) 1992 by Richard Kelsey and Jonathan Rees." port)
  149.     (write-line "Please report bugs to scheme48-bugs@altdorf.ai.mit.edu."
  150.         port)
  151.     (write-line "Type :? for help." port)))
  152.  
  153. (define (set-interactive! i)
  154.   (set-fluid! $interactive? i))
  155.  
  156. (define (read-command prompt)
  157.   (let ((i-port (fluid $input-port))
  158.         (o-port (fluid $output-port)))
  159.     (let prompt-loop ()
  160.       (if (fluid $interactive?)
  161.       (display prompt o-port))
  162.       (let loop ()
  163.         (let ((c (peek-char i-port)))
  164.           (cond ((eof-object? c)
  165.                  (read-char i-port))
  166.                 ((char-whitespace? c)
  167.                  (read-char i-port)
  168.                  (if (char=? c #\newline)
  169.                      (prompt-loop)
  170.                      (loop)))
  171.                 ((char=? c #\:)
  172.                  (read-char i-port)
  173.                  (read-named-command i-port))
  174.                 ((char=? c #\;)
  175.          (gobble-line i-port)
  176.          (prompt-loop))
  177.         (else
  178.          (read-evaluation-command i-port))))))))
  179.  
  180. (define (read-evaluation-command i-port)
  181.   (let ((form (read-form i-port)))
  182.     (if (eq? (skip-over horizontal-space? i-port) #\newline)
  183.     (read-char i-port))
  184.     (lambda ()
  185.       (evaluate-and-print form))))
  186.  
  187. (define (horizontal-space? c)
  188.   (and (char-whitespace? c)
  189.        (not (char=? c #\newline))))
  190.   
  191.  
  192. ; Read an S-expression, allowing ## as a way to refer to last command
  193. ; output.  The use of a procedure circumvents the fact that
  194. ; DESYNTAXIFY might copy the value.
  195.  
  196. (define (read-form port)
  197.   (let ((sharp-sharp (fluid $command-output)))
  198.     (with-sharp-sharp `(',(lambda () sharp-sharp))
  199.       (lambda () (read port)))))
  200.  
  201. ; Commands are implemented as thunks, for now.
  202.  
  203. (define (execute-command command)
  204.   (command))
  205.  
  206. ; Commands
  207.  
  208. (define (read-named-command port)
  209.   (let ((c-name (read port)))
  210.     (let ((probe (table-ref command-table c-name)))
  211.       (if probe
  212.       (read-command-arguments port (car probe) (cdr probe))
  213.       (read-command-error port "Unrecognized command name")))))
  214.  
  215. (define (read-command-arguments port proc descriptions)
  216.   (let loop ((args '())
  217.              (ds descriptions))
  218.     (let ((c (skip-over horizontal-space? port)))
  219.       (if (or (eof-object? c)
  220.           (char=? c #\newline))
  221.       (if (or (null? ds) (eq? (car ds) '&rest))
  222.           (begin (read-char port)
  223.              (lambda () (apply proc (reverse args))))
  224.           (read-command-error port "Too few command arguments"))
  225.       (if (null? ds)
  226.           (read-command-error port "Too many command arguments")
  227.           (if (eq? (car ds) '&rest)
  228.           (loop (cons (read-command-argument (cadr ds) port) args)
  229.             ds)
  230.           (loop (cons (read-command-argument (car ds) port) args)
  231.             (cdr ds))))))))
  232.  
  233. (define (read-command-argument d port)
  234.   (case d
  235.     ((filename)
  236.      (read-string port char-whitespace?))
  237.     ((expression form)
  238.      (read-form port))
  239.     ((name)
  240.      (let ((thing (read port)))
  241.        (if (symbol? thing) thing (error "invalid name" thing))))
  242.     ((value)
  243.      (eval (read-form port) (fluid $package-for-commands)))
  244.     (else (error "invalid argument description" d))))
  245.  
  246. (define (read-command-error port message)
  247.   (write-line message (fluid $output-port))
  248.   (read-line port)
  249.   (lambda () 'invalid-command))
  250.  
  251. ; Particular commands
  252.  
  253. (define command-table (make-table))
  254.  
  255. (define *command-help* '())
  256.  
  257. (define (define-command name help1 help2 arg-descriptions procedure)
  258.   (table-set! command-table name (cons procedure arg-descriptions))
  259.   (set! *command-help*
  260.     (insert (list (symbol->string name)
  261.               (string-append (symbol->string name) " " help1)
  262.               help2)
  263.         *command-help*
  264.         (lambda (z1 z2)
  265.           (string<=? (car z1) (car z2))))))
  266.  
  267. (define (insert x l <)
  268.   (cond ((null? l) (list x))
  269.     ((< x (car l)) (cons x l))
  270.     (else (cons (car l) (insert x (cdr l) <)))))
  271.  
  272. (define (command-help)
  273.   (let ((o-port (fluid $output-port))
  274.     (widest (reduce max 0 (map (lambda (z) (string-length (cadr z)))
  275.                    *command-help*))))
  276.     (for-each (lambda (s)
  277.                 (write-line s o-port))
  278.               '(
  279. "This is an alpha-test version of Scheme48.  You are interacting with"
  280. "the command processor.  The command processor accepts either a command"
  281. "or a Scheme form to evaluate.  Commands are:"
  282. ""))
  283.  
  284.     (for-each (lambda (z)
  285.         (display " :" o-port)
  286.                 (display (pad-right (cadr z) widest #\space) o-port)
  287.         (display " " o-port)
  288.         (display (caddr z) o-port)
  289.         (newline o-port))
  290.           *command-help*)
  291.     (for-each (lambda (s)
  292.                 (write-line s o-port))
  293.               '(
  294. ""
  295. "The expression ## evaluates to the last value displayed by the command"
  296. "processor."
  297.                 ))))
  298.  
  299. (define-command 'help "" "print this message" '() command-help)
  300. (define-command '?    "" "same as :help"      '() command-help)
  301.  
  302. ; Evaluate a form
  303.  
  304. (define (evaluate-and-print form)
  305.   (print-command-result (eval form (fluid $package-for-commands))))
  306.  
  307. (define (print-command-result result)
  308.   (if (not (eq? result (unspecified)))
  309.       (begin (set-fluid! $command-output result)
  310.          (write (value->expression (abbreviate result))
  311.             (fluid $output-port))
  312.          (newline (fluid $output-port)))))
  313.  
  314. ; Kludgey low-tech alternative to *print-lines*.  Used by inspector...
  315.  
  316. (define $abbreviate-depth (make-fluid #f))
  317.  
  318. (define (abbreviate thing)
  319.   (let ((limit (fluid $abbreviate-depth)))
  320.     (if limit
  321.     (let abbrev ((thing thing) (depth 1))
  322.       (cond ((pair? thing)
  323.          (if (> depth limit)
  324.              (list abbreviation-marker)
  325.              (cons (abbrev (car thing) (+ depth 1))
  326.                (abbrev (cdr thing) (+ depth 1)))))
  327.         ((vector? thing)
  328.          (list->vector
  329.           (let recur ((i 0) (depth depth))
  330.             (if (> depth limit)
  331.             (list abbreviation-marker)
  332.             (if (>= i (vector-length thing))
  333.                 '()
  334.                 (cons (abbrev (vector-ref thing i)
  335.                       (+ depth 1))
  336.                   (recur (+ i 1) (+ depth 1))))))))
  337.         ;; Not good for records with fancy disclose methods
  338.         (else thing)))
  339.     thing)))
  340.  
  341. (define abbreviation-marker (string->symbol "..."))
  342.  
  343.  
  344. ; :load
  345.  
  346. (define-command 'load "<filename> ..."
  347.   "load Scheme source file(s)"
  348.   '(&rest filename)
  349.   (lambda filenames
  350.     (for-each (lambda (filename)
  351.         (load filename (fluid $package-for-commands)))
  352.           filenames)))
  353.  
  354. ; :build <exp> <filename>
  355.  
  356. (define (build start filename)
  357.   (build-image start filename))
  358.  
  359. (define-command 'build "<exp> <filename>" "application builder"
  360.   '(value filename) build)
  361.  
  362. ;"A heap image written using :dump or :build can be invoked with"
  363. ;"    s48 -i <filename> [-h <heap size>] [-a <argument>]"
  364. ;"For images made with :build <exp> <filename>, <argument> is passed as"
  365. ;"a string to the procedure that is the result of <exp>."
  366.  
  367. (define (build-image start filename)
  368.   (write-line (string-append "Writing " filename) (fluid $output-port))
  369.   (let ((state (get-dynamic-state)))
  370.     (call-with-current-continuation
  371.       (lambda (cc)
  372.     (flush-the-symbol-table!)
  373.     (write-image filename
  374.              (usual-resumer start)
  375.              (lambda ()
  376.                (initialize!) ;write-image opcode does (clear-registers)
  377.                (set-dynamic-state! state)
  378.                (cc #t)))))))
  379.  
  380.  
  381. ; :dump <filename>
  382.  
  383. (define (dump filename)
  384.   (let ((info (fluid $next-image-info)))
  385.     (set-fluid! $next-image-info "(suspended image)")
  386.     (build-image (lambda (arg)
  387.            (restore-the-symbol-table!)
  388.            (let-fluid $image-info info
  389.              (lambda ()
  390.                (command-processor arg))))
  391.          filename)))
  392.  
  393. (define-command 'dump "<filename>" "write a heap image"
  394.   '(filename) dump)
  395.  
  396. (define $image-info (make-fluid #f))
  397. (define $next-image-info (make-fluid #f))
  398.  
  399. ; Set image info for next :dump command.
  400.  
  401. (define-command 'identify-image "<exp>" "set identification for :dump"
  402.   '(expression)
  403.   (lambda (string)
  404.     (set-fluid! $next-image-info string)))
  405.  
  406. ; :reset
  407.  
  408. (define-command 'reset "" "top level"
  409.   '() reset)
  410.  
  411. ; exit
  412.  
  413. (define-command 'exit "" "leave" '(&rest value) exit)
  414.  
  415. ; batch
  416.  
  417. (define (batch)
  418.   (let ((i (not (fluid $interactive?))))
  419.     (set-interactive! i)
  420.     (write-line (if i
  421.             "Interactive mode"
  422.             "Batch mode")
  423.         (fluid $output-port))))
  424.  
  425. (define-command 'batch "" "toggle batch mode (no prompt, errors exit)"
  426.   '() batch)
  427.  
  428. ; :enable, :disable
  429.  
  430. (define (enable)
  431.   (set-fluid! $package-for-commands system-package))
  432.  
  433. (define-command 'enable "" "system internal environment"
  434.   '() enable)
  435.  
  436. (define (disable)
  437.   (set-fluid! $package-for-commands user-package))
  438.  
  439. (define-command 'disable "" "user environment"
  440.   '() disable)
  441.  
  442. ; User package
  443.  
  444. (define user-package
  445.   (make-package 'user (list scheme-package)))
  446.  
  447. (environment-define! user-package
  448.              'load
  449.              (lambda (filename)
  450.                (load filename user-package)))
  451.  
  452. ; Utilities for command processor
  453.  
  454. (define (command-loop-continuation)  ;utility by debugger
  455.   (command-level-cont (car (fluid $command-levels))))
  456.  
  457. (define (y-or-n? question eof-value)
  458.   (let ((i-port (fluid $input-port))
  459.     (o-port (fluid $output-port)))
  460.     (let loop ((count *y-or-n-eof-count*))
  461.       (display question o-port)
  462.       (display " (y/n)? " o-port)
  463.       (let ((line (read-line i-port)))
  464.     (cond ((eof-object? line)
  465.            (newline)
  466.            (if (= count 0)
  467.            eof-value
  468.            (begin (display "I'll only ask another " o-port)
  469.               (write count o-port)
  470.               (display " times.")
  471.               (newline)
  472.               (loop (- count 1)))))
  473.           ((< (string-length line) 1) (loop count))
  474.           ((char=? (string-ref line 0) #\y) #t)
  475.           ((char=? (string-ref line 0) #\n) #f)
  476.           (else (loop count)))))))
  477.  
  478. (define *y-or-n-eof-count* 100)
  479.  
  480. (define (pad-right string width padchar)
  481.   (let ((n (- width (string-length string))))
  482.     (if (<= n 0)
  483.     string
  484.     (string-append string (make-string n padchar)))))
  485.  
  486.  
  487. (define (write-line string port)
  488.   (write-string string port)
  489.   (newline port))
  490.  
  491. (define (read-line port)
  492.   (let loop ((l '()) (n 0))
  493.     (let ((c (read-char port)))
  494.       (if (eof-object? c)
  495.       c
  496.       (if (char=? c #\newline)
  497.           (reverse-list->string l n)
  498.           (loop (cons c l) (+ n 1)))))))
  499.  
  500. (define (read-string port delimiter?)
  501.   (let loop ((l '()) (n 0))
  502.     (let ((c (peek-char port)))
  503.       (cond ((or (eof-object? c)
  504.                  (delimiter? c))
  505.              (reverse-list->string l n))
  506.             (else
  507.              (loop (cons (read-char port) l) (+ n 1)))))))
  508.  
  509. (define (skip-over pred port)
  510.   (let ((c (peek-char port)))
  511.     (cond ((eof-object? c) c)
  512.       ((pred c) (read-char port) (skip-over pred port))
  513.       (else c))))
  514.  
  515. ; Find space-separated fields
  516. ;
  517. ;(define (parse-resume-argument string)
  518. ;  (define limit (string-length string))
  519. ;  (define (find pred i)
  520. ;    (cond ((>= i limit) #f)
  521. ;          ((pred (string-ref string i)) i)
  522. ;          (else (find pred (+ i 1)))))
  523. ;  (define (not-char-whitespace? c)
  524. ;    (not (char-whitespace? c)))
  525. ;  (if (= limit 0)
  526. ;      '()
  527. ;      (let recur ((i 0))
  528. ;        (let ((i (find not-char-whitespace? i)))
  529. ;          (if i
  530. ;              (let ((j (find char-whitespace? i)))
  531. ;                (if j
  532. ;                    (cons (substring string i j)
  533. ;                          (recur j))
  534. ;                    (list (substring string i limit))))
  535. ;              '())))))
  536.  
  537. ; (put 'with-sharp-sharp 'scheme-indent-hook 1)
  538. ; (put 'internal-catch 'scheme-indent-hook 0)
  539.