upd advent.lisp so it works

[lifp.git] / console.lisp

diff --git a/console.lisp b/console.lisp
index 96d2e81da4c8e3a7b38ac10f92164d31f36f8c53..545d1e62d5f73d8e5047b0c657ca9947511ca277 100644 (file)
--- a/console.lisp
+++ b/console.lisp
@@ -6,15 +6,17 @@
 \r
 (in-package :cl-user)\r
 (defpackage :if-console\r
-  (:use :common-lisp :ltk :com.gigamonkeys.pathnames)\r
+  (:use :common-lisp :ltk :cl-fad)\r
   (:export :terminal-in :terminal-out\r
    :run-console :console-running-p :textwidth :offset :style\r
-   :*text* :get-input :ltk-after :*repl-mode* :*hard-quit* :quit-lisp\r
+   :*text* :get-input :ltk-after :*repl-mode* :*no-output*\r
+   :*hard-quit* :quit-lisp\r
    :close-console :load-module :print-message))\r
 \r
 (in-package :if-console)\r
 \r
 (defparameter *repl-mode* nil)\r
+(defparameter *no-output* nil)\r
 (defparameter *console-on* nil)\r
 (defparameter *text* nil)\r
 (defparameter *inp* nil)\r
@@ -35,9 +37,10 @@
 \r
 (defmethod gray:stream-write-char ((s terminal-out) char)\r
   (unless (console-running-p) (error "No console is running"))\r
+  (unless *no-output*\r
   (if *repl-mode* (princ char)\r
       (append-text (first *console-on*) \r
-                  (make-string 1 :initial-element char))))\r
+                  (make-string 1 :initial-element char)))))\r
 \r
 (defmethod gray:stream-line-column ((s terminal-out))\r
   (offset s))\r
@@ -45,11 +48,12 @@
 (defmethod gray:stream-write-char-sequence ((s terminal-out) str\r
                                            &optional start end)\r
   (unless (console-running-p) (error "No console is running"))\r
+  (unless *no-output*\r
   (let ((toprint (subseq str (if start start 0) (if end end nil))))\r
     (if *repl-mode* (princ toprint)\r
        (progn\r
          (append-text (first *console-on*) toprint)\r
-         (see (first *console-on*) "insert")))))\r
+         (see (first *console-on*) "insert"))))))\r
 \r
 (defmethod gray:stream-read-char ((s terminal-in))\r
   (if *repl-mode* (read-char *standard-input*)\r
@@ -137,19 +141,35 @@
                 :defaults file))\r
       (values file dir))))\r
 \r
+(defun splice-filename (file)\r
+  "Returns file itself and its directory as the second value"\r
+  (values file (make-pathname\r
+                :directory (pathname-directory file)\r
+                :name nil\r
+                :type nil\r
+                :defaults file)))\r
 \r
 (defun load-module (startup lib-loader)\r
   "Loads IF module into the interpreter"\r
-  (multiple-value-bind (file dir) (pick-file)\r
-    (unless file (append-text *text* "Failed to load module.\r
-"))\r
+  (multiple-value-bind (file dir) \r
+      (splice-filename (get-open-file :filetypes '(("Loadable files"\r
+                                                    "*.fas *.lisp")\r
+                                                   ("Compiled story files"\r
+                                                    "*.fas")\r
+                                                   ("Plain story files"\r
+                                                    "*.lisp")\r
+                                                   ("All files" "*"))\r
+                                      :title "Load story file"))\r
+      ;;(pick-file) <- was used before\r
+    (unless file (append-text *text* (format nil "Failed to load module.~%"))\r
+            (return-from load-module nil))\r
     (funcall lib-loader file dir)\r
     (funcall startup)))\r
 \r
 (defun run-console (startup lib-loader &key (interactive nil))\r
   (if *repl-mode* (progn (funcall startup) \r
                         (return-from run-console t))\r
-  (with-ltk ()\r
+  (with-ltk (:debug :develop :handle-warnings nil)\r
       (let* ((txt (make-instance 'text))\r
             (menu (make-menubar))\r
             (m-file (make-menu menu "File"))\r
@@ -190,5 +210,4 @@
                         (terpri *standard-output*))\r
       (progn (configure *text* :state "normal")\r
             (append-text *text* (apply #'format nil string args))\r
-            (append-text *text* "\r
-"))))
\ No newline at end of file
+            (append-text *text* (make-string 1 :initial-element #\Newline)))))\r