home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.faslsp.lha / rexx1.lsp < prev    next >
Lisp/Scheme  |  1996-06-13  |  7KB  |  175 lines
  1. ;;;; Rexx Funktionen für CLISP
  2. ;;;; Jörg Höhle 13.6.1996
  3.  
  4. (in-package "LISP")
  5. (export '(rexx-run-command rexx-send-command rexx-wait-sent-command rexx-do-command
  6.           rexx-loop *rexx-ignore-errors*
  7. )        )
  8.  
  9. ;;;; Interface:
  10. ;;;
  11. ;;; (rexx-loop)
  12. ;;;
  13. ;;; (rexx-run-command name) -> null
  14. ;;;
  15. ;;; (rexx-do-command name) -> (rc result)
  16. ;;;
  17. ;;; (rexx-send-command name) -> handle
  18. ;;; (rexx-wait-sent-command handle) -> (rc result)
  19. ;;;
  20. ;;; name kann ein String (Kommandos in einem String)
  21. ;;;      oder ein Pathname (File mit Kommandos) sein.
  22. ;;; rc ist der ARexx return Code.
  23. ;;; result ist der ARexx return String, nur wenn rc gleich 0.
  24.  
  25. ;;;; ===========================================================================
  26. ;;;; Implementation:
  27.  
  28. (in-package "SYSTEM")
  29.  
  30. ;;; Wir benutzen folgende Funktionen aus REXX.D:
  31. ;;; (system::%rexx-wait-input) -> boolean
  32. ;;; (system::%rexx-get) -> (handle string) für eine neue Nachricht oder
  33. ;;;  (handle rc [result]) für ein Reply auf eine unserer Nachrichten
  34. ;;; (system::%rexx-reply handle rc result) -> null
  35. ;;; (system::%rexx-put name :result :string :token :async :io) -> handle
  36. ;;; Keyword-Argumente result, string, token, async, io sind Flags:
  37. ;;;  result: Antwort merken
  38. ;;;  string: Argument als Befehle statt 1. Token als Dateiname verstehen
  39. ;;;  token: Tokens erzeugen
  40. ;;;  async: An AREXX statt REXX Port schicken, für asynchrone Bearbeitung
  41. ;;;  io: E/A Kanäle übernehmen
  42.  
  43. ;; Wir verwalten eine Aliste  msg -> reply  aller weggeschickten und noch
  44. ;; unbearbeiteten Messages und ihrer Antworten (Listen (Code String);
  45. ;; NIL für noch unbeantwortete Messages). Beim Abschicken einer Message
  46. ;; bekommen wir ein "handle" (FOREIGN-POINTER) als Erkennungszeichen
  47. ;; (diese werden mit EQUALP verglichen).
  48.  
  49. (defvar *rexx-outmsg-list* '())
  50.  
  51. (defun rexx-add-index (handle &optional (value nil))
  52.   (push (cons handle value) *rexx-outmsg-list*)
  53. )
  54. (defun rexx-find-index (handle)
  55.   (assoc handle *rexx-outmsg-list* :test #'equalp)
  56. )
  57. (defun rexx-delete-entry (acons)
  58.   (setq *rexx-outmsg-list* (delete acons *rexx-outmsg-list* :test #'eq))
  59. )
  60.  
  61. ;; Startet ein REXX-Kommando, ohne jedoch jetzt auf dessen Beendigung zu warten.
  62. ;; Liefert das Handle, damit man später noch auf seine Beendigung warten kann,
  63. ;; jedoch NIL, falls das Kommando nicht erfolgreich abgeschickt werden konnte.
  64. (defun rexx-send-command (name &rest keys &key result string token async io)
  65.   (declare (ignore result string token async io))
  66.   "Starts asynchronous execution of a rexx command."
  67.   (let ((handle (apply #'%rexx-put name keys)))
  68.     (when handle
  69.       (rexx-add-index handle)
  70.       handle
  71. ) ) )
  72.  
  73. ;; Wartet auf die nächste Nachricht und liefert ihr Handle.
  74. (defun rexx-next-event ()
  75.   (loop ; es fehlt derzeit die Möglichkeit, parallel *STANDARD-INPUT* zu lesen
  76.     ; nächste Nachricht lesen und auswerten, falls vorhanden:
  77.     (let ((event (%rexx-get)))
  78.       (when event (return event))
  79.     )
  80.     ; auf die nächste Nachricht warten:
  81.     (%rexx-wait-input)
  82. ) )
  83.  
  84.  
  85. (defvar *rexx-ignore-errors* t
  86.   "If T silently ignore errors, if NIL invoke normal *error-handler*,
  87.   otherwise must be a function that is bound to *error-handler*")
  88.  
  89.  
  90. ;; "Hauptschleife": Wartet auf Nachrichten, interpretiert diese als Fragen,
  91. ;; wertet sie aus und schickt die Antwort zurück (oder Return-Code 5 im Falle
  92. ;; eines Fehlers). Die Schleife wird beendet, wenn eine Antwort auf Handle
  93. ;; wait-for kommt.
  94. ;; Wir möchten: daß rexx-loop in eine Endlosschleife geht und möglicherweise
  95. ;; in den Debugger springt. unwind/abort soll dabei zurück in die Schleife
  96. ;; springen (oder doch rexx-loop verlassen? (dann loop statt driver
  97. ;; benutzen)), damit falsche ARexx-Eingaben nicht zum Abbruch von rexx-loop
  98. ;; führen.
  99. ;; Ferner soll rexx-loop auch ganz normal beendet werden, z.Z. springt es
  100. ;; über rexx:exit-loop.cl in eine Eingabeschleife, deswegen geht (progn
  101. ;; (rexx-loop) (print "Over")) nicht.
  102. (defun rexx-loop (&optional wait-for)
  103.   "Rexx driver loop. Optional message to wait for."
  104.   (driver ; driver oder einfaches loop ??
  105.     #'(lambda ()
  106.         (let ((event (rexx-next-event))) ; nächste Nachricht
  107.           (cond ((numberp (second event)) ; ein Reply (handle rc [result])
  108.                  (let ((index (rexx-find-index (first event))))
  109.                    (when index (setf (cdr index) (rest event))) ; Antwort abspeichern
  110.                  )
  111.                  (when (equalp (first event) wait-for)
  112.                    (return-from rexx-loop (rest event)) ; evtl. Schleife beenden
  113.                 ))
  114.                 (t ; ein Befehl (handle string)
  115.                  (let ((result nil))
  116.                    ; warum funktioniert (catch 'debug ...) nicht??
  117.                    (unwind-protect
  118.                      (block try-rep ; Fehlerbehandlung
  119.                        (setq result
  120.                          (with-output-to-string (stream)
  121.                            (let ((*error-handler*
  122.                                   (cond ((functionp *rexx-ignore-errors*)
  123.                                          *rexx-ignore-errors*)
  124.                                         ((not *rexx-ignore-errors*)
  125.                                          *error-handler*)
  126.                                         (t #'(lambda (&rest error-args)
  127.                                                (declare (ignore error-args))
  128.                                                (return-from try-rep nil)))
  129.                                 )))
  130.                              ; primitives READ-EVAL-PRINT :
  131.                              (princ (eval (read-from-string (second event)))
  132.                                     stream
  133.                      ) ) ) ) )
  134.                      (%rexx-reply (first event) (if result 0 5) result) ; portabler machen!??
  135.                 )) )
  136. ) )   ) ) )
  137.  
  138. ;; Wartet auf die Beendigung eines REXX-Kommandos.
  139. ;; Liefert die Antwort (eine Liste (Code [String])).
  140. (defun rexx-wait-sent-command (handle)
  141.   "Waits for command termination."
  142.   (let ((index (rexx-find-index handle)))
  143.     (unless index
  144.       (error-of-type 'error
  145.         #L{
  146.         DEUTSCH "Kein Warten auf ~S möglich."
  147.         ENGLISH "No waiting for ~S possible."
  148.         FRANCAIS "Pas d'attente de ~S possible."
  149.         }
  150.         handle
  151.     ) )
  152.     (loop
  153.       (when (cdr index) (rexx-delete-entry index) (return (cdr index)))
  154.       (rexx-loop handle) ; auf die Antwort warten, Aussprung oben
  155. ) ) )
  156.  
  157. ;; Startet ein REXX-Kommando und wartet, bis es beendet ist.
  158. ;; Liefert die Antwort (eine Liste (Code String)),
  159. ;; jedoch NIL, falls das Kommando nicht erfolgreich abgeschickt werden konnte.
  160. (defun rexx-do-command (name &rest keys &key &allow-other-keys)
  161.   "Executes command, waiting for result."
  162.   (let ((handle (apply #'rexx-send-command name keys)))
  163.     (when handle
  164.       (rexx-wait-sent-command handle)
  165. ) ) )
  166.  
  167. ;; Startet ein REXX-Kommando, ohne jedoch auf dessen Beendigung zu warten
  168. ;; (asynchron).
  169. ;; Liefert /=NIL, falls das Kommando erfolgreich abgeschickt wurde.
  170. (defun rexx-run-command (name &key string token)
  171.   "Runs a rexx command asynchronously, no return code."
  172.   (if (rexx-do-command name :string string :token token :async t) t nil)
  173. )
  174.  
  175.