From a361435f30b8c651b0a4584b1adfc29b1cdd2b82 Mon Sep 17 00:00:00 2001 From: demattia Date: Tue, 14 Sep 2004 11:54:00 +0000 Subject: [PATCH] *** empty log message *** --- .gitignore | 28 ++ scheme/handle-fatal-error.scm | 97 ++++++ scheme/nuit-engine.scm | 589 ++++++++++++++++++++++++++++++++++ scheme/nuit-packages.scm | 14 + 4 files changed, 728 insertions(+) create mode 100644 .gitignore create mode 100644 scheme/handle-fatal-error.scm create mode 100644 scheme/nuit-engine.scm create mode 100644 scheme/nuit-packages.scm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..da8168b --- /dev/null +++ b/.gitignore @@ -0,0 +1,28 @@ +# CVS default ignores begin +tags +TAGS +.make.state +.nse_depinfo +*~ +\#* +.#* +,* +_$* +*$ +*.old +*.bak +*.BAK +*.orig +*.rej +.del-* +*.a +*.olb +*.o +*.obj +*.so +*.exe +*.Z +*.elc +*.ln +core +# CVS default ignores end diff --git a/scheme/handle-fatal-error.scm b/scheme/handle-fatal-error.scm new file mode 100644 index 0000000..63ed459 --- /dev/null +++ b/scheme/handle-fatal-error.scm @@ -0,0 +1,97 @@ +;;; Handle fatal errors in a sensible way. -*- Scheme -*- + +;;; This file is part of the Scheme Untergrund Networking package. + +;;; Copyright (c) 1995 by Olin Shivers. +;;; For copyright information, see the file COPYING which comes with +;;; the distribution. + +;;; (with-fatal-error-handler* handler thunk) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Call THUNK, and return whatever it returns. If THUNK signals a condition, +;;; and that condition is an error condition (or a subtype of error), then +;;; HANDLER gets a chance to handle it. +;;; The HANDLER proc is applied to two values: +;;; (HANDLER condition decline) +;;; HANDLER's continuation is WITH-FATAL-ERROR-HANDLER*'s; whatever HANDLER +;;; returns is returned from WITH-FATAL-ERROR-HANDLER. HANDLER declines to +;;; handle the error by throwing to DECLINE, a nullary continuation. +;;; +;;; Why is it called with-FATAL-error-handler*? Because returning to the +;;; guy that signalled the error is not an option. +;;; +;;; Why the nested outer pair of CALL/CC's? Well, what happens if the user's +;;; error handler *itself* raises an error? This could potentially give +;;; rise to an infinite loop, because WITH-HANDLER runs its handler in +;;; the original condition-signaller's context, so you'd search back for a +;;; handler, and find yourself again. For example, here is an infinite loop: +;;; +;;; (with-handler (lambda (condition more) +;;; (display "Loop!") +;;; (error "ouch")) ; Get back, Loretta. +;;; (lambda () (error "start me up"))) +;;; +;;; I could require W-F-E-H* users to code carefully, but instead I make sure +;;; the user's fatal-error handler runs in w-f-e-h*'s handler context, so +;;; if it signals a condition, we'll start the search from there. That's the +;;; point of continuation K. When the original thunk completes successfully, +;;; we dodge the K hackery by using ACCEPT to make a normal return. + +(define (with-fatal-error-handler* handler thunk) + (call-with-current-continuation + (lambda (accept) + ((call-with-current-continuation + (lambda (k) + (with-handler (lambda (condition more) + (if (error? condition) + (call-with-current-continuation + (lambda (decline) + (k (lambda () (handler condition decline)))))) + (more)) ; Keep looking for a handler. + (lambda () (call-with-values thunk accept))))))))) + +(define-syntax with-fatal-error-handler + (syntax-rules () + ((with-fatal-error-handler handler body ...) + (with-fatal-error-handler* handler + (lambda () body ...))))) + +;This one ran HANDLER in the signaller's condition-handler context. +;It was therefore susceptible to infinite loops if you didn't code +;your handler's carefully. +; +;(define (with-fatal-error-handler* handler thunk) +; (call-with-current-continuation +; (lambda (accept) +; (with-handler (lambda (condition more) +; (if (error? condition) +; (call-with-current-continuation +; (lambda (decline) +; (accept (handler condition decline))))) +; (more)) ; Keep looking for a handler. +; thunk)))) + +;;; (%error-handler-cond kont eh-clauses cond-clauses) +;;; Transform error-handler clauses into COND clauses by wrapping continuation +;;; KONT around the body of each e-h clause, so that if it fires, the result +;;; is thrown to KONT, but if no clause fires, the cond returns to the default +;;; continuation. + +;(define-syntax %error-handler-cond +; (syntax-rules (=> else) +; +; ((%error-handler-cond kont ((test => proc) clause ...) (ans ...)) +; (%error-handler-cond kont +; (clause ...) +; ((test => (lambda (v) (kont (proc v)))) ans ...))) +; +; ((%error-handler-cond kont ((test body ...) clause ...) (ans ...)) +; (%error-handler-cond kont +; (clause ...) +; ((test (kont (begin body ...))) ans ...))) +; +; ((%error-handler-cond kont ((else body ...)) (ans-clause ...)) +; (cond (else body ...) ans-clause ...)) +; +; ((%error-handler-cond kont () (ans-clause ...)) +; (cond ans-clause ...)))) diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm new file mode 100644 index 0000000..e0f5353 --- /dev/null +++ b/scheme/nuit-engine.scm @@ -0,0 +1,589 @@ +;; ,load /home/demattia/studium/studienarbeit/scsh-nuit/scheme/nuit-engine.scm + + +;;************************************************************************* +;;Zustand + +;;Zustand des oberen Fensters (Command-Window) +;;--------------------------- + +;;Text +(define text-command (list "Welcome in the scsh-ncurses-ui!" "")) + +;;gibt an, in welcher Zeile der gesamten Command-History man sich befindet +(define pos-command 2) +;;in welcher Spalte +(define pos-command-col 2) + +;;gibt an, in welcher Zeile des Buffers nach Zeilenumbruch man sich befindet. +(define pos-command-fin-ln 2) + +;;gibt an, in welcher Zeile des Buffers man sich befindet +(define command-buffer-pos-y 2) +;;gibt an, an welcher Position des Buffers man sich befindet. +(define command-buffer-pos-x 2) + +;;Anzahl der Zeilen des Commando-Buffers +(define command-lines 0) + +;;Anzahl der Spalten des Commando-Buffers +(define command-cols 0) + +;;befindet sich der cursor am Ende der letzten Zeile des command-wins? +(define can-write-command #t) + + +;;Zustand des unteren Fensters (Result-Window) +;;---------------------------- + +;;Text +(define text-result (list "Start entering commands." + "Ctrl-h for help.")) + +;;gibt an, in welcher Zeile des Result-Buffers man sich befindet +(define pos-result 2) +;;in welcher Spalte +(define pos-result-col 17) + +;;gibt an, in welcher Zeile des Buffers man sich befindet +(define result-buffer-pos-y 2) +;;gibt an, an welcher Position des Buffers man sich befindet. +(define result-buffer-pos-x 2) + +;;Anzahl der Zeilen des Buffers +(define result-lines 0) +;;Anzahl der Spalten des Buffers +(define result-cols 0) + + + +;;allgemeiner Zustand +;;------------------- + +;;entweder 1...oben oder 2...unten +(define active-buffer 1) + + +;;************************************************************************* +;;Verhalten + +;;Eingabe verarbeiten +(define run + (lambda () + (let loop ((ch (paint))) + (cond + + ;;Beenden + ((= ch key-f1) + #t) + + ;;Enter + ((= ch 10) + (if (= active-buffer 1) + (begin + (execute-command) + (loop (paint))) + (loop (paint)))) + + ;;Backspace + ((= ch key-backspace) + (if (= active-buffer 1) + (if can-write-command + (if (< pos-command-col 3) + (loop (paint)) + (begin + (remove-from-command-buffer) + (set! pos-command-col (- pos-command-col 1)) + (loop (paint)))) + (loop (paint))) + (loop (paint)))) + + ;;Navigieren + ((= ch key-up) + (if (= active-buffer 1) + (if (< pos-command-fin-ln 2) + (loop (paint)) + (let ((length-prev-line + (string-length + (list-ref text-command (- pos-command 2))))) + (begin + (set! can-write-command #f) + (set! pos-command (- pos-command 1)) + (set! pos-command-col (+ length-prev-line 2)) + (loop (paint))))) + (if (< pos-result 2) + (loop (paint)) + (let ((length-prev-line + (string-length + (list-ref text-result (- pos-result 2))))) + (begin + (set! pos-result (- pos-result 1)) + (set! pos-result-col (+ length-prev-line 1)) + (loop (paint))))))) + + ((= ch key-down) + (if (= active-buffer 1) + (let ((last-pos (length text-command))) + (if (>= pos-command last-pos) + (loop (paint)) + (let ((length-next-line + (string-length + (list-ref text-command pos-command)))) + (begin + (set! pos-command-col (+ length-next-line 2)) + (set! pos-command (+ pos-command 1)) + (if (= pos-command last-pos) + (set! can-write-command #t)) + (loop (paint)))))) + (let ((last-pos (length text-result))) + (if (>= pos-result last-pos) + (loop (paint)) + (let ((length-next-line + (string-length + (list-ref text-result pos-result)))) + (begin + (set! pos-result-col (+ length-next-line 1)) + (set! pos-result (+ pos-result 1)) + (loop (paint)))))))) + + ((= ch key-left) + (if (= active-buffer 1) + (if (<= pos-command-col 2) + (loop (paint)) + (begin + (set! pos-command-col (- pos-command-col 1)) + (loop (paint)))) + (if (<= pos-result-col 1) + (loop (paint)) + (begin + (set! pos-result-col (- pos-result-col 1)) + (loop (paint)))))) + + ((= ch key-right) + (if (= active-buffer 1) + (let ((line-length (string-length + (list-ref text-command (- pos-command 1))))) + (if (>= pos-command-col (+ line-length 2)) + (loop (paint)) + (begin + (set! pos-command-col (+ pos-command-col 1)) + (loop (paint))))) + (let ((line-length (string-length + (list-ref text-result (- pos-result 1))))) + (if (>= pos-result-col (+ line-length 1)) + (loop (paint)) + (begin + (set! pos-result-col (+ pos-result-col 1)) + (loop (paint))))))) + + ;;Ctrl+b -> Buffer wechseln + ((= ch 2) + (begin + (if (= active-buffer 1) + (set! active-buffer 2) + (set! active-buffer 1)) + (loop (paint)))) + + + ;;Ctrl+a -> Zeilenanfang + ((= ch 1) + (if (= active-buffer 1) + (begin + (set! command-buffer-pos-x 2) + (loop (paint))))) + + ;;Ctrl-e -> Zeilenende + ((= ch 5) + (if (= active-buffer 1) + (let ((line-length (string-length + (list-ref text-command (- pos-command 1))))) + (begin + (set! command-buffer-pos-x (+ line-length 2)) + (loop (paint)))))) + + (else + (if (= active-buffer 1) + (if (<= ch 255) + (if can-write-command + (begin + (add-to-command-buffer ch) + (loop (paint))) + (loop (paint))) + (loop (paint))))))))) + + +;;darstellen und auf Eingabe warten +(define paint + (lambda () + (begin + (init-screen) + (cbreak) + (let* ((bar1-y 0) + (bar1-x 0) + (bar1-h 3) + (bar1-w (COLS)) + (bar2-y (round (/ (LINES) 3))) + (bar2-x 0) + (bar2-h 3) + (bar2-w (COLS)) + (comwin-y 3) + (comwin-x 0) + (comwin-h (- bar2-y 3)) + (comwin-w (COLS)) + (reswin-y (+ bar2-y 3)) + (reswin-x 0) + (reswin-h (- (- (- (LINES) 6) comwin-h) 3)) + (reswin-w (COLS)) + (bar3-y (+ reswin-y reswin-h)) + (bar3-x 0) + (bar3-h 3) + (bar3-w (COLS))) + (let ((bar1 (newwin bar1-h bar1-w bar1-y bar1-x)) + (bar2 (newwin bar2-h bar2-w bar2-y bar2-x)) + (command-win (newwin comwin-h comwin-w comwin-y comwin-x)) + (result-win (newwin reswin-h reswin-w reswin-y reswin-x)) + (bar3 (newwin bar3-h bar3-w bar3-y bar3-x))) + (box bar1 (ascii->char 0) (ascii->char 0)) + (mvwaddstr bar1 1 1 "Command") + (wrefresh bar1) + (box bar2 (ascii->char 0) (ascii->char 0)) + (mvwaddstr bar2 1 1 "Result") + (wrefresh bar2) + (box command-win (ascii->char 0) (ascii->char 0)) + (set! command-lines (- comwin-h 2)) + (set! command-cols (- comwin-w 3)) + (print-command-buffer command-win) + (wrefresh command-win) + (box result-win (ascii->char 0) (ascii->char 0)) + (set! result-lines (- reswin-h 2)) + (set! result-cols (- reswin-w 3)) + (print-result-buffer result-win) + (wrefresh result-win) + (box bar3 (ascii->char 0) (ascii->char 0)) + (wattron bar3 (A-REVERSE)) + (mvwaddstr bar3 1 1 "F1:Exit | Ctrl+b:Switch-Buffer") + (wstandend bar3) + (wrefresh bar3) + (cursor-right-pos command-win result-win comwin-h reswin-h) + (noecho) + (keypad bar1 #t) + (let ((ch (wgetch bar1))) + (wclear bar1) + (wclear bar2) + (wclear command-win) + (wclear result-win) + (wclear bar3) + (clear) + (endwin) + (echo) + ch + )))))) + +;;Eingabe wurde durch Benutzer bestätigt -> Kommando ausfuehren +(define execute-command + (lambda () + (let* ((command (list-ref text-command (- (length text-command) 1))) + (command-port (open-input-string command)) + (tmp-env (scheme-report-environment 5)) + (handler (lambda (condition more) + (cons 'Error: condition))) + (result (with-fatal-error-handler + handler + (eval (read command-port) tmp-env))) + (result-port (open-output-string))) + (begin + (write result result-port) + (let ((result-string (get-output-string result-port))) + (begin + (layout-result command result-string result-cols) + (set! text-command (append text-command (list ""))) + (scroll-command-buffer))))))) + +;;Nach einer Eingabe kann es sein, dass die aktive Buffer_Zeile verschoben +;;werden muss. +(define scroll-command-buffer + (lambda () + (begin + (set! pos-command (+ pos-command 1)) + (set! pos-command-col 2)))) + + +;;Der Benutzer muss sich darum kümmern, dass das Ergebnis sinnvoll +;;dargestellt wird. +(define layout-result + (lambda (command result width) + ;;standard (else -> keine spezielle Darstellung vorgesehen) + (layout-result-standard result width))) +; (begin +; (let ((com (if (> (string-length command) (- width 22)) +; (string-append (substring command 0 (- width 22)) "...") +; command))) +; (set! text-result (cons (string-append "command unknown: " com) '())) +; (set! pos-result-col (+ 18 (string-length com))) +; (set! pos-result 1))))) + + + +;;Ein Character zur letzten Zeile des Command-Buffers hinzufügen +(define add-to-command-buffer + (lambda (ch) + (let* ((last-pos (- (length text-command) 1)) + (old-last-el (list-ref text-command last-pos)) + (old-rest (sublist text-command 0 last-pos)) + (before-ch (substring old-last-el 0 + (max 0 (- pos-command-col 2)))) + (after-ch (substring old-last-el + (max 0 (- pos-command-col 2)) + (string-length old-last-el))) + (new-last-el (string-append before-ch + (string (ascii->char ch)) + after-ch))) + (set! text-command (append old-rest (list new-last-el))) + (set! pos-command-col (+ pos-command-col 1))))) + +;;Ein Character aus der letzten Zeile entfernen (backspace) +(define remove-from-command-buffer + (lambda () + (let* ((last-pos (- (length text-command) 1)) + (old-last-el (list-ref text-command last-pos)) + (old-rest (sublist text-command 0 last-pos)) + (before-ch (substring old-last-el 0 + (max 0 (- pos-command-col 3)))) + (after-ch (if (= pos-command-col + (+ (string-length old-last-el) 2)) + "" + (substring old-last-el + (max 0 (- pos-command-col 2)) + (string-length old-last-el)))) + (new-last-el (if (= pos-command-col + (+ (string-length old-last-el) 2)) + before-ch + (string-append before-ch after-ch)))) + (set! text-command (append old-rest (list new-last-el)))))) + + + +;;Es wird der sichtbare Teil der bisherigen Eingaben in den Command- +;;Buffer angezeigt. +(define print-command-buffer + (lambda (comwin) + (let ((lines (get-right-command-lines))) + (let loop ((pos 1)) + (if (> pos command-lines) + values + (let ((line (list-ref lines (- pos 1)))) + (begin + (mvwaddstr comwin pos 1 line) + (wrefresh comwin) + (loop (+ pos 1))))))))) + + +;;Anzeigen des sichtbaren Teils des Result-Buffers +(define print-result-buffer + (lambda (reswin) + (let ((lines (get-right-result-lines))) + (let loop ((pos 1)) + (if (> pos result-lines) + values + (let ((line (list-ref lines (- pos 1)))) + (begin + (mvwaddstr reswin pos 1 line) + (wrefresh reswin) + (loop (+ pos 1))))))))) + + +;;Es werden die anzuzeigenden Zeilen erzeugt. +;;nötig, damit auch Befehle über mehrere Zeilen möglich sind: +(define get-right-command-lines + (lambda () + (let* ((all-lines-seperated (all-commands-seperated text-command)) + (num-all-lines (length all-lines-seperated))) + (if (>= pos-command-fin-ln command-lines) + ;;aktive Zeile ist die unterste + (sublist all-lines-seperated + (- pos-command-fin-ln command-lines) + command-lines) + (if (<= num-all-lines command-lines) + ;;noch keine ganze Seite im Buffer + (prepare-lines all-lines-seperated + command-lines (- pos-command-fin-ln 1)) + ;;scrollen auf der ersten Seite + (sublist all-lines-seperated 0 command-lines)))))) + +;;anzuzeigende Zeilen im Result-Buffer +(define get-right-result-lines + (lambda () + (prepare-lines text-result result-lines pos-result))) + + + + + +;;alle Statements zerlegen +(define all-commands-seperated + (lambda (commands) + (let loop ((act-pos 1) + (new '())) + (begin + (if (= act-pos pos-command) + (let* ((length-new (length new)) + (first-el-old (list-ref commands (- act-pos 1))) + (seperated-act (seperate-line-com + first-el-old command-cols)) + (length-act (length seperated-act))) + (set! pos-command-fin-ln (+ length-new length-act)))) + + (if (> act-pos (length commands)) + (reverse new) + (let* ((first-el-old (list-ref commands (- act-pos 1))) + (seperated-fst-el-old + (seperate-line-com first-el-old command-cols))) + (loop (+ act-pos 1) (append seperated-fst-el-old new)))))))) + + +;;Ein Statement wird in Stücke zerlegt, so dass dann jedes Stück in eine +;;Zeile passt. +(define seperate-line-com + (lambda (line width) + (let loop ((new '()) + (old line)) + (if (> width (string-length old)) + (if (= 0 (string-length old)) + (if (equal? new '()) + (add-prompts '("")) + (add-prompts new)) + ;new + (add-prompts (append (list old) new))) + ;(append (list old) new)) + (let ((next-line (substring old 0 width)) + (rest-old (substring old width (string-length old)))) + (loop (cons next-line new) rest-old)))))) + + +;;> hinzufügen +(define add-prompts + (lambda (l) + (let* ((lr (reverse l)) + (old-first-el (list-ref lr 0)) + (new-first-el (string-append ">" old-first-el)) + (old-rest (list-tail lr 1))) + (let loop ((old old-rest) + (new (list new-first-el))) + (if (> (length old) 0) + (let* ((old-first-el (list-ref old 0)) + (new-first-el (string-append " " old-first-el))) + (loop (list-tail old 1) (append new (list new-first-el)))) + (reverse new)))))) + + + +;;Cursor an die richtige Stelle bewegen: +(define cursor-right-pos + (lambda (comwin reswin comwin-h reswin-h) + (begin + (compute-y-x) + (if (= active-buffer 1) + (begin + (wmove comwin command-buffer-pos-y command-buffer-pos-x) + (wrefresh comwin)) + (begin + (wmove reswin result-buffer-pos-y result-buffer-pos-x) + (wrefresh reswin)))))) + + +;;pos-y und pos-x berechnen +(define compute-y-x + (lambda () + (if (= active-buffer 1) + (begin + ;;zuerst mal y + (if (>= pos-command-fin-ln command-lines) + ;;unterste Zeile + (set! command-buffer-pos-y command-lines) + ;;sonst + (set! command-buffer-pos-y pos-command-fin-ln)) + ;;jetzt x + (let ((posx (modulo pos-command-col command-cols))) + (set! command-buffer-pos-x posx))) + (begin + ;;zuerst y + (if (>= pos-result result-lines) + (set! result-buffer-pos-y result-lines) + (set! result-buffer-pos-y pos-result)) + (set! result-buffer-pos-x pos-result-col))))) + + +;;Es wird in einer Liste der zu druckende Berecih ausgewählt: +(define prepare-lines + (lambda (l height pos) + (if (< (length l) height) + ;; Liste zu kurz -> ""s hinzufügen + (let loop ((tmp-list l)) + (if (= height (length tmp-list)) + tmp-list + (loop (append tmp-list (list ""))))) + ;; Teilliste holen + (if (< pos height) + ;;pos nicht ganz unten + (sublist l 0 height) + ;;standard-Fall + (sublist l (- pos height) height))))) + +;;Teilliste +(define sublist + (lambda (l pos k) + (let ((tmp (list-tail l pos))) + (reverse (list-tail (reverse tmp) + (- (length tmp) k)))))) + +;;************************************************************************* +;;Die folgenden Funktionen sollten später in eine eigene Datei kommen. +;;Sie sind abhängig vom jeweiligen Befehl. + +;;Im Standardfall wird einfach als Ergebnis die Rückgabe der scsh ausgegeben. +(define layout-result-standard + (lambda (result width) + (set! text-result (reverse (seperate-line result width))))) + +;;nützliche Hilfsfunktionen: + +;;Ein Statement wird in Stücke zerlegt, so dass dann jedes Stück in eine +;;Zeile passt. +(define seperate-line + (lambda (line width) + (let loop ((new '()) + (old line)) + (if (> width (string-length old)) + (if (= 0 (string-length old)) + (if (equal? new '()) + '("") + new) + ;new + (append (list old) new)) + ;(append (list old) new)) + (let ((next-line (substring old 0 width)) + (rest-old (substring old width (string-length old)))) + (loop (cons next-line new) rest-old)))))) + + +(define (with-fatal-error-handler* handler thunk) + (call-with-current-continuation + (lambda (accept) + ((call-with-current-continuation + (lambda (k) + (with-handler (lambda (condition more) + (if (error? condition) + (call-with-current-continuation + (lambda (decline) + (k (lambda () (handler condition decline)))))) + (more)) ; Keep looking for a handler. + (lambda () (call-with-values thunk accept))))))))) + +(define-syntax with-fatal-error-handler + (syntax-rules () + ((with-fatal-error-handler handler body ...) + (with-fatal-error-handler* handler + (lambda () body ...))))) + +(run) + \ No newline at end of file diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm new file mode 100644 index 0000000..6caa9a7 --- /dev/null +++ b/scheme/nuit-packages.scm @@ -0,0 +1,14 @@ +(define-interface nuit-interface + (export run)) + +(define-structure nuit nuit-interface + (open scheme-with-scsh + external-calls + define-record-types + conditions + signals + handle + ncurses + srfi-6) + (files nuit-engine + handle-fatal-error))