1 files changed, 208 insertions, 0 deletions
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))
+