Import to github.

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"))))
+