home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 4.ddi / LISPLIB / DRIBBLE.LSP < prev    next >
Encoding:
Text File  |  1984-11-06  |  2.1 KB  |  59 lines
  1. ;;; (C) Copyright 1984 by Gold Hill Computers
  2.  
  3. ;;;    The DRIBBLE facility (slurp)
  4. ;;; The only toplevel function in this file is DRIBBLE.
  5.  
  6. (DEFVAR *DRIBBLE-STREAM* NIL)        ; the DRIBBLE output stream
  7. (DEFVAR *DRIBBLE-TERMINAL* NIL)        ; during DRIBBLE this is terminal
  8.  
  9. (DEFUN DRIBBLE (&OPTIONAL PN)
  10.   "DRIBBLE with a pathname argument start the dribble operation, with
  11. no pathname argument ends the dribble operation."
  12.   (COND ((AND PN (NULL *DRIBBLE-STREAM*))        ; open dribble file
  13.      (SETQ *DRIBBLE-STREAM* (OPEN PN :DIRECTION :OUTPUT)
  14.            *DRIBBLE-UNREAD-CHAR* NIL
  15.            *DRIBBLE-TERMINAL* *TERMINAL-IO*
  16.            *TERMINAL-IO* #'DRIBBLE-TERM)
  17.      T)
  18.     ((AND (NULL PN) *DRIBBLE-STREAM*)        ; close dribble file
  19.      (SETQ *TERMINAL-IO* *DRIBBLE-TERMINAL*)
  20.      (CLOSE *DRIBBLE-STREAM*)
  21.      (SETQ *DRIBBLE-STREAM* NIL))
  22.     ((AND (NULL PN) (NULL *DRIBBLE-STREAM*))  ; asked to close but not open
  23.      (FORMAT T "~&DRIBBLE not in progress."))
  24.     ((AND PN *DRIBBLE-STREAM*)          ; asked to open but already open
  25.      (FORMAT T "~&DRIBBLE is already in progress."))
  26.     ))
  27.  
  28. (DEFVAR *DRIBBLE-UNREAD-CHAR* NIL)
  29.  
  30. ;; This is the input stream handler during a dribble.
  31. (DEFUN DRIBBLE-IN (MSG &REST ARGS)
  32.   (CASE MSG
  33.     (:READ-CHAR
  34.       (COND (*DRIBBLE-UNREAD-CHAR*
  35.          (PROG1 *DRIBBLE-UNREAD-CHAR*
  36.                 (SETQ *DRIBBLE-UNREAD-CHAR* NIL)))
  37.         (T
  38.          (LET ((CHAR (SEND *DRIBBLE-TERMINAL* :READ-CHAR)))
  39.            (SEND *DRIBBLE-STREAM* :WRITE-CHAR CHAR)
  40.            CHAR))))
  41.     (:UNREAD-CHAR (SETQ *DRIBBLE-UNREAD-CHAR* (CAR ARGS)))
  42.     ;; forward to the real stream.
  43.     (OTHERWISE
  44.       (APPLY *DRIBBLE-TERMINAL* MSG ARGS))))
  45.  
  46. ;; This is the output stream handler during a dribble.
  47. (DEFUN DRIBBLE-OUT (&REST ARGS)
  48.   (APPLY *DRIBBLE-STREAM* ARGS)
  49.   (APPLY *DRIBBLE-TERMINAL* ARGS))
  50.  
  51. ;; This is the stream for *TERMINAL-IO* during a dribble.
  52. ;; Depending on the message we decide to dispatch to the input
  53. ;; or output dribble streams.
  54. (DEFUN DRIBBLE-TERM (&REST ARGS)
  55.   (CASE (CAR ARGS)
  56.     ((:WRITE-CHAR :WRITE-STRING :WRITE-LINE) (APPLY #'DRIBBLE-OUT ARGS))
  57.     (OTHERWISE (APPLY #'DRIBBLE-IN ARGS))))
  58.  
  59.