port.scm 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427
  1. ; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
  2. ; Ports and port handlers
  3. ; (discloser <port>) -> (<symbol> <value> ...)
  4. ; (close <port>) -> whatever
  5. ;
  6. ; Input ports
  7. ; (byte <port> <read?>) -> <byte>
  8. ; (char <port> <mode>) -> <char>
  9. ; <mode> says whether we're doing ...
  10. ; - #t: a PEEK
  11. ; - #f: a READ
  12. ; - (): CHAR-READY?
  13. ; (block <port> <buffer> <start> <count>) -> <byte count>
  14. ; (ready? <port>) -> <boolean>
  15. ;
  16. ; Output ports
  17. ; (byte <port> <byte>) -> whatever
  18. ; (char <port> <char>) -> whatever
  19. ; (block <port> <buffer> <start> <count>) -> whatever
  20. ; (ready? <port>) -> <boolean>
  21. ; (force-output <port>) -> whatever
  22. (define-record-type port-handler :port-handler
  23. (make-port-handler discloser close byte char block ready? force)
  24. port-handler?
  25. (discloser port-handler-discloser)
  26. (close port-handler-close)
  27. (byte port-handler-byte)
  28. (char port-handler-char)
  29. (block port-handler-block)
  30. (ready? port-handler-ready?)
  31. (force port-handler-force)) ; only used for output
  32. ;----------------
  33. ; Disclosing ports by calling the disclose handler.
  34. (define (disclose-port port)
  35. ((port-handler-discloser (port-handler port))
  36. port))
  37. (define-method &disclose ((port <input-port>))
  38. (disclose-port port))
  39. (define-method &disclose ((port <output-port>))
  40. (disclose-port port))
  41. ;----------------
  42. ; Set up VM exception handlers for the three unnecessary I/O primitives,
  43. ; READ-BYTE, PEEK-BYTE, and WRITE-BYTE. These do the right thing in
  44. ; the case of unbuffered ports or buffer overflow or underflow.
  45. ;
  46. ; This is abstracted to avoid a circular module dependency.
  47. (define (initialize-i/o-handlers! define-vm-exception-handler signal-exception)
  48. (define-vm-exception-handler (enum op read-byte)
  49. (one-arg-proc->handler (lambda (port)
  50. ((port-handler-byte (port-handler port))
  51. port
  52. #t))))
  53. (define-vm-exception-handler (enum op peek-byte)
  54. (one-arg-proc->handler (lambda (port)
  55. ((port-handler-byte (port-handler port))
  56. port
  57. #f))))
  58. (define-vm-exception-handler (enum op read-char)
  59. (one-arg-proc->handler (lambda (port)
  60. ((port-handler-char (port-handler port))
  61. port
  62. #f))))
  63. (define-vm-exception-handler (enum op peek-char)
  64. (one-arg-proc->handler (lambda (port)
  65. ((port-handler-char (port-handler port))
  66. port
  67. #t))))
  68. (define-vm-exception-handler (enum op write-byte)
  69. (two-arg-proc->handler (lambda (byte port)
  70. ((port-handler-byte (port-handler port))
  71. port
  72. byte))))
  73. (define-vm-exception-handler (enum op write-char)
  74. (two-arg-proc->handler (lambda (ch port)
  75. ((port-handler-char (port-handler port))
  76. port
  77. ch)))))
  78. ; Check the VM exception and then lock the port.
  79. (define (one-arg-proc->handler proc)
  80. (lambda (opcode reason port)
  81. (if (= reason (enum exception buffer-full/empty))
  82. (proc port)
  83. ;; note this must be an assertion violation---these only look at the buffer
  84. (signal-vm-exception opcode reason port))))
  85. ; This could be combined with one-arg-... if the port were the first argument.
  86. (define (two-arg-proc->handler proc)
  87. (lambda (opcode reason arg port)
  88. (if (= reason (enum exception buffer-full/empty))
  89. (proc arg port)
  90. ;; note this must be an assertion violation---these only look at the buffer
  91. (signal-vm-exception opcode reason arg port))))
  92. ;----------------
  93. ; Wrappers for the various port operations. These check types and arguments
  94. ; and then call the appropriate handler procedure.
  95. (define (real-char-ready? port)
  96. (cond
  97. ((open-input-port? port)
  98. ((port-handler-char (port-handler port)) port '()))
  99. (else
  100. (assertion-violation 'char-ready? "invalid argument" port))))
  101. ; See if there is a character available. BYTE-READY? itself is defined
  102. ; in current-port.scm as it needs CURRENT-INPUT-PORT when called with
  103. ; no arguments.
  104. (define (real-byte-ready? port)
  105. (if (open-input-port? port)
  106. ((port-handler-ready? (port-handler port))
  107. port)
  108. (assertion-violation 'real-byte-ready? "invalid argument" port)))
  109. ; Reading in a block of characters at once.
  110. (define (read-block buffer start count port . maybe-wait?)
  111. (if (and (port? port)
  112. (open-input-port? port)
  113. (okay-limits? buffer
  114. start
  115. count))
  116. (if (= count 0)
  117. 0
  118. ((port-handler-block (port-handler port))
  119. port
  120. buffer
  121. start
  122. count
  123. (or (null? maybe-wait?)
  124. (car maybe-wait?))))
  125. (assertion-violation 'read-block "invalid argument" buffer start count port)))
  126. ; Write the COUNT bytes beginning at START from BUFFER to PORT.
  127. (define (write-block buffer start count port)
  128. (if (and (port? port)
  129. (open-output-port? port)
  130. (okay-limits? buffer start count))
  131. (if (< 0 count)
  132. ((port-handler-block (port-handler port))
  133. port
  134. buffer
  135. start
  136. count))
  137. (assertion-violation 'write-block "invalid argument" buffer start count port)))
  138. (define (write-string string port)
  139. (do ((size (string-length string))
  140. (i 0 (+ 1 i)))
  141. ((>= i size) (unspecific))
  142. (write-char (string-ref string i) port)))
  143. ; BYTE-READY? for output ports.
  144. (define (output-port-ready? port)
  145. (if (open-output-port? port)
  146. ((port-handler-ready? (port-handler port))
  147. port)
  148. (assertion-violation 'output-port-ready? "invalid argument" port)))
  149. ; Forcing output.
  150. (define (force-output port)
  151. (if (open-output-port? port)
  152. ((port-handler-force (port-handler port))
  153. port
  154. #t) ; raise error if PORT is not open
  155. (assertion-violation 'force-output "invalid argument" port)))
  156. (define (force-output-if-open port)
  157. (if (open-output-port? port)
  158. ((port-handler-force (port-handler port))
  159. port
  160. #f))) ; do not raise error if PORT is not open
  161. ; Closing input and output ports.
  162. ; RnRS says that CLOSE-{IN|OUT}PUT-PORT is idempotent.
  163. (define (close-input-port port)
  164. (if (input-port? port)
  165. (begin
  166. (if (open-input-port? port)
  167. ((port-handler-close (port-handler port))
  168. port))
  169. (unspecific))
  170. (assertion-violation 'close-input-port "invalid argument" port)))
  171. (define (close-output-port port)
  172. (if (output-port? port)
  173. (begin
  174. (if (open-output-port? port)
  175. ((port-handler-close (port-handler port))
  176. port))
  177. (unspecific))
  178. (assertion-violation 'close-output-port "invalid argument" port)))
  179. ;----------------
  180. (define (port-text-codec p)
  181. (spec->text-codec (port-text-codec-spec p)))
  182. (define (set-port-text-codec! p codec)
  183. (set-port-text-codec-spec! p (text-codec->spec codec)))
  184. ;----------------
  185. ; Check that BUFFER contains COUNT characters starting from START.
  186. (define (okay-limits? buffer start count)
  187. (and (integer? start)
  188. (exact? start)
  189. (<= 0 start)
  190. (integer? count)
  191. (exact? count)
  192. (<= 0 count)
  193. (<= (+ start count)
  194. (cond ((byte-vector? buffer)
  195. (byte-vector-length buffer))
  196. (else
  197. -1)))))
  198. ;----------------
  199. ; Is PORT open?
  200. (define (open-port? port)
  201. (not (= 0 (bitwise-and open-port-mask (provisional-port-status port)))))
  202. (define open-port-mask
  203. (bitwise-ior (arithmetic-shift 1 (enum port-status-options open-for-input))
  204. (arithmetic-shift 1 (enum port-status-options open-for-output))))
  205. ;----------------
  206. ; Input ports
  207. (define input-port-mask
  208. (arithmetic-shift 1
  209. (enum port-status-options input)))
  210. (define open-input-port-mask
  211. (arithmetic-shift 1
  212. (enum port-status-options open-for-input)))
  213. (define open-input-port-status
  214. (bitwise-ior input-port-mask
  215. open-input-port-mask))
  216. (define (open-input-port? port)
  217. (not (= 0 (bitwise-and open-input-port-mask
  218. (provisional-port-status port)))))
  219. (define (make-input-port-closed! port)
  220. (provisional-set-port-status! port
  221. (bitwise-and (provisional-port-status port)
  222. (bitwise-not open-input-port-mask))))
  223. ;----------------
  224. ; Output ports
  225. (define output-port-mask
  226. (arithmetic-shift 1
  227. (enum port-status-options output)))
  228. (define open-output-port-mask
  229. (arithmetic-shift 1
  230. (enum port-status-options open-for-output)))
  231. (define open-output-port-status
  232. (bitwise-ior output-port-mask
  233. open-output-port-mask))
  234. (define (open-output-port? port)
  235. (not (= 0 (bitwise-and open-output-port-mask
  236. (provisional-port-status port)))))
  237. (define (make-output-port-closed! port)
  238. (provisional-set-port-status! port
  239. (bitwise-and (provisional-port-status port)
  240. (bitwise-not open-output-port-mask))))
  241. (define (make-unbuffered-output-port handler data)
  242. (if (port-handler? handler)
  243. (make-port handler
  244. (enum text-encoding-option latin-1)
  245. #f
  246. open-output-port-status
  247. #f ; lock (not used in unbuffered ports)
  248. data
  249. (make-byte-vector 128 0) ; buffer
  250. #f ; index
  251. #f ; limit
  252. #f ; pending-cr?
  253. #f) ; pending-eof?
  254. (assertion-violation 'make-unbuffered-output-port "invalid argument"
  255. handler data)))
  256. (define (make-one-byte-handler write-block)
  257. (lambda (port byte)
  258. (let ((buffer (port-buffer port)))
  259. (byte-vector-set! buffer 0 byte)
  260. (let loop ()
  261. (if (= 0 (write-block port buffer 0 1))
  262. (loop))))))
  263. (define (make-one-char-handler write-block)
  264. (lambda (port ch)
  265. (let ((buffer (port-buffer port))
  266. (encode-char
  267. (text-codec-encode-char-proc (port-text-codec port))))
  268. (let ((encode-count
  269. (if (and (port-crlf? port)
  270. (char=? ch #\newline))
  271. (atomically
  272. (call-with-values
  273. (lambda ()
  274. (encode-char cr
  275. buffer 0 (byte-vector-length buffer)))
  276. (lambda (ok? encode-count-cr)
  277. ;; OK? must be true
  278. (call-with-values
  279. (lambda ()
  280. (encode-char #\newline
  281. buffer
  282. encode-count-cr
  283. (- (byte-vector-length buffer) encode-count-cr)))
  284. (lambda (ok? encode-count-lf)
  285. ;; OK? must be true
  286. (+ encode-count-cr encode-count-lf))))))
  287. (atomically
  288. (call-with-values
  289. (lambda ()
  290. (encode-char ch
  291. buffer 0 (byte-vector-length buffer)))
  292. (lambda (ok? encode-count)
  293. (if ok?
  294. encode-count
  295. ;; hrmpfl ...
  296. (call-with-values
  297. (lambda ()
  298. (encode-char #\?
  299. buffer 0 (byte-vector-length buffer)))
  300. (lambda (ok? encode-count)
  301. encode-count)))))))))
  302. (let loop ((index 0))
  303. (let* ((to-write (- encode-count index))
  304. (written
  305. (write-block port buffer index to-write)))
  306. (if (< written to-write)
  307. (loop (+ index written)))))))))
  308. (define cr (ascii->char 13))
  309. (define (make-write-block-handler write-block)
  310. (lambda (port buffer start count)
  311. (let loop ((sent 0))
  312. (let ((sent (+ sent
  313. (write-block port
  314. buffer
  315. (+ start sent)
  316. (- count sent)))))
  317. (if (< sent count)
  318. (loop sent))))))
  319. (define (make-unbuffered-output-port-handler discloser closer! write-block ready?)
  320. (make-port-handler discloser
  321. closer!
  322. (make-one-byte-handler write-block)
  323. (make-one-char-handler write-block)
  324. (make-write-block-handler write-block)
  325. ready?
  326. (lambda (port error-if-closed?) ; output forcer
  327. (unspecific))))
  328. ;----------------
  329. ; Output ports that just discard any output.
  330. (define null-output-port-handler
  331. (make-port-handler
  332. (lambda (ignore) ; disclose
  333. (list 'null-output-port))
  334. make-output-port-closed! ; close
  335. (lambda (port byte) ; one-byte (we just empty the buffer)
  336. (set-port-index! port 0))
  337. (lambda (port char) ; one-char (we just empty the buffer)
  338. (set-port-index! port 0))
  339. (lambda (port buffer start count) ; write-block
  340. count)
  341. (lambda (port) ; ready?
  342. #t)
  343. (lambda (port error-if-closed?) ; force-output
  344. (unspecific))))
  345. ; They can all share a buffer. The buffer is needed because the WRITE-BYTE
  346. ; byte code actually wants to put characters somewhere.
  347. (define null-output-buffer
  348. (make-byte-vector 1024 0))
  349. (define (make-null-output-port)
  350. (make-port null-output-port-handler
  351. null-text-codec
  352. #f
  353. open-output-port-status
  354. #f ; timestamp
  355. #f ; data
  356. null-output-buffer
  357. 0 ; index
  358. (byte-vector-length null-output-buffer) ; limit
  359. #f ; pending-cr?
  360. #f)) ; pending-eof?