home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
High Voltage Shareware
/
high1.zip
/
high1
/
DIR24
/
CLISP.ZIP
/
REXX.LSP
< prev
next >
Wrap
Lisp/Scheme
|
1993-09-12
|
6KB
|
152 lines
;;;; Rexx Funktionen für CLISP
;;;; Jörg Höhle 27.11.1992
(in-package "LISP")
(export '(rexx-run-command rexx-send-command rexx-wait-sent-command rexx-do-command
rexx-loop
) )
;;;; Interface:
;;;
;;; (rexx-loop)
;;;
;;; (rexx-run-command name) -> null
;;;
;;; (rexx-do-command name) -> (rc result)
;;;
;;; (rexx-send-command name) -> handle
;;; (rexx-wait-sent-command handle) -> (rc result)
;;;
;;; name kann ein String (Kommandos in einem String)
;;; oder ein Pathname (File mit Kommandos) sein.
;;; rc ist der ARexx return Code.
;;; result ist der ARexx return String, nur wenn rc gleich 0.
;;;; ===========================================================================
;;;; Implementation:
(in-package "SYSTEM")
;;; Wir benutzen folgende Funktionen aus REXX.D:
;;; (system::%rexx-wait-input) -> boolean
;;; (system::%rexx-get) -> (handle string) oder (handle rc [result])
;;; (system::%rexx-reply handle rc result) -> null
;;; (system::%rexx-put name :result :string :token :async :io) -> handle
;;; Keyword-Argumente result, string, token, async, io sind Flags:
;;; result: Antwort merken
;;; string: Argument als Befehle statt 1. Token als Dateiname verstehen
;;; token: Tokens erzeugen
;;; async: An AREXX statt REXX Port schicken, für asynchrone Bearbeitung
;;; io: E/A Kanäle übernehmen
;; Wir verwalten eine Aliste msg -> reply aller weggeschickten und noch
;; unbearbeiteten Messages und ihrer Antworten (Listen (Code String);
;; NIL für noch unbeantwortete Messages). Beim Abschicken einer Message
;; bekommen wir ein "handle" als Erkennungszeichen (diese werden
;; mit EQUAL verglichen).
(defvar *rexx-outmsg-list* '())
(defun rexx-add-index (handle &optional (value nil))
(push (cons handle value) *rexx-outmsg-list*)
)
(defun rexx-find-index (handle)
(assoc handle *rexx-outmsg-list* :test #'equal)
)
(defun rexx-delete-entry (acons)
(setq *rexx-outmsg-list* (delete acons *rexx-outmsg-list* :test #'eq))
)
;; Startet ein REXX-Kommando, ohne jedoch jetzt auf dessen Beendigung zu warten.
;; Liefert das Handle, damit man später noch auf seine Beendigung warten kann,
;; jedoch NIL, falls das Kommando nicht erfolgreich abgeschickt werden konnte.
(defun rexx-send-command (name &rest keys &key result string token async io)
(declare (ignore result string token async io))
"Starts asynchronous execution of a rexx command."
(let ((handle (apply #'%rexx-put name keys)))
(when handle
(rexx-add-index handle)
handle
) ) )
;; Wartet auf die nächste Nachricht und liefert ihr Handle.
(defun rexx-next-event ()
(loop ; es fehlt derzeit die Möglichkeit, parallel *STANDARD-INPUT* zu lesen
; nächste Nachricht lesen und auswerten, falls vorhanden:
(let ((event (%rexx-get)))
(when event (return event))
)
; auf die nächste Nachricht warten:
(%rexx-wait-input)
) )
;; "Hauptschleife": Wartet auf Nachrichten, interpretiert diese als Fragen,
;; wertet sie aus und schickt die Antwort zurück. Die Schleife wird beendet,
;; wenn eine Antwort auf Handle wait-for kommt.
(defun rexx-loop (&optional wait-for)
"Rexx driver loop. Optional message to wait for."
(driver ; driver oder einfaches loop ??
#'(lambda ()
(let ((event (rexx-next-event))) ; nächste Nachricht
(cond ((numberp (second event)) ; ein Reply (handle rc [result])
(let ((index (rexx-find-index (first event))))
(when index (setf (cdr index) (rest event))) ; Antwort abspeichern
)
(when (equal (first event) wait-for)
(return-from rexx-loop (rest event)) ; evtl. Schleife beenden
))
(t ; ein Befehl (handle string)
(let ((result nil))
; warum funktioniert (catch 'debug ...) nicht??
(unwind-protect
(block try-rep ; Fehlerbehandlung
(setq result
(with-output-to-string (stream)
(let ((*error-handler*
#'(lambda (&rest error-args)
(declare (ignore error-args))
(return-from try-rep nil)
)) )
; primitives READ-EVAL-PRINT :
(princ (eval (read-from-string (second event)))
stream
) ) ) ) )
(%rexx-reply (first event) (if result 0 5) result) ; portabler machen!??
)) )
) ) ) ) )
;; Wartet auf die Beendigung eines REXX-Kommandos.
;; Liefert die Antwort (eine Liste (Code String)).
(defun rexx-wait-sent-command (handle)
"Waits for command termination."
(loop
(let ((done (rexx-find-index handle)))
(unless done
(error #+DEUTSCH "Kein Warten auf ~S möglich."
#+ENGLISH "No waiting for ~S possible."
#+FRANCAIS "Pas d'attente de ~S possible."
handle
) )
(when (cdr done) (rexx-delete-entry done) (return (cdr done)))
(rexx-loop handle) ; auf die Antwort warten, Aussprung oben
) ) )
;; Startet ein REXX-Kommando und wartet, bis es beendet ist.
;; Liefert die Antwort (eine Liste (Code String)),
;; jedoch NIL, falls das Kommando nicht erfolgreich abgeschickt werden konnte.
(defun rexx-do-command (name &rest keys &key &allow-other-keys)
"Executes command, waiting for result."
(let ((handle (apply #'rexx-send-command name keys)))
(when handle
(rexx-wait-sent-command handle)
) ) )
;; Startet ein REXX-Kommando, ohne jedoch auf dessen Beendigung zu warten
;; (asynchron).
;; Liefert /=NIL, falls das Kommando erfolgreich abgeschickt wurde.
(defun rexx-run-command (name &key string token)
"Runs a rexx command asynchronously, no return code."
(if (rexx-do-command name :string string :token token :async t) t nil)
)