prim-io.scm 18 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579
  1. ; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.
  2. ; I/O primitives
  3. ; See doc/io.txt for a description of Scheme 48's I/O system.
  4. ; Argument specs
  5. (define open-input-port->
  6. (input-type (lambda (x)
  7. (and (port? x)
  8. (port-has-status? x (enum port-status-options
  9. open-for-input))))
  10. no-coercion))
  11. (define open-output-port->
  12. (input-type (lambda (x)
  13. (and (port? x)
  14. (port-has-status? x (enum port-status-options
  15. open-for-output))))
  16. no-coercion))
  17. (define channel-> (input-type channel? no-coercion))
  18. (define (port-has-status? port status)
  19. (not (= 0 (bitwise-and (extract-fixnum (port-status port))
  20. (shift-left 1 status)))))
  21. ;; Must be a C-level string, as a byte vector
  22. (define (extract-filename filename)
  23. (extract-low-string filename))
  24. ; Check SPEC type and then call OPEN-CHANNEL.
  25. (define-consing-primitive open-channel (any-> any-> fixnum-> any->)
  26. (lambda (ignore) channel-size)
  27. (lambda (spec id mode close-silently? key)
  28. (let* ((lose (lambda (reason)
  29. (raise-exception* reason 0 spec (enter-fixnum mode))))
  30. (win (lambda (index)
  31. (receive (channel reason)
  32. (make-registered-channel mode id index close-silently? key)
  33. (cond ((false? channel)
  34. (if (code-vector? spec)
  35. (close-channel-index! index spec mode))
  36. (lose reason))
  37. (else
  38. (goto return channel)))))))
  39. (cond ((not (open-channel-status? mode))
  40. (lose (enum exception wrong-type-argument)))
  41. ((fixnum? spec)
  42. (if (<= 0 (extract-fixnum spec))
  43. (win (extract-fixnum spec))
  44. (lose (enum exception wrong-type-argument))))
  45. ((code-vector? spec)
  46. (receive (channel status)
  47. (let ((filename (extract-filename spec)))
  48. (if (or (= mode (enum channel-status-option input))
  49. (= mode (enum channel-status-option special-input)))
  50. (open-input-file-channel filename)
  51. (open-output-file-channel filename)))
  52. (cond ((eq? status (enum errors no-errors))
  53. (win channel))
  54. (else
  55. (raise-exception os-error 0
  56. spec
  57. (enter-fixnum mode)
  58. (enter-fixnum status))))))
  59. (else
  60. (lose (enum exception wrong-type-argument)))))))
  61. (define (open-channel-status? mode)
  62. (or (= mode (enum channel-status-option input))
  63. (= mode (enum channel-status-option output))
  64. (= mode (enum channel-status-option special-input))
  65. (= mode (enum channel-status-option special-output))))
  66. (define-consing-primitive close-channel (channel->)
  67. (lambda (ignore) error-string-size)
  68. (lambda (channel key)
  69. (if (open? channel)
  70. (let ((status (close-channel! channel)))
  71. (if (error? status)
  72. (raise-exception os-error 0 channel (get-error-string status key))
  73. (goto no-result)))
  74. (raise-exception wrong-type-argument 0 channel))))
  75. (define-consing-primitive channel-ready? (channel->)
  76. (lambda (ignore) error-string-size)
  77. (lambda (channel key)
  78. (if (open? channel)
  79. (receive (ready? status)
  80. (channel-ready? (extract-channel channel)
  81. (input-channel? channel))
  82. (if (error? status)
  83. (raise-exception os-error 0 channel (get-error-string status key))
  84. (goto return-boolean ready?)))
  85. (raise-exception wrong-type-argument 0 channel))))
  86. ;----------------
  87. ; Reading from and writing to channels.
  88. ;
  89. ; This is a wrapper around CHANNEL-READ-BLOCK. We check argument
  90. ; types and interpret the return value. We either return a
  91. ; number---the number of bytes read---or a cell containing the OS
  92. ; error code in the case of an I/O error.
  93. (define-consing-primitive channel-maybe-read
  94. (channel-> any-> fixnum-> fixnum-> boolean->)
  95. (lambda (ignore) cell-size)
  96. (lambda (channel buffer start count wait? key)
  97. (if (and (input-channel? channel)
  98. (buffer? buffer)
  99. (not (immutable? buffer))
  100. (<= (+ start count)
  101. (buffer-length buffer)))
  102. (receive (got eof? pending? status)
  103. (channel-read-block (extract-channel channel)
  104. (address+ (address-after-header buffer)
  105. start)
  106. count
  107. wait?)
  108. (goto return
  109. (cond ((error? status)
  110. (make-cell (enter-fixnum status) key))
  111. (eof?
  112. ;; possible on Windows
  113. (if pending?
  114. (set-channel-os-status! channel true))
  115. eof-object)
  116. (pending?
  117. (set-channel-os-status! channel true)
  118. false)
  119. (else
  120. (enter-fixnum got)))))
  121. (raise-exception wrong-type-argument 0
  122. channel
  123. buffer
  124. (enter-fixnum start)
  125. (enter-fixnum count)
  126. (enter-boolean wait?)))))
  127. ; This is a wrapper around CHANNEL-WRITE-BLOCK. We check argument
  128. ; types and interpret the return value. We either return a
  129. ; number---the number of bytes written---or a cell containing the OS
  130. ; error code in the case of an I/O error.
  131. (define-consing-primitive channel-maybe-write
  132. (channel-> any-> fixnum-> fixnum->)
  133. (lambda (ignore) cell-size)
  134. (lambda (channel buffer start count key)
  135. (if (and (output-channel? channel)
  136. (buffer? buffer)
  137. (<= (+ start count)
  138. (buffer-length buffer)))
  139. (receive (got pending? status)
  140. (channel-write-block (extract-channel channel)
  141. (address+ (address-after-header buffer)
  142. start)
  143. count)
  144. (goto return
  145. (cond
  146. ((error? status)
  147. (make-cell (enter-fixnum status) key))
  148. (pending?
  149. (set-channel-os-status! channel true)
  150. false)
  151. (else
  152. (enter-fixnum got)))))
  153. (raise-exception wrong-type-argument 0
  154. channel
  155. buffer
  156. (enter-fixnum start)
  157. (enter-fixnum count)))))
  158. ;----------------
  159. ; Utilities for the above two opcodes.
  160. (define (buffer? thing)
  161. (code-vector? thing))
  162. (define (buffer-length buffer)
  163. (code-vector-length buffer))
  164. (define (extract-channel channel)
  165. (extract-fixnum (channel-os-index channel)))
  166. ;----------------
  167. ;; random stuff
  168. (define-primitive channel-parameter (fixnum->)
  169. (lambda (param)
  170. (enum-case channel-parameter-option param
  171. ((buffer-size)
  172. (goto return-fixnum (channel-buffer-size)))
  173. ((crlf?)
  174. (goto return-boolean (channel-crlf?)))
  175. (else
  176. (raise-exception bad-option 0 (enter-fixnum param))))))
  177. (define-primitive channel-abort (channel->)
  178. (lambda (channel)
  179. (goto return (vm-channel-abort channel))))
  180. (define-primitive open-channels-list ()
  181. (lambda ()
  182. (goto return (open-channels-list))))
  183. ; Copying error strings into the heap.
  184. (define max-error-string-length 512)
  185. (define error-string-size (vm-string-size max-error-string-length))
  186. (define (get-error-string status key)
  187. (let* ((string (error-string status))
  188. (len (min (string-length string)
  189. max-error-string-length))
  190. (new (vm-make-string len key)))
  191. (do ((i 0 (+ i 1)))
  192. ((= i len))
  193. (vm-string-set! new i (char->ascii (string-ref string i))))
  194. new))
  195. ;----------------------------------------------------------------
  196. ; Port instructions.
  197. ;
  198. ; These are only for speed. If no port was supplied by the user they have
  199. ; to look up the appropriate port in the current dynamic environments.
  200. ; This is a complete hack, also done for speed. See rts/current-port.scm
  201. ; for the other end.
  202. (define (read-or-peek-byte read?)
  203. (lambda ()
  204. (let ((port (if (= (code-byte 0) 0)
  205. (val)
  206. (get-current-port
  207. (enter-fixnum
  208. (enum current-port-marker current-input-port))))))
  209. (if (and (port? port)
  210. (port-has-status? port
  211. (enum port-status-options open-for-input)))
  212. (let ((b (port-buffer port)))
  213. (if (false? b)
  214. (raise-exception buffer-full/empty 1 port)
  215. (let ((i (extract-fixnum (port-index port)))
  216. (l (extract-fixnum (port-limit port))))
  217. (cond ((= i l)
  218. (raise-exception buffer-full/empty 1 port))
  219. (else
  220. (if read?
  221. (set-port-index! port (enter-fixnum (+ i 1))))
  222. (goto continue-with-value
  223. (enter-fixnum (code-vector-ref b i))
  224. 1))))))
  225. (raise-exception wrong-type-argument 1 port)))))
  226. (let ((do-it (read-or-peek-byte #t)))
  227. (define-primitive read-byte () do-it))
  228. (let ((do-it (read-or-peek-byte #f)))
  229. (define-primitive peek-byte () do-it))
  230. (define (read-or-peek-char read?)
  231. (lambda ()
  232. (let ((port (if (= (code-byte 0) 0)
  233. (val)
  234. (get-current-port
  235. (enter-fixnum
  236. (enum current-port-marker current-input-port))))))
  237. (if (and (port? port)
  238. (port-has-status? port
  239. (enum port-status-options open-for-input)))
  240. (let ((b (port-buffer port)))
  241. (if (false? b)
  242. (raise-exception buffer-full/empty 1 port)
  243. (let loop ((i (extract-fixnum (port-index port))))
  244. (let ((l (extract-fixnum (port-limit port)))
  245. (codec (port-text-codec-spec port))
  246. (lose
  247. (lambda ()
  248. ;; we may have gotten out of synch because of CR/LF conversion
  249. (if read?
  250. (set-port-index! port (enter-fixnum i)))
  251. (raise-exception buffer-full/empty 1 port))))
  252. (cond ((= i l)
  253. (lose))
  254. ((not (fixnum? codec))
  255. (lose))
  256. (else
  257. (call-with-values
  258. (lambda ()
  259. (decode-scalar-value (extract-fixnum codec)
  260. (address+ (address-after-header b) i)
  261. (- l i)))
  262. (lambda (encoding-ok? ok? incomplete? value count)
  263. (define (deliver)
  264. (if read?
  265. (begin
  266. (set-port-pending-cr?! port false)
  267. (set-port-index! port (enter-fixnum (+ i count)))))
  268. (goto continue-with-value
  269. (scalar-value->char value)
  270. 1))
  271. (cond
  272. ((not encoding-ok?)
  273. (raise-exception wrong-type-argument 1 port))
  274. ((or (not ok?) incomplete?)
  275. (lose))
  276. ((not (false? (port-crlf? port)))
  277. ;; CR/LF handling. Great.
  278. (cond
  279. ((= value cr-code)
  280. (if read?
  281. (begin
  282. (set-port-pending-cr?! port true)
  283. (set-port-index! port (enter-fixnum (+ i count)))))
  284. (goto continue-with-value (scalar-value->char lf-code) 1))
  285. ((and (= value lf-code)
  286. (not (false? (port-pending-cr? port))))
  287. (if read?
  288. (set-port-pending-cr?! port false))
  289. (loop (+ i count)))
  290. (else
  291. (deliver))))
  292. (else
  293. (deliver)))))))))))
  294. (raise-exception wrong-type-argument 1 port)))))
  295. (let ((do-it (read-or-peek-char #t)))
  296. (define-primitive read-char () do-it))
  297. (let ((do-it (read-or-peek-char #f)))
  298. (define-primitive peek-char () do-it))
  299. (define-primitive write-byte ()
  300. (lambda ()
  301. (receive (byte port)
  302. (if (= (code-byte 0) 0)
  303. (values (pop)
  304. (val))
  305. (values (val)
  306. (get-current-port (enter-fixnum
  307. (enum current-port-marker
  308. current-output-port)))))
  309. (cond
  310. ((not (and (fixnum? byte)
  311. (port? port)
  312. (port-has-status? port
  313. (enum port-status-options open-for-output))))
  314. (raise-exception wrong-type-argument 1 byte port))
  315. ((false? (port-limit port)) ; unbuffered
  316. (raise-exception buffer-full/empty 1 byte port))
  317. (else
  318. (let ((b (port-buffer port))
  319. (i (extract-fixnum (port-index port))))
  320. (cond ((= i (code-vector-length b))
  321. (raise-exception buffer-full/empty 1 byte port))
  322. (else
  323. (set-port-index! port (enter-fixnum (+ i 1)))
  324. (code-vector-set! b i (extract-fixnum byte))
  325. (goto continue-with-value unspecific-value 1)))))))))
  326. (define cr-code 13)
  327. (define lf-code 10)
  328. (define-primitive write-char ()
  329. (lambda ()
  330. (receive (char port)
  331. (if (= (code-byte 0) 0)
  332. (values (pop)
  333. (val))
  334. (values (val)
  335. (get-current-port (enter-fixnum
  336. (enum current-port-marker
  337. current-output-port)))))
  338. (cond
  339. ((not (and (vm-char? char)
  340. (port? port)
  341. (port-has-status? port
  342. (enum port-status-options open-for-output))))
  343. (raise-exception wrong-type-argument 1 char port))
  344. ((false? (port-limit port)) ; unbuffered
  345. (raise-exception buffer-full/empty 1 char port))
  346. (else
  347. (let ((codec (port-text-codec-spec port))
  348. (lose
  349. ;; #### this isn't really the right exception
  350. (lambda () (raise-exception buffer-full/empty 1 char port))))
  351. (if (not (fixnum? codec))
  352. (lose)
  353. (let* ((b (port-buffer port))
  354. (i (extract-fixnum (port-index port)))
  355. (l (code-vector-length b)))
  356. (cond
  357. ((= i l) (lose))
  358. ;; CR/LF handling is atrocious
  359. ((and (not (false? (port-crlf? port)))
  360. (= (char->scalar-value char) lf-code))
  361. (call-with-values
  362. (lambda ()
  363. (encode-scalar-value (extract-fixnum codec) cr-code
  364. (address+ (address-after-header b) i)
  365. (- l i)))
  366. (lambda (codec-ok? encoding-ok? out-of-space? count)
  367. (cond
  368. ((not codec-ok?)
  369. (raise-exception wrong-type-argument 1 char port))
  370. ((or (not encoding-ok?) out-of-space?)
  371. (lose))
  372. (else
  373. (let ((i (+ i count)))
  374. (if (= i l)
  375. (lose)
  376. (call-with-values
  377. (lambda ()
  378. (encode-scalar-value (extract-fixnum codec) lf-code
  379. (address+ (address-after-header b) i)
  380. (- l i)))
  381. (lambda (codec-ok? encoding-ok? out-of-space? count)
  382. (cond
  383. ;; the codec is the same as before, so it must be OK
  384. ((or (not encoding-ok?) out-of-space?)
  385. (lose))
  386. (else
  387. (set-port-index! port (enter-fixnum (+ i count)))
  388. (goto continue-with-value unspecific-value 1))))))))))))
  389. (else
  390. (call-with-values
  391. (lambda ()
  392. (encode-scalar-value (extract-fixnum codec) (char->scalar-value char)
  393. (address+ (address-after-header b) i)
  394. (- l i)))
  395. (lambda (codec-ok? encoding-ok? out-of-space? count)
  396. (cond
  397. ((not codec-ok?)
  398. (raise-exception wrong-type-argument 1 char port))
  399. ((or (not encoding-ok?) out-of-space?)
  400. (lose))
  401. (else
  402. (set-port-index! port (enter-fixnum (+ i count)))
  403. (goto continue-with-value unspecific-value 1)))))))))))))))
  404. ; Do an ASSQ-like walk up the current dynamic environment, looking for
  405. ; MARKER.
  406. (define (get-current-port marker)
  407. (let ((thread (current-thread)))
  408. (if (and (record? thread)
  409. (< 1 (record-length thread)))
  410. (let loop ((env (record-ref thread 1)))
  411. (cond ((not (and (vm-pair? env)
  412. (vm-pair? (vm-car env))))
  413. (if (vm-eq? env null)
  414. (error (if (eq? (extract-fixnum marker)
  415. (enum current-port-marker
  416. current-output-port))
  417. "dynamic environment doesn't have current-output-port"
  418. "dynamic environment doesn't have current-input-port"))
  419. (error "dynamic environment is not a proper list")))
  420. ((vm-eq? marker (vm-car (vm-car env)))
  421. (vm-cdr (vm-car env)))
  422. (else
  423. (loop (vm-cdr env)))))
  424. (error "current thread is not a record"))))
  425. (define-consing-primitive os-error-message (fixnum->)
  426. (lambda (ignore) error-string-size)
  427. (lambda (status key)
  428. (goto return (get-error-string status key))))
  429. ;----------------
  430. ; A poor man's WRITE for use in debugging.
  431. (define-primitive message (any->)
  432. (lambda (stuff)
  433. (let ((out (current-error-port)))
  434. (let loop ((stuff stuff))
  435. (if (vm-pair? stuff)
  436. (begin
  437. (message-element (vm-car stuff) out)
  438. (loop (vm-cdr stuff)))))
  439. (newline out)))
  440. return-unspecific)
  441. (define (message-element thing out)
  442. (cond ((fixnum? thing)
  443. (write-integer (extract-fixnum thing) out))
  444. ((vm-char? thing)
  445. (write-string "#\\" out)
  446. (write-char (ascii->char (char->scalar-value thing)) out)) ; ####
  447. ((typed-record? thing)
  448. (write-string "#{" out)
  449. (write-vm-string (record-type-name thing) out)
  450. (write-char #\} out))
  451. ((vm-string? thing)
  452. (write-vm-string thing out))
  453. ((vm-symbol? thing)
  454. (write-vm-string (vm-symbol->string thing) out))
  455. (else
  456. (write-string (cond ((vm-boolean? thing)
  457. (if (extract-boolean thing) "#t" "#f"))
  458. ((vm-eq? thing null)
  459. "()")
  460. ((vm-pair? thing)
  461. "(...)")
  462. ((vm-vector? thing)
  463. "#(...)")
  464. ((closure? thing)
  465. "#{procedure}")
  466. ((template? thing)
  467. "#{template}")
  468. ((location? thing)
  469. "#{location}")
  470. ((code-vector? thing)
  471. "#{code-vector}")
  472. ((continuation? thing)
  473. "#{continuation}")
  474. (else
  475. "???"))
  476. out))))
  477. (define (typed-record? thing)
  478. (and (record? thing)
  479. (< 0 (record-length thing))
  480. (let ((type (record-ref thing 0)))
  481. (and (record? type)
  482. (< 2 (record-length type))
  483. (vm-symbol? (record-ref type 2))))))
  484. (define (record-type-name record)
  485. (vm-symbol->string (record-ref (record-ref record 0) 2)))
  486. ;----------------------------------------------------------------
  487. ; RESUME-PROC is called when the image is resumed.
  488. ; This does a garbage collection rooting from RESUME-PROC, writes the heap
  489. ; into a file, and then aborts the garbage collection (which didn't modify
  490. ; any VM registers or the stack).
  491. ; Bug: finalizers for things in the image are ignored.
  492. (define-consing-primitive write-image-low (code-vector-> any-> code-vector-> vector->)
  493. (lambda (ignore) error-string-size)
  494. (lambda (filename resume-proc comment-string undumpables key)
  495. (let* ((lose (lambda (reason status)
  496. (raise-exception* reason 0
  497. filename resume-proc comment-string
  498. (get-error-string status key))))
  499. (port-lose (lambda (reason status port)
  500. (if (error? (close-output-port port))
  501. (begin
  502. (error-message "Unable to close image file")
  503. (unspecific))) ; avoid type problem
  504. (lose reason status))))
  505. (receive (port status)
  506. (open-output-file (extract-filename filename))
  507. (if (error? status)
  508. (lose (enum exception cannot-open-channel) status)
  509. (let ((status (write-string (extract-low-string comment-string) port)))
  510. (if (error? status)
  511. (port-lose (enum exception os-error) status port)
  512. (let ((status (s48-write-image resume-proc
  513. undumpables
  514. port)))
  515. (if (error? status)
  516. (port-lose (enum exception os-error) status port)
  517. (let ((status (close-output-port port)))
  518. (if (error? status)
  519. (lose (enum exception os-error) status)
  520. (goto no-result))))))))))))
  521. ; READ-IMAGE needs to protect some values against GCs (this can't be with
  522. ; READ-IMAGE as that is compiled separately.)
  523. (add-gc-root! s48-initializing-gc-root)