home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / port_op.t < prev    next >
Encoding:
Text File  |  1990-06-04  |  8.3 KB  |  273 lines
  1. (herald port_op
  2.         (env tsys (osys buffer) (osys pool))) 
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;;; I/O port operations
  28.  
  29. ;;; General port operations.
  30.  
  31. (define-predicate port?)
  32.  
  33. (define-operation (CLOSE port) (no-value))
  34.  
  35. ;;; Opening lists and strings "wins" by opening the named file.
  36.  
  37. (define-operation (MAYBE-OPEN FILESPEC MODE)
  38.   (maybe-open (->filename filespec) mode))
  39.  
  40. (define-operation (OPEN FILESPEC MODE)
  41.   (iterate loop ((fname filespec))
  42.     (cond ((maybe-open fname mode))
  43.           (else
  44.            (receive vals (error "(OPEN '~s '~s) failed ~%~
  45.                                 **~10tType (RET) or (RET filespec) to retry."
  46.                                 fname
  47.                                 mode)
  48.              (if (null? vals) 
  49.                  (loop filespec)
  50.                  (loop (car vals))))))))
  51.  
  52. (define-operation (port-open? port) (ignore port) '#t) ;??
  53.  
  54. (define-operation (re-open port))
  55.  
  56. ;;; Input operations.  All input ports are expected to handle
  57. ;;; READC and UNREADC.
  58.  
  59. (define-predicate INPUT-PORT?)
  60. (define-operation (INTERACTIVE? port) nil)
  61. (define INTERACTIVE-PORT? INTERACTIVE?)
  62.  
  63. (define-operation (READ-CHAR PORT))           ; MUST BE HANDLED.
  64. (define readc read-char)
  65.  
  66. (define-operation (char-ready? port)
  67.   (let ((val (maybe-read-char port)))
  68.     (cond (val
  69.            (unread-char port)
  70.            '#t)
  71.           (else '#f))))
  72.  
  73. (define-operation (maybe-read-char port))     ;++ should default be readc?
  74. (define maybe-readc maybe-read-char)
  75.  
  76. (define-operation (UNREAD-CHAR PORT))         ; MUST BE HANDLED.
  77. (define unreadc unread-char)
  78.  
  79. (define-operation (PEEK-CHAR PORT)
  80.   (cond ((iob? port)
  81.          (vm-peek-char port))
  82.         (else
  83.          (let ((val (read-char port)))
  84.            (unread-char port)
  85.            val))))
  86.  
  87. (define PEEKC peek-char)
  88.  
  89. (define-operation (READ PORT)
  90.   (read-object port (port-read-table port)))
  91.  
  92. (define-settable-operation (PORT-READ-TABLE PORT))
  93.  
  94. (define SET-PORT-READ-TABLE (setter port-read-table))
  95.  
  96. ;;; WITH-BUFFERS is not available in VM.
  97.  
  98. (define-operation (READ-LINE port)
  99.   (with-buffers ((buffer))
  100.     (let ((readc (if (iob? port) vm-read-char read-char))
  101.           (done  (lambda () (buffer->string buffer))))    ; go to.
  102.       (iterate loop ()
  103.         (let ((ch (readc port)))
  104.           (cond ((eof? ch)
  105.                  (if (buffer-empty? buffer) eof (done)))
  106.                 (else
  107.                  (cond ((newline? ch) (done))
  108.                        (else
  109.                         (vm-write-char buffer ch)
  110.                         (loop))))))))))
  111.  
  112. (define-operation (read-block port extend size))
  113.  
  114. (define-operation (clear-input port) (no-value))
  115.  
  116. ;;; Output operations.  All output ports are expected to handle
  117. ;;; WRITEC.
  118.  
  119. (define-predicate OUTPUT-PORT?)
  120.  
  121. (define-operation (print obj port)
  122.   (print-random obj port))
  123.  
  124. (define-operation (display obj port)
  125.   (print obj port))
  126.  
  127. (define-operation (print-type-string obj)
  128.   (cond ((bogus-entity? obj)
  129.          (if (procedure? (bogus-entity-procedure obj)) "Procedure" "Object"))
  130.         ((procedure? obj) "Procedure")
  131.         ((frame?     obj) "Continuation")
  132.         ((extend?    obj) "Object")
  133.         ;; should never fall through past reasonable? check.
  134.         (else "Random")))
  135.  
  136. (define-operation (print-info obj) '#f)
  137.  
  138. ;;; What about robustness problem, i.e. errors within the printer?
  139. ;;; We have to be able to do something intelligent with pair pointer
  140. ;;; into outer space, etc.  Can we hook the print operation to do
  141. ;;; reasonableness check on arg before dispatching?
  142.  
  143. (lset *print-table* nil)
  144.  
  145. (define (print-random obj port)
  146.   (cond ((not (reasonable? obj))
  147.          (format port "#{Unreasonable~_#x~x}" (descriptor->fixnum obj)))
  148.         (else
  149.          (let ((type (print-type-string obj))
  150.                (h    (object-hash obj))
  151.                (id   (or (print-info obj) (identification obj))))
  152.            (if id
  153.                (format port "#{~a~_~s~_~s}" type h id)
  154.                (format port "#{~a~_~s}" type h))))))
  155.  
  156.  
  157. (define-operation (WRITE-CHAR PORT CHAR))        ; must be handled.
  158.  
  159. (define WRITEC write-char)
  160.  
  161. (define-operation (WRITE-STRING PORT STRING)
  162.   (let* ((string (enforce string? string))
  163.          (writec (if (iob? port) vm-write-char write-char))
  164.          (len    (string-length string)))
  165.     (do ((i 0 (fx+ i 1)))
  166.         ((fx>= i len) (no-value))
  167.       (writec port (string-elt string i)))))
  168.  
  169. (define WRITES write-string)
  170.  
  171. ;++ obsolete - flush later
  172. (define-operation (WRITE-TEXT PORT TEXT)
  173.   (display text port))
  174.  
  175. (define-operation (WRITE-LINE PORT STRING)
  176.   (let ((string (enforce string? string)))
  177.     (write-string port string)
  178.     (newline port)))
  179.  
  180. (define-operation (WRITE-SPACES PORT N)
  181.   (cond ((iob? port) (vm-write-spaces port n))
  182.         (else
  183.          (iterate loop ((i 0))
  184.            (cond ((fx>= i n) (no-value))
  185.                  (else
  186.                   (space port)
  187.                   (loop (fx+ i 1))))))))
  188.  
  189. (define-operation (WRITE PORT OBJ)
  190.   (print obj port)
  191.   (newline port))
  192.  
  193.  
  194. (define-operation (SPACE PORT)
  195.   (cond ((or (fx>= (hpos port) (line-length port))
  196.              (fx>= (hpos port) (wrap-column port)))
  197.          (newline port))
  198.         (else
  199.          (write-char port #\space))))
  200.  
  201.  
  202. ;;; This should be the only place in the system where
  203. ;;; #\NEWLINE is written to a port.
  204.  
  205. (define-operation (newline port)
  206.   (write-char port #\newline))
  207.  
  208. (define NEW-LINE newline)
  209.  
  210. (define-operation (FRESHLINE port)
  211.   (if (fx> (hpos port) 0) (newline port)))
  212.  
  213. (define FRESH-LINE freshline)
  214.  
  215. ;;; Presumably ok to ignore.
  216. (define-operation (FORCE-OUTPUT port) nil)
  217. (define-settable-operation (PORT-NAME PORT) 'anonymous)
  218. (define set-port-name (setter port-name))
  219. (define-operation (port->IOB port) nil)
  220.  
  221. ;++ What about FILEPOS and SET-FILEPOS?  last-modified time?
  222. ;++ Name some other operations that should be supported.
  223.  
  224. ;;; Other random stuff.
  225.  
  226.  
  227. (define-settable-operation (LINE-LENGTH port) standard-line-length)
  228.  
  229. (define SET-LINE-LENGTH (setter line-length))
  230.  
  231. (define-settable-operation (WRAP-COLUMN port) standard-wrap-column)
  232.  
  233. (define SET-WRAP-COLUMN (setter wrap-column))
  234.  
  235. ;;; force fresh-line to do newline
  236.  
  237. (define hpos
  238.   (operation (lambda (port) (ignore port) 1) ; force fresh-line to do newline
  239.     ((setter self) set-hpos)))
  240.  
  241. (define-operation (set-hpos port pos)
  242.   (let ((pos (enforce fixnum? pos))
  243.         (p   (cond ((fx> (hpos port) pos) (newline port) 0)
  244.                    (else (hpos port)))))
  245.     (write-spaces port (fx- pos p))))
  246.  
  247. (define VPOS
  248.   (operation (lambda (port) (ignore port) 1)
  249.     ((setter self) set-vpos)))
  250.  
  251. (define-operation (SET-VPOS PORT POS)
  252.   (let ((pos (enforce fixnum? pos))
  253.         (v   (vpos port)))
  254.     (do ((v v (fx+ v 1)))
  255.         ((fx>= v pos) pos)
  256.       (newline port))))
  257.  
  258. ;;; Other random operations.
  259.  
  260. (define-settable-operation (FILE-POSITION PORT))
  261.  
  262. (define SET-FILE-POSITION (setter file-position))
  263.  
  264. (define-predicate OUTPUT-WIDTH-PORT?)
  265.  
  266. (define-operation (PRINT-WIDTH OBJ)
  267.   (with-output-width-port port (print obj port)))
  268.  
  269. (define-operation (DISPLAY-WIDTH OBJ)
  270.   (with-output-width-port port (display obj port)))
  271.  
  272. (define-unimplemented (WRITE-ELIDED PORT OBJ LIMIT))
  273.