diff options
Diffstat (limited to 'command-interface')
| -rw-r--r-- | command-interface/README | 2 | ||||
| -rw-r--r-- | command-interface/command-interface.scm | 11 | ||||
| -rw-r--r-- | command-interface/command-utils.scm | 208 | ||||
| -rw-r--r-- | command-interface/command.scm | 308 | ||||
| -rw-r--r-- | command-interface/incremental-compiler.scm | 168 |
5 files changed, 697 insertions, 0 deletions
diff --git a/command-interface/README b/command-interface/README new file mode 100644 index 0000000..f4991af --- /dev/null +++ b/command-interface/README @@ -0,0 +1,2 @@ +This directory contains code to implement the command interface and +incremental compiler. See the doc directory for details. diff --git a/command-interface/command-interface.scm b/command-interface/command-interface.scm new file mode 100644 index 0000000..1eebde3 --- /dev/null +++ b/command-interface/command-interface.scm @@ -0,0 +1,11 @@ +;;; csys.scm -- compilation unit definition for the compilation system + +(define-compilation-unit command-interface + (source-filename "$Y2/command-interface/") + (require global) + (unit command + (source-filename "command.scm")) + (unit command-utils + (source-filename "command-utils.scm")) + (unit incremental-compiler + (source-filename "incremental-compiler.scm"))) diff --git a/command-interface/command-utils.scm b/command-interface/command-utils.scm new file mode 100644 index 0000000..d46663f --- /dev/null +++ b/command-interface/command-utils.scm @@ -0,0 +1,208 @@ +;;; command-interface/command-utils.scm + +;;; These are utilities used by the command interface. + +;;; These send output to the user + +;;; This is used in emacs mode + +(define (say/em . args) + (say1 args)) + +;;; This is for both ordinary text to emacs and output to the command interface + +(define (say . args) + (say1 args)) + +(define (say1 args) + (apply (function format) (cons (current-output-port) args))) + +;;; This is for non-emacs output + +(define (say/ne . args) + (when (not *emacs-mode*) + (say1 args))) + + +;;; These random utilities should be elsewhere + +;;; This determines whether the current module is loaded & available. +;;; If the module is Main, an empty Main module is created. + +(define (cm-available?) + (cond ((table-entry *modules* *current-mod*) + '#t) + ((eq? *current-mod* '|Main|) + (make-empty-main) + '#t) + (else + '#f))) + +;;; This creates a empty module named Main to use as a scratch pad. + +(define (make-empty-main) + (compile/load "$PRELUDE/Prelude") + (setf *unit* '|Main|) + (setf *current-mod* '|Main|) + (let ((mods (parse-from-string + "module Main where {import Prelude}" + (function parse-module-list) + "foo"))) + ;;; This should generate no code at all so the returned code is ignored. + (modules->lisp-code mods) + (setf (table-entry *modules* *current-mod*) (car mods)) + (clear-extended-modules))) + +(define (eval-fragment eval?) + (cond ((not (cm-available?)) + (say "~&Module ~A is not loaded.~%" *current-mod*) + 'error) + ((memq *fragment-status* '(Compiled Saved)) + (when eval? + (eval-module *extension-module*)) + 'ok) + ((eq? *fragment-status* 'Error) + (say/ne "~&Errors exist in current fragment.~%") + 'error) + ((string=? *current-string* "") + (say/ne "~&Current extension is empty.~%") + 'error) + (else + (let ((res (compile-fragment + *current-mod* *current-string* + *extension-file-name*))) + (cond ((eq? res 'error) + (setf *fragment-status* 'Error) + (notify-error)) + (else + (setf *extension-module* res) + (setf *fragment-status* 'Compiled) + (when eval? + (eval-module *extension-module*)))))))) + +(define (set-current-file file) + (cond ((null? file) + '()) + ((null? (cdr file)) + (setf *remembered-file* (car file))) + (else + (say "~&Invalid file spec ~s.~%" file) + (funcall *abort-command*)))) + +(define (select-current-mod mods) + (when (pair? mods) + (when (not (memq *current-mod* mods)) + (setf *current-mod* (car mods)) + (say/ne "~&Now in module ~A.~%" *current-mod*)))) + +;;; Emacs mode stuff + +;;; *** bogus alert!!! This coercion may fail to produce a +;;; *** real character in some Lisps. + +(define *emacs-notify-char* (integer->char 1)) + +(define (notify-ready) + (when *emacs-mode* + (say/em "~Ar" *emacs-notify-char*) + (force-output (current-output-port)))) + +(define (notify-input-request) + (when *emacs-mode* + (say/em "~Ai" *emacs-notify-char*) + (force-output (current-output-port)))) + +(define (notify-error) + (when *emacs-mode* + (say/em "~Ae" *emacs-notify-char*) + (force-output (current-output-port)))) + +(define (notify-printers printers) + (notify-settings "p" printers)) + +(define (notify-optimizers optimizers) + (notify-settings "o" optimizers)) + +(define (notify-settings flag values) + (when *emacs-mode* + (say/em "~A~A(" *emacs-notify-char* flag) + (dolist (p values) + (say/em " ~A" (string-downcase (symbol->string p)))) + (say/em ")~%") + (force-output (current-output-port)))) + +(define (notify-status-line str) + (when *emacs-mode* + (say/em "~As~A~%" *emacs-notify-char* str) + (force-output (current-output-port)))) + +;;; These are used to drive the real compiler. + +(define *compile/compile-cflags* + (make cflags + (load-code? '#t) + (compile-code? '#t) + (write-code? '#t) + (write-interface? '#t))) + + +(define (compile/compile file) + (haskell-compile file *compile/compile-cflags*)) + + +(define *compile/load-cflags* + (make cflags + (load-code? '#t) + (compile-code? '#f) + (write-code? '#f) + (write-interface? '#f))) + +(define (compile/load file) + (haskell-compile file *compile/load-cflags*)) + + +;;; Printer setting support + +(define (set-printers args mode) + (set-switches *printers* (strings->syms args) + mode *all-printers* "printers")) + +(define (set-optimizers args mode) + (set-switches *optimizers* (strings->syms args) + mode *all-optimizers* "optimizers")) + +(define (set-switches current new mode all name) + (dolist (s new) + (when (and (not (eq? s 'all)) (not (memq s all))) + (signal-invalid-value s name all))) + (let ((res (cond ((eq? mode '+) + (set-union current new)) + ((eq? mode '-) + (set-difference current new)) + ((eq? mode '=) + (if (equal? new '(all)) + all + new))))) + res)) + +(define (signal-invalid-value s name all) + (recoverable-error 'invalid-value + "~A is not one of the valid ~A. Possible values are: ~%~A" + s name all)) + +(define (print-file file) + (call-with-input-file file (function write-all-chars))) + +(define (write-all-chars port) + (let ((line (read-line port))) + (if (eof-object? line) + 'ok + (begin + (write-line line) + (write-all-chars port))))) + +(define (strings->syms l) + (map (lambda (x) + (string->symbol (string-upcase x))) + l)) + diff --git a/command-interface/command.scm b/command-interface/command.scm new file mode 100644 index 0000000..3b98991 --- /dev/null +++ b/command-interface/command.scm @@ -0,0 +1,308 @@ + +;;; Globals used by the command interpreter + +(define *current-string* "") +(define *current-mod* '|Main|) +(define *current-command* '()) +(define *remembered-file* "Foo") +(define *fragment-status* '()) +(define *temp-counter* 0) +(define *last-compiled* "") +(define *abort-command* '()) +(define *command-dispatch* '()) +(define *extension-module* '()) +(define *extension-file-name* "interactive") + +(define (prompt mod) + (format '#f "~A> " mod)) + +(define-local-syntax (define-command name&args helpstr . body) + (let* ((str (car name&args)) + (args (cdr name&args)) + (fname (string->symbol (string-append "CMD-" str)))) + `(begin + (define (,fname arguments) + (verify-command-args ',args arguments ',helpstr) + (apply (lambda ,args ,@body) arguments)) + (setf *command-dispatch* + (nconc *command-dispatch* + (list (cons ',str (function ,fname))))) + ',fname))) + +(define (heval) + (initialize-haskell-system) + (setf *current-string* "") + (setf *fragment-status* 'Building) + (say "~&Yale Haskell ~A~A ~A~%Type :? for help.~%" + *haskell-compiler-version* *haskell-compiler-update* (identify-system)) + (read-commands)) + + +;;; This loop reads commands until a quit + +(define (read-commands) + (do ((cmd-status (read-command) (read-command))) + ((eq? cmd-status 'quit-command-loop) (exit)))) + +;;; This processes a single line of input. + +(define (read-command) + (let/cc abort-command + (setf *abort-command* (lambda () (funcall abort-command 'error))) + (setf *abort-compilation* *abort-command*) + (setf *phase* 'command-interface) + (setf *in-error-handler?* '#f) + (ready-for-input-line) + (let ((ch (peek-char))) + (cond ((eof-object? ch) + 'quit-command-loop) + ((char=? ch '#\:) + (read-char) + (execute-command)) + ((and (char=? ch '#\newline) + (not (eq? *fragment-status* 'Building))) + (read-char) + 'Ignored) + (else + (when (not (eq? *fragment-status* 'Building)) + (setf *fragment-status* 'Building) + (setf *current-string* "")) + (cond ((eqv? ch '#\=) + (read-char) + (append-to-current-string (expand-print-abbr (read-line)))) + ((eqv? ch '#\@) + (read-char) + (append-to-current-string (expand-exec-abbr (read-line)))) + (else + (append-to-current-string (read-line)))) + 'OK) + )))) + +(define (append-to-current-string string) + (setf *current-string* + (string-append *current-string* + string + (string #\newline)))) + + +(define (expand-print-abbr string) + (incf *temp-counter*) + (format '#f "temp_~a = print temp1_~a where temp1_~a = ~a" + *temp-counter* *temp-counter* *temp-counter* string)) + +(define (expand-exec-abbr string) + (incf *temp-counter*) + (format '#f "temp_~a :: Dialogue~%temp_~a = ~a" + *temp-counter* *temp-counter* string)) + + +(define (ready-for-input-line) + (when (not *emacs-mode*) + (fresh-line (current-output-port)) + (write-string (prompt *current-mod*) (current-output-port)) + (force-output (current-output-port))) + (notify-ready)) + +(define (execute-command) + (if (char=? (peek-char) '#\() ;this is the escape to the lisp evaluator + (let ((form (read))) + (eval form) + 'OK) + (let* ((string (read-line)) + (length (string-length string)) + (cmd+args (parse-command-args string 0 0 length))) + (cond ((null? cmd+args) + (say "~&Eh?~%") + 'OK) + (else + (let ((fn (assoc/test (function string-starts?) + (car cmd+args) + *command-dispatch*))) + (cond ((eq? fn '#f) + (say "~&~A: unknown command. Use :? for help.~%" + (car cmd+args)) + 'OK) + (else + (funcall (cdr fn) (cdr cmd+args)))))))))) + + +;;; This parses the command into a list of substrings. +;;; Args are separated by spaces. + +(define (parse-command-args string start next end) + (declare (type fixnum start next end) + (type string string)) + (cond ((eqv? next end) + (if (eqv? start next) + '() + (list (substring string start next)))) + ((char=? (string-ref string next) '#\space) + (let ((next-next (+ next 1))) + (if (eqv? start next) + (parse-command-args string next-next next-next end) + (cons (substring string start next) + (parse-command-args string next-next next-next end))))) + (else + (parse-command-args string start (+ next 1) end)))) + +(define (verify-command-args template args help) + (cond ((and (null? template) (null? args)) + '#t) + ((symbol? template) + '#t) + ((or (null? template) (null? args)) + (say "~&Command error.~%~A~%" help) + (funcall *abort-command*)) + (else + (verify-command-args (car template) (car args) help) + (verify-command-args (cdr template) (cdr args) help)))) + +(define-command ("?") + ":? Print the help file." + (print-file "$HASKELL/command-interface-help")) + +(define-command ("eval") + ":eval Evaluate current extension." + (eval-fragment '#t) + 'OK) + +(define-command ("save") + ":save Save current extension" + (eval-fragment '#f) + (cond ((eq? *fragment-status* 'Error) + (say/ne "~&Cannot save: errors encountered.~%")) + ((eq? *fragment-status* 'Compiled) + (extend-module *current-mod* *extension-module*) + (setf *fragment-status* 'Saved))) + 'OK) + +(define-command ("quit") + ":quit Quit the Haskell evaluator." + 'quit-command-loop) + +(define-command ("module" mod) + ":module module-name Select module for incremental evaluation." + (setf *current-mod* (string->symbol mod)) + (when (not (cm-available?)) + (say/ne "~&Warning: module ~A is not currently loaded.~%" *current-mod*)) + 'OK) + +(define-command ("run" . file) + ":run <file> Compile, load, and run a file." + (set-current-file file) + (clear-extended-modules) + (let ((mods (compile/load *remembered-file*))) + (when (pair? mods) + (dolist (m mods) + (eval-module (table-entry *modules* m))))) + 'OK) + +(define-command ("compile" . file) + ":compile <file> Compile and load a file." + (set-current-file file) + (clear-extended-modules) + (select-current-mod (compile/compile *remembered-file*)) + 'OK) + +(define-command ("load" . file) + ":load <file> Load a file." + (set-current-file file) + (clear-extended-modules) + (select-current-mod (compile/load *remembered-file*)) + 'OK) + +(define-command ("Main") + ":Main Switch to an empty Main module." + (make-empty-main) + 'OK) + +(define-command ("clear") + ":clear Clear saved definitions from current module." + (remove-extended-modules *current-mod*) + (setf *current-string* "") + (setf *fragment-status* 'Building)) + +(define-command ("list") + ":list List current extension." + (say "~&Current Haskell extension:~%~a" *current-string*) + (cond ((eq? *fragment-status* 'Error) + (say "Extension contains errors.~%")) + ((eq? *fragment-status* 'Compiled) + (say "Extension is compiled and ready.~%"))) + 'OK) + +(define-command ("kill") + ":kill Clear the current fragment." + (when (eq? *fragment-status* 'Building) + (setf *current-string* "")) + 'OK) + +(define-command ("p?") + ":p? Show available printers." + (if *emacs-mode* + (notify-printers (dynamic *printers*)) + (begin + (print-file "$HASKELL/emacs-tools/printer-help.txt") + (say "~&Active printers: ~A~%" (dynamic *printers*))) + )) + +(define-command ("p=" . passes) + ":p= pass1 pass2 ... Set printers." + (setf *printers* (set-printers passes '=)) + (say/ne "~&Setting printers: ~A~%" *printers*)) + +(define-command ("p+" . passes) + ":p+ pass1 pass2 ... Add printers." + (setf *printers* (set-printers passes '+)) + (say/ne "~&Setting printers: ~A~%" *printers*)) + +(define-command ("p-" . passes) + ":p- pass1 pass2 ... Turn off printers." + (setf *printers* (set-printers passes '-)) + (say/ne "~&Setting printers: ~A~%" *printers*)) + + + +(define-command ("o?") + ":o? Show available optimizers." + (if *emacs-mode* + (notify-optimizers (dynamic *optimizers*)) + (begin + (print-file "$HASKELL/emacs-tools/optimizer-help.txt") + (say "~&Active optimizers: ~A~%" (dynamic *optimizers*))) + )) + +(define-command ("o=" . optimizers) + ":o= optimizer1 optimizer2 ... Set optimizers." + (setf *optimizers* (set-optimizers optimizers '=)) + (say/ne "~&Setting optimizers: ~A~%" *optimizers*)) + +(define-command ("o+" . optimizers) + ":o+ optimizer1 optimizer2 ... Add optimizers." + (setf *optimizers* (set-optimizers optimizers '+)) + (say/ne "~&Setting optimizers: ~A~%" *optimizers*)) + +(define-command ("o-" . optimizers) + ":o- optimizer1 optimizer2 ... Turn off optimizers." + (setf *optimizers* (set-optimizers optimizers '-)) + (say/ne "~&Setting optimizers: ~A~%" *optimizers*)) + + +(define-command ("cd" d) + ":cd directory Change the current directory." + (cd d) + 'OK) + +(define-command ("Emacs" mode) + ":Emacs on/off Turn on or off emacs mode." + (cond ((string=? mode "on") + (setf *emacs-mode* '#t)) + ((string=? mode "off") + (setf *emacs-mode* '#f)) + (else + (say "~&Use on or off.~%")))) + +(define-command ("file" name) + ":file name" + (setf *extension-file-name* name) + 'OK) diff --git a/command-interface/incremental-compiler.scm b/command-interface/incremental-compiler.scm new file mode 100644 index 0000000..207b79d --- /dev/null +++ b/command-interface/incremental-compiler.scm @@ -0,0 +1,168 @@ +;;; ================================================================== + +;;; This deals with incremental compilation as used by the command interface. +;;; The basic theory is to create new modules which import the entire +;;; symbol table of an existing module. + + +;;; This adds a new module to the extension environment. This env is an alist +;;; of module names & extended modules. + +(define *extension-env* '()) + +(define (extend-module mod-name new-ast) + (push (tuple mod-name new-ast) *extension-env*)) + +;;; This cleans out extensions for a module. + +(define (remove-extended-modules mod-name) + (setf *extension-env* (rem-ext1 *extension-env* mod-name))) + +(define (rem-ext1 env name) + (cond ((null? env) + '()) + ((eq? (tuple-2-1 (car env)) name) + (rem-ext1 (cdr env) name)) + (else + (cons (car env) (rem-ext1 (cdr env) name))))) + +(define (clear-extended-modules) + (setf *extension-env* '())) + +;;; This retrieves the current extension to a module (if any). + +(define (updated-module name) + (let ((name+mod (assq name *extension-env*))) + (if (not (eq? name+mod '#f)) + (tuple-2-2 name+mod) + (let ((mod-in-table (table-entry *modules* name))) + (cond ((eq? mod-in-table '#f) + (signal-module-not-ready name)) + ((eq? (module-type mod-in-table) 'interface) + (signal-cant-eval-interface name)) + (else mod-in-table)))))) + +(define (signal-module-not-ready name) + (fatal-error 'module-not-ready + "Module ~A is not loaded and ready." + name)) + +(define (signal-cant-eval-interface name) + (fatal-error 'no-evaluation-in-interface + "Module ~A is an interface: evaluation not allowed." + name)) + +(define (compile-fragment module str filename) + (let ((mod-ast (updated-module module))) + (dynamic-let + ((*printers* (if (memq 'extension *printers*) *printers* '())) + (*abort-phase* '#f)) + (mlet (((t-code new-ast) (compile-fragment1 module mod-ast str filename))) + (cond ((eq? t-code 'error) + 'error) + (else + (eval t-code) + new-ast)))))) + +(define (compile-fragment1 mod-name mod-ast str filename) + (let/cc x + (dynamic-let ((*abort-compilation* (lambda () (funcall x 'error '())))) + (let* ((mods (parse-from-string + (format '#f "module ~A where~%~A~%" mod-name str) + (function parse-module-list) + filename)) + (new-mod (car mods))) + (when (not (null? (cdr mods))) + (signal-module-decl-in-extension)) + (when (not (null? (module-imports new-mod))) + (signal-import-decl-in-extension)) + (fragment-initialize new-mod mod-ast) + (values (modules->lisp-code mods) new-mod))))) + +(define (signal-module-decl-in-extension) + (fatal-error 'module-decl-in-extension + "Module declarations are not allowed in extensions.")) + +(define (signal-import-decl-in-extension) + (fatal-error 'import-decl-in-extension + "Import declarations are not allowed in extensions.")) + + +;;; Copy stuff into the fragment module structure from its parent module. +;;; The inverted symbol table is not necessary since the module contains +;;; no imports. + +(define (fragment-initialize new old) + (setf (module-name new) (gensym)) + (setf (module-type new) 'extension) + (setf (module-unit new) (module-unit old)) + (setf (module-uses-standard-prelude? new) + (module-uses-standard-prelude? old)) + (setf (module-inherited-env new) old) + (setf (module-fixity-table new) + (copy-table (module-fixity-table old))) + (setf (module-default new) (module-default old))) + +;;; This code deals with the actual evaluation of Haskell code. + +;;; This decides whether a variable has type `Dialogue'. + +(define (io-type? var) + (let ((type (var-type var))) + (when (not (gtype? type)) + (error "~s is not a Gtype." type)) + (and (null? (gtype-context type)) + (is-dialogue? (gtype-type type))))) + +(define (is-dialogue? type) + (let ((type (expand-ntype-synonym type))) + (and (ntycon? type) + (eq? (ntycon-tycon type) (core-symbol "Arrow")) + (let* ((args (ntycon-args type)) + (a1 (expand-ntype-synonym (car args))) + (a2 (expand-ntype-synonym (cadr args)))) + (and + (ntycon? a1) + (eq? (ntycon-tycon a1) (core-symbol "SystemState")) + (ntycon? a2) + (eq? (ntycon-tycon a2) (core-symbol "IOResult"))))))) + +(define (is-list-of? type con) + (and (ntycon? type) + (eq? (ntycon-tycon type) (core-symbol "List")) + (let ((arg (expand-ntype-synonym (car (ntycon-args type))))) + (and (ntycon? arg) (eq? (ntycon-tycon arg) con))))) + +(define (apply-exec var) + (initialize-io-system) + (mlet (((_ sec) + (time-execution + (lambda () + (let/cc x + (setf *runtime-abort* (lambda () (funcall x 'error))) + (let ((fn (eval (fullname var)))) + (unless (var-strict? var) + (setf fn (force fn))) + (funcall fn (box 'state)))))))) + (say "~%") + (when (memq 'time *printers*) + (say "Execution time: ~A seconds~%" sec))) + 'done) + +(define (eval-module mod) + (dolist (v (module-vars mod)) + (when (io-type? v) + (when (not (string-starts? "temp_" (symbol->string (def-name v)))) + (say/ne "~&Evaluating ~A.~%" v)) + (apply-exec v)))) + +(define (run-program name) + (compile/load name) + (let ((main-mod (table-entry *modules* '|Main|))) + (if main-mod + (let ((main-var (table-entry (module-symbol-table main-mod) '|main|))) + (if main-var + (apply-exec main-var) + (error "Variable main missing"))) + (error "module Main missing")))) + |