| blob | 889b902460477f698b2b31ee559956bd54981c02 |
1 ;;;============================================================================
3 ;;; File: "_io.scm"
5 ;;; Copyright (c) 1994-2011 by Marc Feeley, All Rights Reserved.
7 ;;;============================================================================
9 (##include "header.scm")
11 ;;;============================================================================
13 ;;; Implementation of exceptions.
15 (implement-library-type-datum-parsing-exception)
17 (define-prim (##raise-datum-parsing-exception kind readenv . parameters)
18 (macro-raise
19 (macro-make-datum-parsing-exception
20 kind
21 readenv
22 parameters)))
24 (implement-library-type-unterminated-process-exception)
26 (define-prim (##raise-unterminated-process-exception proc . args)
27 (##extract-procedure-and-arguments
28 proc
29 args
30 #f
31 #f
32 #f
33 (lambda (procedure arguments dummy1 dummy2 dummy3)
34 (macro-raise
35 (macro-make-unterminated-process-exception procedure arguments)))))
37 (implement-library-type-nonempty-input-port-character-buffer-exception)
39 (define-prim (##raise-nonempty-input-port-character-buffer-exception proc . args)
40 (##extract-procedure-and-arguments
41 proc
42 args
43 #f
44 #f
45 #f
46 (lambda (procedure arguments dummy1 dummy2 dummy3)
47 (macro-raise
48 (macro-make-nonempty-input-port-character-buffer-exception procedure arguments)))))
50 (implement-library-type-no-such-file-or-directory-exception)
52 (define-prim (##raise-no-such-file-or-directory-exception proc . args)
53 (##extract-procedure-and-arguments
54 proc
55 args
56 #f
57 #f
58 #f
59 (lambda (procedure arguments dummy1 dummy2 dummy3)
60 (macro-raise
61 (macro-make-no-such-file-or-directory-exception
62 procedure
63 arguments)))))
65 ;;;----------------------------------------------------------------------------
67 ;;; Define type checking procedures.
69 (define-fail-check-type settings
70 'settings)
72 (define-fail-check-type exact-integer-or-string-or-settings
73 'exact-integer-or-string-or-settings)
75 (define-fail-check-type string-or-ip-address
76 'string-or-ip-address)
78 ;;;----------------------------------------------------------------------------
80 ;;; Implementation of write environments.
82 (define-prim (##make-writeenv
83 style
84 port
85 readtable
86 marktable
87 force?
88 width
89 shift
90 close-parens
91 level
92 limit)
93 (macro-make-writeenv
94 style
95 port
96 readtable
97 marktable
98 force?
99 width
100 shift
101 close-parens
102 level
103 limit))
105 ;;;----------------------------------------------------------------------------
107 ;;; Implementation of read environments.
109 (define-prim (##make-readenv
110 port
111 readtable
112 wrapper
113 unwrapper
114 allow-script?)
115 (macro-make-readenv
116 port
117 readtable
118 wrapper
119 unwrapper
120 allow-script?
121 '()
122 #f
123 0))
125 (define-prim (##readenv-current-filepos re)
126 (##readenv-relative-filepos re 0))
128 (define-prim (##readenv-relative-filepos re offset)
129 (let* ((port
130 (macro-readenv-port re))
131 (line
132 (macro-character-port-rlines port))
133 (char-count
134 (##fixnum.- (##fixnum.+ (macro-character-port-rchars port)
135 (macro-character-port-rlo port))
136 offset))
137 (col
138 (##fixnum.- char-count
139 (macro-character-port-rcurline port))))
140 (##make-filepos line col char-count)))
142 ;;;----------------------------------------------------------------------------
144 ;;; Implementation of port settings.
146 (define-prim (##make-psettings
147 direction
148 allowed-settings
149 settings
150 fail
151 succeed)
152 (let ((psettings
153 (macro-make-psettings
154 direction
155 (macro-make-psettings-options
156 (macro-default-readtable)
157 (macro-default-char-encoding)
158 (macro-default-char-encoding-errors)
159 (macro-default-eol-encoding)
160 (macro-default-buffering)
161 (macro-default-permanent-close))
162 (macro-make-psettings-options
163 (macro-default-readtable)
164 (macro-default-char-encoding-errors)
165 (macro-default-char-encoding)
166 (macro-default-eol-encoding)
167 (macro-default-buffering)
168 (macro-default-permanent-close))
169 (macro-default-path)
170 (macro-default-init)
171 (macro-default-arguments)
172 (macro-default-environment)
173 (macro-default-directory)
174 (macro-default-append)
175 (macro-default-create)
176 (macro-default-truncate)
177 (macro-default-permissions)
178 (macro-default-output-width)
179 (macro-default-stdin-redir)
180 (macro-default-stdout-redir)
181 (macro-default-stderr-redir)
182 (macro-default-pseudo-term)
183 (macro-default-show-console)
184 (macro-default-server-address)
185 (macro-default-port-number)
186 (macro-default-socket-type)
187 (macro-default-coalesce)
188 (macro-default-keep-alive)
189 (macro-default-backlog)
190 (macro-default-reuse-address)
191 (macro-default-broadcast)
192 (macro-default-ignore-hidden))))
193 (##parse-psettings!
194 allowed-settings
195 settings
196 psettings
197 fail
198 succeed)))
200 (define-prim (##parse-psettings!
201 allowed-settings
202 settings
203 psettings
204 fail
205 succeed)
207 (define (error name)
208 (fail))
210 (define (error-improper-list)
211 (fail))
213 (define (direction value)
214 (cond ((##eq? value 'input)
215 (macro-direction-in))
216 ((##eq? value 'output)
217 (macro-direction-out))
218 ((##eq? value 'input-output)
219 (macro-direction-inout))
220 (else
221 #f)))
223 (define (readtable value)
224 (cond ((macro-readtable? value)
225 value)
226 (else
227 #f)))
229 (define (char-encoding value)
230 (cond ((##eq? value 'ASCII)
231 (macro-char-encoding-ASCII))
232 ((##eq? value 'ISO-8859-1)
233 (macro-char-encoding-ISO-8859-1))
234 ((##eq? value 'UTF-8)
235 (macro-char-encoding-UTF-8))
236 ((##eq? value 'UTF-16)
237 (macro-char-encoding-UTF-16))
238 ((##eq? value 'UTF-16LE)
239 (macro-char-encoding-UTF-16LE))
240 ((##eq? value 'UTF-16BE)
241 (macro-char-encoding-UTF-16BE))
242 ((##eq? value 'UTF)
243 (macro-char-encoding-UTF))
244 ((##eq? value 'UTF-fallback-ASCII)
245 (macro-char-encoding-UTF-fallback-ASCII))
246 ((##eq? value 'UTF-fallback-ISO-8859-1)
247 (macro-char-encoding-UTF-fallback-ISO-8859-1))
248 ((##eq? value 'UTF-fallback-UTF-8)
249 (macro-char-encoding-UTF-fallback-UTF-8))
250 ((##eq? value 'UTF-fallback-UTF-16)
251 (macro-char-encoding-UTF-fallback-UTF-16))
252 ((##eq? value 'UTF-fallback-UTF-16LE)
253 (macro-char-encoding-UTF-fallback-UTF-16LE))
254 ((##eq? value 'UTF-fallback-UTF-16BE)
255 (macro-char-encoding-UTF-fallback-UTF-16BE))
256 ((##eq? value 'UCS-2)
257 (macro-char-encoding-UCS-2))
258 ((##eq? value 'UCS-2LE)
259 (macro-char-encoding-UCS-2LE))
260 ((##eq? value 'UCS-2BE)
261 (macro-char-encoding-UCS-2BE))
262 ((##eq? value 'UCS-4)
263 (macro-char-encoding-UCS-4))
264 ((##eq? value 'UCS-4LE)
265 (macro-char-encoding-UCS-4LE))
266 ((##eq? value 'UCS-4BE)
267 (macro-char-encoding-UCS-4BE))
268 ;; ((##eq? value 'wchar)
269 ;; (macro-char-encoding-wchar))
270 ;; ((##eq? value 'native)
271 ;; (macro-char-encoding-native))
272 (else
273 #f)))
275 (define (char-encoding-errors value)
276 (cond ((##eq? value #t)
277 (macro-char-encoding-errors-on))
278 ((##eq? value #f)
279 (macro-char-encoding-errors-off))
280 (else
281 #f)))
283 (define (eol-encoding value)
284 (cond ((##eq? value 'lf)
285 (macro-eol-encoding-lf))
286 ((##eq? value 'cr)
287 (macro-eol-encoding-cr))
288 ((##eq? value 'cr-lf)
289 (macro-eol-encoding-crlf))
290 (else
291 #f)))
293 (define (buffering value)
294 (cond ((##eq? value #t)
295 (macro-full-buffering))
296 ((##eq? value 'line)
297 (macro-line-buffering))
298 ((##eq? value #f)
299 (macro-no-buffering))
300 (else
301 #f)))
303 (define (permanent-close value)
304 (cond ((##eq? value #t)
305 (macro-permanent-close))
306 ((##eq? value #f)
307 (macro-no-permanent-close))
308 (else
309 #f)))
311 (define (path value)
312 value)
314 (define (init value)
315 value)
317 (define (arguments value)
318 (##copy-string-list value))
320 (define (environment value)
321 (cond ((##not value)
322 value)
323 (else
324 (##copy-string-list value))))
326 (define (directory value)
327 value)
329 (define (append-flag value)
330 (cond ((##eq? (macro-psettings-direction psettings)
331 (macro-direction-in))
332 #f)
333 (value
334 (macro-append))
335 (else
336 (macro-no-append))))
338 (define (create-flag value)
339 (cond ((##eq? (macro-psettings-direction psettings)
340 (macro-direction-in))
341 #f)
342 ((##eq? value #f)
343 (macro-no-create))
344 ((##eq? value 'maybe)
345 (macro-maybe-create))
346 ((##eq? value #t)
347 (macro-create))
348 (else
349 #f)))
351 (define (truncate-flag value)
352 (cond ((##eq? (macro-psettings-direction psettings)
353 (macro-direction-in))
354 #f)
355 (value
356 (macro-truncate))
357 (else
358 (macro-no-truncate))))
360 (define (permissions value)
361 (cond ((##eq? (macro-psettings-direction psettings)
362 (macro-direction-in))
363 #f)
364 ((and (##fixnum? value)
365 (##not (##fixnum.< value 0))
366 (##fixnum.< value #o1000))
367 value)
368 (else
369 #f)))
371 (define (output-width value)
372 (cond ((##eq? (macro-psettings-direction psettings)
373 (macro-direction-in))
374 #f)
375 ((and (##fixnum? value)
376 (##fixnum.< 0 value))
377 value)
378 (else
379 #f)))
381 (define (stdin-redir value)
382 (cond ((##eq? value #t)
383 (macro-stdin-from-port))
384 ((##eq? value #f)
385 (macro-stdin-unchanged))
386 (else
387 #f)))
389 (define (stdout-redir value)
390 (cond ((##eq? value #t)
391 (macro-stdout-to-port))
392 ((##eq? value #f)
393 (macro-stdout-unchanged))
394 (else
395 #f)))
397 (define (stderr-redir value)
398 (cond ((##eq? value #t)
399 (macro-stderr-to-port))
400 ((##eq? value #f)
401 (macro-stderr-unchanged))
402 (else
403 #f)))
405 (define (pseudo-term value)
406 (cond ((##eq? value #t)
407 (macro-pseudo-term))
408 ((##eq? value #f)
409 (macro-no-pseudo-term))
410 (else
411 #f)))
413 (define (show-console value)
414 (cond ((##eq? value #t)
415 (macro-show-console))
416 ((##eq? value #f)
417 (macro-no-show-console))
418 (else
419 #f)))
421 (define (port-number value)
422 (cond ((and (##fixnum? value)
423 (##fixnum.<= 0 value)
424 (##fixnum.<= value 65535))
425 value)
426 (else
427 #f)))
429 (define (socket-type value)
430 (cond ((or (##eq? value 'TCP) (##eq? value 'tcp))
431 (macro-socket-type-TCP))
432 ((or (##eq? value 'UDP) (##eq? value 'udp))
433 (macro-socket-type-UDP))
434 ((or (##eq? value 'RAW) (##eq? value 'raw))
435 (macro-socket-type-RAW))
436 (else
437 #f)))
439 (define (coalesce value)
440 (cond ((##eq? value #t)
441 (macro-coalesce))
442 ((##eq? value #f)
443 (macro-no-coalesce))
444 (else
445 #f)))
447 (define (keep-alive value)
448 (cond ((##eq? value #t)
449 (macro-keep-alive))
450 ((##eq? value #f)
451 (macro-no-keep-alive))
452 (else
453 #f)))
455 (define (backlog value)
456 (if (and (##fixnum? value)
457 (##not (##fixnum.< value 0)))
458 value
459 #f))
461 (define (reuse-address value)
462 (cond ((##eq? value #t)
463 (macro-reuse-address))
464 ((##eq? value #f)
465 (macro-no-reuse-address))
466 (else
467 #f)))
469 (define (broadcast value)
470 (cond ((##eq? value #t)
471 (macro-broadcast))
472 ((##eq? value #f)
473 (macro-no-broadcast))
474 (else
475 #f)))
477 (define (ignore-hidden value)
478 (cond ((##eq? (macro-psettings-direction psettings)
479 (macro-direction-out))
480 #f)
481 ((##eq? value #t)
482 (macro-ignore-hidden))
483 ((##eq? value #f)
484 (macro-ignore-nothing))
485 ((##eq? value 'dot-and-dot-dot)
486 (macro-ignore-dot-and-dot-dot))
487 (else
488 #f)))
490 (let loop ((lst settings))
491 (macro-force-vars (lst)
492 (cond ((##pair? lst)
493 (let ((name (##car lst))
494 (rest1 (##cdr lst)))
495 (macro-force-vars (name rest1)
496 (if (and (##memq name allowed-settings)
497 (##pair? rest1))
499 (let ((value (##car rest1))
500 (rest2 (##cdr rest1)))
501 (macro-force-vars (value)
503 (cond ((##eq? name 'direction:)
504 (let ((x (direction value)))
505 (if x
506 (begin
507 (macro-psettings-direction-set!
508 psettings
509 x)
510 (loop rest2))
511 (error name))))
513 ((and (##eq? name 'input-readtable:)
514 (##not
515 (##eq?
516 (macro-psettings-direction psettings)
517 (macro-direction-out))))
518 (let ((x (readtable value)))
519 (if x
520 (begin
521 (macro-psettings-options-readtable-set!
522 (macro-psettings-roptions psettings)
523 x)
524 (loop rest2))
525 (error name))))
527 ((and (##eq? name 'output-readtable:)
528 (##not
529 (##eq?
530 (macro-psettings-direction psettings)
531 (macro-direction-in))))
532 (let ((x (readtable value)))
533 (if x
534 (begin
535 (macro-psettings-options-readtable-set!
536 (macro-psettings-woptions psettings)
537 x)
538 (loop rest2))
539 (error name))))
541 ((##eq? name 'readtable:)
542 (let ((x (readtable value)))
543 (if x
544 (begin
545 (macro-psettings-options-readtable-set!
546 (macro-psettings-roptions psettings)
547 x)
548 (macro-psettings-options-readtable-set!
549 (macro-psettings-woptions psettings)
550 x)
551 (loop rest2))
552 (error name))))
554 ((and (##eq? name 'input-char-encoding:)
555 (##not
556 (##eq?
557 (macro-psettings-direction psettings)
558 (macro-direction-out))))
559 (let ((x (char-encoding value)))
560 (if x
561 (begin
562 (macro-psettings-options-char-encoding-set!
563 (macro-psettings-roptions psettings)
564 x)
565 (loop rest2))
566 (error name))))
568 ((and (##eq? name 'output-char-encoding:)
569 (##not
570 (##eq?
571 (macro-psettings-direction psettings)
572 (macro-direction-in))))
573 (let ((x (char-encoding value)))
574 (if x
575 (begin
576 (macro-psettings-options-char-encoding-set!
577 (macro-psettings-woptions psettings)
578 x)
579 (loop rest2))
580 (error name))))
582 ((##eq? name 'char-encoding:)
583 (let ((x (char-encoding value)))
584 (if x
585 (begin
586 (macro-psettings-options-char-encoding-set!
587 (macro-psettings-roptions psettings)
588 x)
589 (macro-psettings-options-char-encoding-set!
590 (macro-psettings-woptions psettings)
591 x)
592 (loop rest2))
593 (error name))))
595 ((and (##eq? name 'input-char-encoding-errors:)
596 (##not
597 (##eq?
598 (macro-psettings-direction psettings)
599 (macro-direction-out))))
600 (let ((x (char-encoding-errors value)))
601 (if x
602 (begin
603 (macro-psettings-options-char-encoding-errors-set!
604 (macro-psettings-roptions psettings)
605 x)
606 (loop rest2))
607 (error name))))
609 ((and (##eq? name 'output-char-encoding-errors:)
610 (##not
611 (##eq?
612 (macro-psettings-direction psettings)
613 (macro-direction-in))))
614 (let ((x (char-encoding-errors value)))
615 (if x
616 (begin
617 (macro-psettings-options-char-encoding-errors-set!
618 (macro-psettings-woptions psettings)
619 x)
620 (loop rest2))
621 (error name))))
623 ((##eq? name 'char-encoding-errors:)
624 (let ((x (char-encoding-errors value)))
625 (if x
626 (begin
627 (macro-psettings-options-char-encoding-errors-set!
628 (macro-psettings-roptions psettings)
629 x)
630 (macro-psettings-options-char-encoding-errors-set!
631 (macro-psettings-woptions psettings)
632 x)
633 (loop rest2))
634 (error name))))
636 ((and (##eq? name 'input-eol-encoding:)
637 (##not
638 (##eq?
639 (macro-psettings-direction psettings)
640 (macro-direction-out))))
641 (let ((x (eol-encoding value)))
642 (if x
643 (begin
644 (macro-psettings-options-eol-encoding-set!
645 (macro-psettings-roptions psettings)
646 x)
647 (loop rest2))
648 (error name))))
650 ((and (##eq? name 'output-eol-encoding:)
651 (##not
652 (##eq?
653 (macro-psettings-direction psettings)
654 (macro-direction-in))))
655 (let ((x (eol-encoding value)))
656 (if x
657 (begin
658 (macro-psettings-options-eol-encoding-set!
659 (macro-psettings-woptions psettings)
660 x)
661 (loop rest2))
662 (error name))))
664 ((##eq? name 'eol-encoding:)
665 (let ((x (eol-encoding value)))
666 (if x
667 (begin
668 (macro-psettings-options-eol-encoding-set!
669 (macro-psettings-roptions psettings)
670 x)
671 (macro-psettings-options-eol-encoding-set!
672 (macro-psettings-woptions psettings)
673 x)
674 (loop rest2))
675 (error name))))
677 ((and (##eq? name 'input-buffering:)
678 (##not
679 (##eq?
680 (macro-psettings-direction psettings)
681 (macro-direction-out))))
682 (let ((x (buffering value)))
683 (if x
684 (begin
685 (macro-psettings-options-buffering-set!
686 (macro-psettings-roptions psettings)
687 x)
688 (loop rest2))
689 (error name))))
691 ((and (##eq? name 'output-buffering:)
692 (##not
693 (##eq?
694 (macro-psettings-direction psettings)
695 (macro-direction-in))))
696 (let ((x (buffering value)))
697 (if x
698 (begin
699 (macro-psettings-options-buffering-set!
700 (macro-psettings-woptions psettings)
701 x)
702 (loop rest2))
703 (error name))))
705 ((##eq? name 'buffering:)
706 (let ((x (buffering value)))
707 (if x
708 (begin
709 (macro-psettings-options-buffering-set!
710 (macro-psettings-roptions psettings)
711 x)
712 (macro-psettings-options-buffering-set!
713 (macro-psettings-woptions psettings)
714 x)
715 (loop rest2))
716 (error name))))
718 ((##eq? name 'permanent-close:)
719 (let ((x (permanent-close value)))
720 (if x
721 (begin
722 (macro-psettings-options-permanent-close-set!
723 (macro-psettings-roptions psettings)
724 x)
725 (macro-psettings-options-permanent-close-set!
726 (macro-psettings-woptions psettings)
727 x)
728 (loop rest2))
729 (error name))))
731 ((##eq? name 'path:)
732 (let ((x (path value)))
733 (if x
734 (begin
735 (macro-psettings-path-set!
736 psettings
737 x)
738 (loop rest2))
739 (error name))))
741 ((##eq? name 'init:)
742 (let ((x (init value)))
743 (if x
744 (begin
745 (macro-psettings-init-set!
746 psettings
747 x)
748 (loop rest2))
749 (error name))))
751 ((##eq? name 'arguments:)
752 (let ((x (arguments value)))
753 (if (##fixnum? x)
754 (error name)
755 (begin
756 (macro-psettings-arguments-set!
757 psettings
758 x)
759 (loop rest2)))))
761 ((##eq? name 'environment:)
762 (let ((x (environment value)))
763 (if (##fixnum? x)
764 (error name)
765 (begin
766 (macro-psettings-environment-set!
767 psettings
768 x)
769 (loop rest2)))))
771 ((##eq? name 'directory:)
772 (let ((x (directory value)))
773 (if (##fixnum? x)
774 (error name)
775 (begin
776 (macro-psettings-directory-set!
777 psettings
778 x)
779 (loop rest2)))))
781 ((##eq? name 'append:)
782 (let ((x (append-flag value)))
783 (if x
784 (begin
785 (macro-psettings-append-set!
786 psettings
787 x)
788 (loop rest2))
789 (error name))))
791 ((##eq? name 'create:)
792 (let ((x (create-flag value)))
793 (if x
794 (begin
795 (macro-psettings-create-set!
796 psettings
797 x)
798 (loop rest2))
799 (error name))))
801 ((##eq? name 'truncate:)
802 (let ((x (truncate-flag value)))
803 (if x
804 (begin
805 (macro-psettings-truncate-set!
806 psettings
807 x)
808 (loop rest2))
809 (error name))))
811 ((##eq? name 'permissions:)
812 (let ((x (permissions value)))
813 (if x
814 (begin
815 (macro-psettings-permissions-set!
816 psettings
817 x)
818 (loop rest2))
819 (error name))))
821 ((##eq? name 'output-width:)
822 (let ((x (output-width value)))
823 (if x
824 (begin
825 (macro-psettings-output-width-set!
826 psettings
827 x)
828 (loop rest2))
829 (error name))))
831 ((##eq? name 'stdin-redirection:)
832 (let ((x (stdin-redir value)))
833 (if x
834 (begin
835 (macro-psettings-stdin-redir-set!
836 psettings
837 x)
838 (loop rest2))
839 (error name))))
841 ((##eq? name 'stdout-redirection:)
842 (let ((x (stdout-redir value)))
843 (if x
844 (begin
845 (macro-psettings-stdout-redir-set!
846 psettings
847 x)
848 (loop rest2))
849 (error name))))
851 ((##eq? name 'stderr-redirection:)
852 (let ((x (stderr-redir value)))
853 (if x
854 (begin
855 (macro-psettings-stderr-redir-set!
856 psettings
857 x)
858 (loop rest2))
859 (error name))))
861 ((##eq? name 'pseudo-terminal:)
862 (let ((x (pseudo-term value)))
863 (if x
864 (begin
865 (macro-psettings-pseudo-term-set!
866 psettings
867 x)
868 (loop rest2))
869 (error name))))
871 ((##eq? name 'show-console:)
872 (let ((x (show-console value)))
873 (if x
874 (begin
875 (macro-psettings-show-console-set!
876 psettings
877 x)
878 (loop rest2))
879 (error name))))
881 ((##eq? name 'server-address:)
882 (cond ((##string? value)
883 (let ((address-and-port-number
884 (##string->address-and-port-number
885 value
886 (macro-default-server-address)
887 #f)))
888 (if address-and-port-number
889 (let ((address
890 (##car
891 address-and-port-number))
892 (port-number
893 (##cdr
894 address-and-port-number)))
895 (macro-psettings-server-address-set!
896 psettings
897 address)
898 (if port-number
899 (macro-psettings-port-number-set!
900 psettings
901 port-number))
902 (loop rest2))
903 (error name))))
904 ((##ip-address? value)
905 (macro-psettings-server-address-set!
906 psettings
907 value)
908 (loop rest2))
909 (else
910 (error name))))
912 ((##eq? name 'port-number:)
913 (let ((x (port-number value)))
914 (if x
915 (begin
916 (macro-psettings-port-number-set!
917 psettings
918 x)
919 (loop rest2))
920 (error name))))
922 ((##eq? name 'socket-type:)
923 (let ((x (socket-type value)))
924 (if x
925 (begin
926 (macro-psettings-socket-type-set!
927 psettings
928 x)
929 (loop rest2))
930 (error name))))
932 ((##eq? name 'coalesce:)
933 (let ((x (coalesce value)))
934 (if x
935 (begin
936 (macro-psettings-coalesce-set!
937 psettings
938 x)
939 (loop rest2))
940 (error name))))
942 ((##eq? name 'keep-alive:)
943 (let ((x (keep-alive value)))
944 (if x
945 (begin
946 (macro-psettings-keep-alive-set!
947 psettings
948 x)
949 (loop rest2))
950 (error name))))
952 ((##eq? name 'backlog:)
953 (let ((x (backlog value)))
954 (if x
955 (begin
956 (macro-psettings-backlog-set!
957 psettings
958 x)
959 (loop rest2))
960 (error name))))
962 ((##eq? name 'reuse-address:)
963 (let ((x (reuse-address value)))
964 (if x
965 (begin
966 (macro-psettings-reuse-address-set!
967 psettings
968 x)
969 (loop rest2))
970 (error name))))
972 ((##eq? name 'broadcast:)
973 (let ((x (broadcast value)))
974 (if x
975 (begin
976 (macro-psettings-broadcast-set!
977 psettings
978 x)
979 (loop rest2))
980 (error name))))
982 ((##eq? name 'ignore-hidden:)
983 (let ((x (ignore-hidden value)))
984 (if x
985 (begin
986 (macro-psettings-ignore-hidden-set!
987 psettings
988 x)
989 (loop rest2))
990 (error name))))
992 (else
993 (error name)))))
995 (error name)))))
997 ((##null? lst)
998 (succeed psettings))
1000 (else
1001 (error-improper-list))))))
1003 (##define-macro (macro-stream-options-output-shift) 32768)
1005 (define-prim (##psettings->roptions psettings default-options)
1006 (##psettings-options->options
1007 (macro-psettings-roptions psettings)
1008 (##fixnum.modulo default-options (macro-stream-options-output-shift))))
1010 (define-prim (##psettings->woptions psettings default-options)
1011 (##psettings-options->options
1012 (macro-psettings-woptions psettings)
1013 (##fixnum.quotient default-options (macro-stream-options-output-shift))))
1015 (define-prim (##psettings->input-readtable psettings)
1016 (or (macro-psettings-options-readtable
1017 (macro-psettings-roptions psettings))
1018 (##current-readtable)))
1020 (define-prim (##psettings->output-readtable psettings)
1021 (or (macro-psettings-options-readtable
1022 (macro-psettings-woptions psettings))
1023 (##current-readtable)))
1025 (define-prim (##psettings-options->options options default-options)
1026 (let ((permanent-close
1027 (macro-psettings-options-permanent-close options))
1028 (buffering
1029 (macro-psettings-options-buffering options))
1030 (eol-encoding
1031 (macro-psettings-options-eol-encoding options))
1032 (char-encoding
1033 (macro-psettings-options-char-encoding options))
1034 (char-encoding-errors
1035 (macro-psettings-options-char-encoding-errors options)))
1036 (##fixnum.+
1037 (##fixnum.+
1038 (##fixnum.* (macro-char-encoding-shift)
1039 (if (##fixnum.= char-encoding (macro-default-char-encoding))
1040 (##fixnum.modulo
1041 (##fixnum.quotient default-options
1042 (macro-char-encoding-shift))
1043 (macro-char-encoding-range))
1044 char-encoding))
1045 (##fixnum.* (macro-char-encoding-errors-shift)
1046 (if (##fixnum.= char-encoding-errors (macro-default-char-encoding-errors))
1047 (##fixnum.modulo
1048 (##fixnum.quotient default-options
1049 (macro-char-encoding-errors-shift))
1050 (macro-char-encoding-errors-range))
1051 char-encoding-errors))
1052 (##fixnum.+
1053 (##fixnum.+
1054 (##fixnum.* (macro-eol-encoding-shift)
1055 (if (##fixnum.= eol-encoding (macro-default-eol-encoding))
1056 (##fixnum.modulo
1057 (##fixnum.quotient default-options
1058 (macro-eol-encoding-shift))
1059 (macro-eol-encoding-range))
1060 eol-encoding))
1061 (##fixnum.+
1062 (##fixnum.* (macro-open-state-shift)
1063 (##fixnum.modulo
1064 (##fixnum.quotient default-options
1065 (macro-open-state-shift))
1066 (macro-open-state-range)))
1067 (##fixnum.+
1068 (##fixnum.* (macro-permanent-close-shift)
1069 permanent-close)
1070 (##fixnum.* (macro-buffering-shift)
1071 (if (##fixnum.= buffering (macro-default-buffering))
1072 (##fixnum.modulo
1073 (##fixnum.quotient default-options
1074 (macro-buffering-shift))
1075 (macro-buffering-range))
1076 buffering))))))))))
1078 (define-prim (##psettings->device-flags psettings)
1079 (let ((direction
1080 (macro-psettings-direction psettings))
1081 (append
1082 (macro-psettings-append psettings))
1083 (create
1084 (macro-psettings-create psettings))
1085 (truncate
1086 (macro-psettings-truncate psettings)))
1087 (##fixnum.+
1088 (##fixnum.* (macro-direction-shift)
1089 direction)
1090 (##fixnum.+
1091 (##fixnum.* (macro-append-shift)
1092 (if (##not (##fixnum.= append (macro-default-append)))
1093 append
1094 (macro-no-append)))
1095 (##fixnum.+
1096 (##fixnum.* (macro-create-shift)
1097 (cond ((##not (##fixnum.= create (macro-default-create)))
1098 create)
1099 ((##fixnum.= direction (macro-direction-out))
1100 (macro-maybe-create))
1101 (else
1102 (macro-no-create))))
1103 (##fixnum.* (macro-truncate-shift)
1104 (cond ((##not (##fixnum.= truncate (macro-default-truncate)))
1105 truncate)
1106 ((##fixnum.= direction (macro-direction-out))
1107 (if (##fixnum.= append (macro-append))
1108 (macro-no-truncate)
1109 (macro-truncate)))
1110 (else
1111 (macro-no-truncate)))))))))
1113 (define-prim (##psettings->permissions psettings default-permissions)
1114 (let ((permissions (macro-psettings-permissions psettings)))
1115 (if (##not (##fixnum.= permissions (macro-default-permissions)))
1116 permissions
1117 default-permissions)))
1119 (define-prim (##psettings->output-width psettings)
1120 (let ((output-width (macro-psettings-output-width psettings)))
1121 (if (##not (##fixnum.= output-width (macro-default-output-width)))
1122 output-width
1123 80)))
1125 ;;;----------------------------------------------------------------------------
1127 ;;; Implementation of port type checking.
1129 (define-prim (##port? obj)
1130 (macro-port? obj))
1132 (define-prim (port? obj)
1133 (macro-force-vars (obj)
1134 (macro-port? obj)))
1136 (define-prim (##input-port? obj)
1137 (macro-input-port? obj))
1139 (define-prim (input-port? obj)
1140 (macro-force-vars (obj)
1141 (macro-input-port? obj)))
1143 (define-prim (##output-port? obj)
1144 (macro-output-port? obj))
1146 (define-prim (output-port? obj)
1147 (macro-force-vars (obj)
1148 (macro-output-port? obj)))
1150 (implement-check-type-port)
1151 (define-fail-check-type input-port 'input-port)
1152 (define-fail-check-type output-port 'output-port)
1153 (define-fail-check-type character-input-port 'character-input-port)
1154 (define-fail-check-type character-output-port 'character-output-port)
1155 (define-fail-check-type byte-port 'byte-port)
1156 (define-fail-check-type byte-input-port 'byte-input-port)
1157 (define-fail-check-type byte-output-port 'byte-output-port)
1158 (define-fail-check-type device-input-port 'device-input-port)
1159 (define-fail-check-type device-output-port 'device-output-port)
1161 ;;;----------------------------------------------------------------------------
1163 ;;; I/O condition variables.
1165 (define-prim (##make-io-condvar name for-writing?)
1166 (let ((cv (##make-condvar name)))
1167 (macro-btq-owner-set! cv (if for-writing? 2 0))
1168 cv))
1170 (define-prim (##io-condvar? cv)
1171 (##fixnum? (macro-btq-owner cv)))
1173 (define-prim (##io-condvar-for-writing? cv)
1174 (##not (##fixnum.= 0 (##fixnum.bitwise-and 2 (macro-btq-owner cv)))))
1176 (define-prim (##io-condvar-port cv)
1177 (macro-condvar-specific cv))
1179 (define-prim (##io-condvar-port-set! cv port)
1180 (macro-condvar-specific-set! cv port))
1182 ;;;----------------------------------------------------------------------------
1184 ;;; Implementation of dummy ports.
1186 (define-prim (##make-dummy-port)
1187 (let* ((mutex
1188 #f)
1189 (rkind
1190 (macro-object-kind))
1191 (wkind
1192 (macro-object-kind))
1193 (roptions
1194 0)
1195 (rtimeout
1196 #t)
1197 (rtimeout-thunk
1198 #f)
1199 (woptions
1200 0)
1201 (wtimeout
1202 #t)
1203 (wtimeout-thunk
1204 #f))
1206 (define (name port)
1207 'dummy)
1209 (define (read-datum port re)
1210 #!eof)
1212 (define (write-datum port obj we)
1213 (##void))
1215 (define (newline port)
1216 (##void))
1218 (define (force-output port level prim arg1 arg2 arg3 arg4)
1219 (##void))
1221 (define (close port prim arg1)
1222 (##void))
1224 (define (set-rtimeout port timeout thunk)
1225 (##void))
1227 (define (set-wtimeout port timeout thunk)
1228 (##void))
1230 (macro-make-port
1231 mutex
1232 rkind
1233 wkind
1234 name
1235 read-datum
1236 write-datum
1237 newline
1238 force-output
1239 close
1240 roptions
1241 rtimeout
1242 rtimeout-thunk
1243 set-rtimeout
1244 woptions
1245 wtimeout
1246 wtimeout-thunk
1247 set-wtimeout)))
1249 (define (open-dummy)
1250 (##make-dummy-port))
1252 ;;;----------------------------------------------------------------------------
1254 ;;; Implementation of device ports.
1256 (define-prim (##make-device-port device-name rdevice wdevice psettings)
1258 (define char-buf-len 512) ;; character buffer length
1259 (define byte-buf-len 1024) ;; byte buffer length
1261 (let* ((mutex
1262 (macro-make-port-mutex))
1263 (rkind
1264 (if rdevice
1265 (##os-device-kind rdevice)
1266 (macro-none-kind)))
1267 (wkind
1268 (if wdevice
1269 (##os-device-kind wdevice)
1270 (macro-none-kind)))
1271 (roptions
1272 (if (##fixnum.= rkind (macro-none-kind))
1273 0
1274 (##psettings->roptions
1275 psettings
1276 (##os-device-stream-default-options rdevice))))
1277 (rtimeout
1278 #t)
1279 (rtimeout-thunk
1280 #f)
1281 (woptions
1282 (if (##fixnum.= wkind (macro-none-kind))
1283 0
1284 (##psettings->woptions
1285 psettings
1286 (##os-device-stream-default-options wdevice))))
1287 (wtimeout
1288 #t)
1289 (wtimeout-thunk
1290 #f)
1291 (char-rbuf
1292 (and (##not (##fixnum.= rkind (macro-none-kind)))
1293 (##make-string (if (macro-unbuffered? roptions)
1294 1
1295 char-buf-len))))
1296 (char-rlo
1297 0)
1298 (char-rhi
1299 0)
1300 (char-rchars
1301 0)
1302 (char-rlines
1303 0)
1304 (char-rcurline
1305 0)
1306 (char-rbuf-fill
1307 ##char-rbuf-fill)
1308 (char-peek-eof?
1309 #f)
1310 (char-wbuf
1311 (and (##not (##fixnum.= wkind (macro-none-kind)))
1312 (##make-string (if (macro-unbuffered? woptions)
1313 1
1314 char-buf-len))))
1315 (char-wlo
1316 0)
1317 (char-whi
1318 0)
1319 (char-wchars
1320 0)
1321 (char-wlines
1322 0)
1323 (char-wcurline
1324 0)
1325 (char-wbuf-drain
1326 ##char-wbuf-drain)
1327 (input-readtable
1328 (##psettings->input-readtable psettings))
1329 (output-readtable
1330 (##psettings->output-readtable psettings))
1331 (byte-rbuf
1332 (and (##not (##fixnum.= rkind (macro-none-kind)))
1333 (##make-u8vector byte-buf-len)))
1334 (byte-rlo
1335 0)
1336 (byte-rhi
1337 0)
1338 (byte-rbuf-fill
1339 ##byte-rbuf-fill)
1340 (byte-wbuf
1341 (and (##not (##fixnum.= wkind (macro-none-kind)))
1342 (##make-u8vector byte-buf-len)))
1343 (byte-wlo
1344 0)
1345 (byte-whi
1346 0)
1347 (byte-wbuf-drain
1348 ##byte-wbuf-drain)
1349 (rdevice-condvar
1350 (and (##not (##fixnum.= rkind (macro-none-kind)))
1351 (##make-rdevice-condvar rdevice)))
1352 (wdevice-condvar
1353 (and (##not (##fixnum.= wkind (macro-none-kind)))
1354 (##make-wdevice-condvar wdevice))))
1356 (define (name port)
1358 ;; It is assumed that the thread **does not** have exclusive
1359 ;; access to the port.
1361 (##declare (not interrupts-enabled))
1363 (macro-device-port-name port))
1365 (define (read-datum port re)
1367 ;; It is assumed that the thread **does not** have exclusive
1368 ;; access to the port.
1370 (##declare (not interrupts-enabled))
1372 (##read-datum-or-eof re))
1374 (define (write-datum port obj we)
1376 ;; It is assumed that the thread **does not** have exclusive
1377 ;; access to the port.
1379 (##declare (not interrupts-enabled))
1381 (##wr we obj))
1383 (define (newline port)
1385 ;; It is assumed that the thread **does not** have exclusive
1386 ;; access to the port.
1388 (##declare (not interrupts-enabled))
1390 (##write-char #\newline port))
1392 (define (force-output port level prim arg1 arg2 arg3 arg4)
1394 ;; It is assumed that the thread **does not** have exclusive
1395 ;; access to the port.
1397 (##declare (not interrupts-enabled))
1399 (macro-port-mutex-lock! port) ;; get exclusive access to port
1401 (let ((code (force-output-aux port level #t)))
1402 (macro-port-mutex-unlock! port)
1403 (if (##fixnum.< code 0)
1404 (##raise-os-exception #f code prim arg1 arg2 arg3 arg4)
1405 (##void))))
1407 (define (force-output-aux port level block?)
1409 ;; It is assumed that the thread has exclusive access to the port.
1411 (##declare (not interrupts-enabled))
1413 (let ((code1 (drain-output port)))
1414 (if (##fixnum? code1)
1415 code1
1416 (let* ((wdevice-condvar (macro-device-port-wdevice-condvar port))
1417 (wdevice (macro-condvar-name wdevice-condvar))
1418 (code2 (##os-device-force-output wdevice level)))
1419 (cond ((##fixnum.= code2 ##err-code-EINTR)
1421 ;; the force was interrupted, so try again
1423 (force-output-aux port level block?))
1425 ((and block?
1426 (##fixnum.= code2 ##err-code-EAGAIN))
1428 ;; the force would block, so wait and then try again
1430 (macro-port-mutex-unlock! port)
1431 (let ((continue?
1432 (or (##wait-for-io!
1433 (macro-device-port-wdevice-condvar port)
1434 (macro-port-wtimeout port))
1435 ((macro-port-wtimeout-thunk port)))))
1436 (macro-port-mutex-lock! port) ;; regain access to port
1437 (if continue?
1438 (force-output-aux port level block?)
1439 code2)))
1441 (else
1442 code2))))))
1444 (define (drain-output port)
1446 ;; It is assumed that the thread has exclusive access to the port.
1448 (##declare (not interrupts-enabled))
1450 (let ((code ((macro-character-port-wbuf-drain port) port)))
1451 (if (##fixnum? code)
1452 code
1453 ((macro-byte-port-wbuf-drain port) port))))
1455 (define (close port prim arg1)
1457 ;; It is assumed that the thread **does not** have exclusive
1458 ;; access to the port.
1460 (##declare (not interrupts-enabled))
1462 (macro-port-mutex-lock! port) ;; get exclusive access to port
1464 (let ((result (close-aux1 port prim)))
1465 (macro-port-mutex-unlock! port)
1466 (if (##fixnum? result)
1467 (##raise-os-exception #f result prim arg1)
1468 result)))
1470 (define (close-aux1 port prim)
1472 ;; It is assumed that the thread has exclusive access to the port.
1474 (##declare (not interrupts-enabled))
1476 (if (or (##fixnum.= (macro-port-wkind port) (macro-none-kind))
1477 (##eq? prim close-input-port))
1478 (close-aux2 port prim)
1479 (let ((code (force-output-aux port 0 #f)))
1480 (if (and (##fixnum.< code 0)
1481 (##not (##fixnum.= code ##err-code-EAGAIN)))
1483 code
1485 ;; The close operation may have failed to force the output.
1486 ;; However the close operation is not allowed to block, so
1487 ;; we just continue and close the device. The user can make
1488 ;; sure that the output is forced by calling force-output
1489 ;; (which can block) before calling close-port.
1491 (close-aux2 port prim)))))
1493 (define (close-aux2 port prim)
1495 ;; It is assumed that the thread has exclusive access to the port.
1497 (##declare (not interrupts-enabled))
1499 (##close-device
1500 port
1501 (macro-device-port-rdevice-condvar port)
1502 (macro-device-port-wdevice-condvar port)
1503 prim))
1505 (define (set-rtimeout port timeout thunk)
1507 ;; It is assumed that the thread **does not** have exclusive
1508 ;; access to the port.
1510 (##declare (not interrupts-enabled))
1512 (macro-port-mutex-lock! port) ;; get exclusive access to port
1514 (macro-port-rtimeout-set! port timeout)
1515 (macro-port-rtimeout-thunk-set! port thunk)
1516 (##condvar-signal-no-reschedule!
1517 (macro-device-port-rdevice-condvar port)
1518 #t)
1519 (macro-port-mutex-unlock! port)
1520 (##void))
1522 (define (set-wtimeout port timeout thunk)
1524 ;; It is assumed that the thread **does not** have exclusive
1525 ;; access to the port.
1527 (##declare (not interrupts-enabled))
1529 (macro-port-mutex-lock! port) ;; get exclusive access to port
1531 (macro-port-wtimeout-set! port timeout)
1532 (macro-port-wtimeout-thunk-set! port thunk)
1533 (##condvar-signal-no-reschedule!
1534 (macro-device-port-wdevice-condvar port)
1535 #t)
1536 (macro-port-mutex-unlock! port)
1537 (##void))
1539 (define (output-width port)
1541 ;; It is assumed that the thread **does not** have exclusive
1542 ;; access to the port.
1544 (##declare (not interrupts-enabled))
1546 (macro-port-mutex-lock! port) ;; get exclusive access to port
1548 (let* ((wdevice-condvar (macro-device-port-wdevice-condvar port))
1549 (wdevice (macro-condvar-name wdevice-condvar))
1550 (result (##os-device-stream-width wdevice)))
1551 (macro-port-mutex-unlock! port)
1552 (if (##fixnum.< result 0)
1553 (##raise-os-exception #f result output-port-width port)
1554 result)))
1556 (let ((port
1557 (macro-make-device-port
1558 mutex
1559 rkind
1560 wkind
1561 name
1562 read-datum
1563 write-datum
1564 newline
1565 force-output
1566 close
1567 roptions
1568 rtimeout
1569 rtimeout-thunk
1570 set-rtimeout
1571 woptions
1572 wtimeout
1573 wtimeout-thunk
1574 set-wtimeout
1575 char-rbuf
1576 char-rlo
1577 char-rhi
1578 char-rchars
1579 char-rlines
1580 char-rcurline
1581 char-rbuf-fill
1582 char-peek-eof?
1583 char-wbuf
1584 char-wlo
1585 char-whi
1586 char-wchars
1587 char-wlines
1588 char-wcurline
1589 char-wbuf-drain
1590 input-readtable
1591 output-readtable
1592 output-width
1593 byte-rbuf
1594 byte-rlo
1595 byte-rhi
1596 byte-rbuf-fill
1597 byte-wbuf
1598 byte-wlo
1599 byte-whi
1600 byte-wbuf-drain
1601 rdevice-condvar
1602 wdevice-condvar
1603 device-name)))
1604 (if rdevice-condvar
1605 (##io-condvar-port-set! rdevice-condvar port))
1606 (if wdevice-condvar
1607 (##io-condvar-port-set! wdevice-condvar port))
1608 port)))
1610 (define-prim (##make-rdevice-condvar rdevice)
1611 (##make-io-condvar rdevice #f))
1613 (define-prim (##make-wdevice-condvar wdevice)
1614 (##make-io-condvar wdevice #t))
1616 (define-prim (##make-device-port-from-single-device
1617 device-name
1618 device
1619 psettings)
1620 (let ((direction (macro-psettings-direction psettings)))
1621 (cond ((##fixnum.= direction (macro-direction-in))
1622 (##make-device-port device-name
1623 device
1624 #f
1625 psettings))
1626 ((##fixnum.= direction (macro-direction-out))
1627 (##make-device-port device-name
1628 #f
1629 device
1630 psettings))
1631 (else
1632 (##make-device-port device-name
1633 device
1634 device
1635 psettings)))))
1637 (define-prim (##close-device port rdevice-condvar wdevice-condvar prim)
1639 (##declare (not interrupts-enabled))
1641 (let ((rdevice
1642 (if (##fixnum.= (macro-port-rkind port) (macro-none-kind))
1643 #f
1644 (macro-condvar-name rdevice-condvar)))
1645 (wdevice
1646 (if (##fixnum.= (macro-port-wkind port) (macro-none-kind))
1647 #f
1648 (macro-condvar-name wdevice-condvar))))
1649 (if (and (##eq? rdevice wdevice)
1650 (##eq? prim close-port))
1651 (let ((code1
1652 (##os-device-close rdevice (macro-direction-inout))))
1653 (if (##fixnum.< code1 0)
1654 code1
1655 (##void)))
1656 (let ((code2
1657 (if (and rdevice
1658 (##not (##eq? prim close-output-port)))
1659 (##os-device-close rdevice (macro-direction-in))
1660 0)))
1661 (if (##fixnum.< code2 0)
1662 code2
1663 (let ((code3
1664 (if (and wdevice
1665 (##not (##eq? prim close-input-port)))
1666 (##os-device-close wdevice (macro-direction-out))
1667 0)))
1668 (if (##fixnum.< code3 0)
1669 code3
1670 (##void))))))))
1672 (define-prim (##input-port-byte-position
1673 port
1674 #!optional
1675 (position (macro-absent-obj))
1676 (whence (macro-absent-obj)))
1677 (let loop ()
1678 (let ((result
1679 (if (##eq? position (macro-absent-obj))
1680 (##os-device-stream-seek
1681 (macro-condvar-name (macro-device-port-rdevice-condvar port))
1682 0
1683 1)
1684 (begin
1685 (##flush-input-buffering port)
1686 (##os-device-stream-seek
1687 (macro-condvar-name (macro-device-port-rdevice-condvar port))
1688 position
1689 (if (##eq? whence (macro-absent-obj)) 0 whence))))))
1690 (if (and (##fixnum? result)
1691 (##fixnum.< result 0))
1692 (if (or (##fixnum.= result ##err-code-EINTR)
1693 (##fixnum.= result ##err-code-EAGAIN))
1694 (loop)
1695 (##raise-os-exception
1696 #f
1697 result
1698 input-port-byte-position
1699 port
1700 position
1701 whence))
1702 result))))
1704 (define-prim (input-port-byte-position
1705 port
1706 #!optional
1707 (position (macro-absent-obj))
1708 (whence (macro-absent-obj)))
1709 (macro-force-vars (port position whence)
1710 (macro-check-device-input-port
1711 port
1712 1
1713 (input-port-byte-position port position whence)
1714 (cond ((##eq? position (macro-absent-obj))
1715 (##input-port-byte-position port))
1716 ((##not (macro-exact-int? position))
1717 (##fail-check-exact-integer 2 input-port-byte-position port position whence))
1718 ((##eq? whence (macro-absent-obj))
1719 (##input-port-byte-position port position))
1720 (else
1721 (macro-check-index-range-incl
1722 whence
1723 3
1724 0
1725 2
1726 (input-port-byte-position port position whence)
1727 (##input-port-byte-position port position whence)))))))
1729 (define-prim (##output-port-byte-position
1730 port
1731 #!optional
1732 (position (macro-absent-obj))
1733 (whence (macro-absent-obj)))
1734 (let loop ()
1735 (let ((result
1736 (if (##eq? position (macro-absent-obj))
1737 (##os-device-stream-seek
1738 (macro-condvar-name (macro-device-port-wdevice-condvar port))
1739 0
1740 1)
1741 (begin
1742 (##force-output port)
1743 (##os-device-stream-seek
1744 (macro-condvar-name (macro-device-port-wdevice-condvar port))
1745 position
1746 (if (##eq? whence (macro-absent-obj)) 0 whence))))))
1747 (if (and (##fixnum? result)
1748 (##fixnum.< result 0))
1749 (if (or (##fixnum.= result ##err-code-EINTR)
1750 (##fixnum.= result ##err-code-EAGAIN))
1751 (loop)
1752 (##raise-os-exception
1753 #f
1754 result
1755 output-port-byte-position
1756 port
1757 position
1758 whence))
1759 result))))
1761 (define-prim (output-port-byte-position
1762 port
1763 #!optional
1764 (position (macro-absent-obj))
1765 (whence (macro-absent-obj)))
1766 (macro-force-vars (port position whence)
1767 (macro-check-device-output-port
1768 port
1769 1
1770 (output-port-byte-position port position whence)
1771 (cond ((##eq? position (macro-absent-obj))
1772 (##output-port-byte-position port))
1773 ((##not (macro-exact-int? position))
1774 (##fail-check-exact-integer 2 output-port-byte-position port position whence))
1775 ((##eq? whence (macro-absent-obj))
1776 (##output-port-byte-position port position))
1777 (else
1778 (macro-check-index-range-incl
1779 whence
1780 3
1781 0
1782 2
1783 (output-port-byte-position port position whence)
1784 (##output-port-byte-position port position whence)))))))
1786 (define-prim (##device-port-wait-for-input! port)
1788 ;; TODO: generalize this to all other types of ports.
1790 ;; The thread will wait until there is data available to read on the
1791 ;; port's device or the port's timeout is reached. The value #f is
1792 ;; returned when the timeout is reached. The value #t is returned
1793 ;; when there is data available to read on the port's device or the
1794 ;; thread was interrupted (for example with thread-interrupt!).
1796 ;; It is assumed that the thread **does not** have exclusive
1797 ;; access to the port.
1799 (##declare (not interrupts-enabled))
1801 (##wait-for-io!
1802 (macro-device-port-rdevice-condvar port)
1803 (macro-port-rtimeout port)))
1805 ;;;----------------------------------------------------------------------------
1807 (define-prim (##char-rbuf-fill port want block?)
1809 ;; port is the character input-port
1810 ;; want is the number of characters that the caller wants (#f = max)
1811 ;; block? is a boolean indicating whether it is OK for the thread to block
1813 ;; This procedure returns one of the following values:
1814 ;; - #t if characters were added to the char buffer,
1815 ;; - #f if no character could be added to the char buffer (because
1816 ;; end-of-file was reached),
1817 ;; - fixnum indicating an error code (in particular, only if block?
1818 ;; is false or there was a read timeout and the timeout thunk
1819 ;; returned #f, ##err-code-EAGAIN is returned to indicate that no
1820 ;; character was currently available).
1822 ;; It is assumed that the thread has exclusive access to the port.
1824 (##declare (not interrupts-enabled))
1826 (let loop ()
1828 ;; keep track of number of characters read
1830 (macro-character-port-rchars-set!
1831 port
1832 (##fixnum.+ (macro-character-port-rchars port)
1833 (macro-character-port-rhi port)))
1835 (macro-character-port-rlo-set! port 0)
1836 (macro-character-port-rhi-set! port 0)
1838 ;; convert bytes from the byte buffer into characters in the char buffer
1840 (let* ((want
1841 (if (macro-unbuffered? (macro-port-roptions port))
1842 want
1843 #f))
1844 (code1
1845 (##os-port-decode-chars! port want #f)))
1847 (cond ((##not (##fixnum.= code1 0))
1849 ;; an error occurred, return the error code to caller
1851 code1)
1853 ((##fixnum.< (macro-character-port-rlo port)
1854 (macro-character-port-rhi port))
1856 ;; characters were added to char buffer
1858 #t)
1860 (else
1862 ;; no characters were added to char buffer, so try to get
1863 ;; some more bytes
1865 (let ((code2 ((macro-byte-port-rbuf-fill port)
1866 port
1867 want ;; assumes chars are at least 1 byte long
1868 block?)))
1870 (cond ((##fixnum? code2)
1872 ;; an error occurred, return the error code to caller
1874 code2)
1876 (code2
1878 ;; bytes were added to byte buffer, so try again
1879 ;; to extract characters from the byte buffer
1881 (loop))
1883 (else
1885 ;; no bytes were added to byte buffer
1886 ;; (end-of-file was reached)
1888 ;; The following call to ##os-port-decode-chars! will
1889 ;; check that the byte buffer is empty. If the
1890 ;; buffer is not empty an error code is returned
1891 ;; to indicate that the remaining bytes can't
1892 ;; form a character, otherwise #f is returned.
1894 (let ((code3 (##os-port-decode-chars! port want #t)))
1895 (if (##fixnum.= code3 0)
1896 #f
1897 code3))))))))))
1899 (define-prim (##byte-rbuf-fill port want block?)
1901 ;; port is the byte input-port
1902 ;; want is the number of bytes that the caller wants (#f = max)
1903 ;; block? is a boolean indicating whether it is OK for the thread to block
1905 ;; This procedure returns one of the following values:
1906 ;; - #t if bytes were added to the byte buffer,
1907 ;; - #f if no byte could be added to the byte buffer (because
1908 ;; end-of-file was reached),
1909 ;; - fixnum indicating an error code (in particular, only if block?
1910 ;; is false or there was a read timeout and the timeout thunk
1911 ;; returned #f, ##err-code-EAGAIN is returned to indicate that no
1912 ;; byte was currently available).
1914 ;; It is assumed that the thread has exclusive access to the port.
1916 (##declare (not interrupts-enabled))
1918 (let loop ()
1920 ;; shift bytes between rlo and rhi to beginning of buffer
1922 (let ((byte-rlo (macro-byte-port-rlo port))
1923 (byte-rhi (macro-byte-port-rhi port)))
1924 (if (##fixnum.< byte-rlo byte-rhi)
1925 (let ((byte-rbuf (macro-byte-port-rbuf port)))
1926 (##subu8vector-move! byte-rbuf byte-rlo byte-rhi byte-rbuf 0)))
1927 (macro-byte-port-rlo-set! port 0)
1928 (macro-byte-port-rhi-set! port (##fixnum.- byte-rhi byte-rlo)))
1930 ;; read into byte buffer at rhi
1932 (let* ((byte-rbuf
1933 (macro-byte-port-rbuf port))
1934 (byte-rhi
1935 (macro-byte-port-rhi port))
1936 (n
1937 (##os-device-stream-read
1938 (macro-condvar-name (macro-device-port-rdevice-condvar port))
1939 byte-rbuf
1940 byte-rhi
1941 (let ((rbuf-len (##u8vector-length byte-rbuf)))
1942 (if (and want (macro-unbuffered? (macro-port-roptions port)))
1943 (##fixnum.min (##fixnum.+ byte-rhi want) rbuf-len)
1944 rbuf-len)))))
1946 (if (##fixnum.< n 0)
1948 ;; the read caused an error
1950 (cond ((##fixnum.= n ##err-code-EINTR)
1952 ;; the read was interrupted, so try again
1954 (loop))
1956 ((and block?
1957 (##fixnum.= n ##err-code-EAGAIN))
1959 ;; the read would block and it is OK to block so wait
1960 ;; and then try again
1962 (macro-port-mutex-unlock! port)
1963 (let ((continue?
1964 (or (##wait-for-io!
1965 (macro-device-port-rdevice-condvar port)
1966 (macro-port-rtimeout port))
1967 ((macro-port-rtimeout-thunk port)))))
1968 (macro-port-mutex-lock! port) ;; regain access to port
1969 (if continue?
1970 (loop)
1971 n)))
1973 (else
1975 ;; return the error code to the caller
1977 n))
1979 ;; the read completed successfully
1981 (if (##fixnum.= n 0) ;; was end-of-file reached?
1982 #f
1983 (begin
1984 (macro-byte-port-rhi-set! port
1985 (##fixnum.+ (macro-byte-port-rhi port) n))
1986 #t))))))
1988 (define-prim (##char-wbuf-drain-no-reset port)
1990 ;; This procedure returns #f when the char buffer was successfully
1991 ;; drained or it returns an error code (fixnum). In particular,
1992 ;; only if there was a write timeout and the timeout thunk returned
1993 ;; #f, ##err-code-EAGAIN is returned to indicate that some chars
1994 ;; could not be written at this time.
1996 ;; It is assumed that the thread has exclusive access to the port.
1998 (##declare (not interrupts-enabled))
2000 (let loop ()
2002 ;; convert characters from char buffer into bytes in the byte buffer
2004 (let ((code1 (##os-port-encode-chars! port)))
2006 (cond ((##not (##fixnum.= code1 0))
2008 ;; an error occurred, return the error code to caller
2010 code1)
2012 ((##fixnum.< (macro-character-port-wlo port)
2013 (macro-character-port-whi port))
2015 ;; the byte buffer is full, so drain it and continue
2016 ;; draining char buffer
2018 (let ((code2 ((macro-byte-port-wbuf-drain port) port)))
2020 (if (##fixnum? code2)
2022 ;; an error occurred, return the error code to caller
2024 code2
2026 ;; the byte buffer was successfully drained, continue
2027 ;; draining char buffer
2029 (loop))))
2031 (else
2033 ;; the char buffer has been emptied
2035 #f)))))
2037 (define-prim (##char-wbuf-drain port)
2039 ;; It is assumed that the thread has exclusive access to the port.
2041 (##declare (not interrupts-enabled))
2043 (or (##char-wbuf-drain-no-reset port)
2044 (begin
2045 (macro-character-port-wchars-set!
2046 port
2047 (##fixnum.+ (macro-character-port-wchars port)
2048 (macro-character-port-whi port)))
2049 (macro-character-port-wlo-set! port 0)
2050 (macro-character-port-whi-set! port 0)
2051 #f)))
2053 (define-prim (##byte-wbuf-drain-no-reset port)
2055 ;; This procedure returns #f when the byte buffer was successfully
2056 ;; drained or it returns an error code (fixnum). In particular,
2057 ;; only if there was a write timeout and the timeout thunk returned
2058 ;; #f, ##err-code-EAGAIN is returned to indicate that no byte could
2059 ;; be written at this time.
2061 ;; It is assumed that the thread has exclusive access to the port.
2063 (##declare (not interrupts-enabled))
2065 (let loop ()
2067 (let ((byte-wlo (macro-byte-port-wlo port))
2068 (byte-whi (macro-byte-port-whi port)))
2069 (if (##fixnum.< byte-wlo byte-whi)
2071 ;; the byte buffer is not empty, write content of byte buffer
2072 ;; from wlo to whi
2074 (let ((n
2075 (##os-device-stream-write
2076 (macro-condvar-name (macro-device-port-wdevice-condvar port))
2077 (macro-byte-port-wbuf port)
2078 byte-wlo
2079 byte-whi)))
2081 (if (##fixnum.< n 0)
2083 ;; the write caused an error
2085 (cond ((##fixnum.= n ##err-code-EINTR)
2087 ;; the write was interrupted, so try again
2089 (loop))
2091 ((##fixnum.= n ##err-code-EAGAIN)
2093 ;; the write would block, so wait and then try again
2095 (macro-port-mutex-unlock! port)
2096 (let ((continue?
2097 (or (##wait-for-io!
2098 (macro-device-port-wdevice-condvar port)
2099 (macro-port-wtimeout port))
2100 ((macro-port-wtimeout-thunk port)))))
2101 (macro-port-mutex-lock! port) ;; regain access to port
2102 (if continue?
2103 (loop)
2104 n)))
2106 (else
2108 ;; return the error code to the caller
2110 n))
2112 ;; some bytes (possibly zero) were written, advance
2113 ;; wlo and try to write more
2115 (begin
2116 (macro-byte-port-wlo-set! port
2117 (##fixnum.+ (macro-byte-port-wlo port) n))
2118 (loop))))
2120 ;; the byte buffer is empty
2122 #f))))
2124 (define-prim (##byte-wbuf-drain port)
2126 ;; It is assumed that the thread has exclusive access to the port.
2128 (##declare (not interrupts-enabled))
2130 (or (##byte-wbuf-drain-no-reset port)
2131 (begin
2132 ;; the byte buffer is empty, reset wlo and whi
2133 (macro-byte-port-wlo-set! port 0)
2134 (macro-byte-port-whi-set! port 0)
2135 #f)))
2137 ;;;----------------------------------------------------------------------------
2139 ;;; Implementation of vector, string and u8vector ports.
2141 (##define-macro (define-prim-vector-port-procedures
2142 name
2143 empty-vect
2144 vect-zap!
2145 drain-output
2146 allowed-settings)
2148 (define (sym . lst)
2149 (string->symbol
2150 (apply string-append
2151 (map (lambda (s) (if (symbol? s) (symbol->string s) s))
2152 lst))))
2154 (let ((vector/character/byte
2155 (cond ((eq? name 'u8vector) 'byte)
2156 ((eq? name 'string) 'character)
2157 (else 'vector))))
2159 (define vect-input-port
2160 (sym name '-input-port))
2162 (define vect-output-port
2163 (sym name '-output-port))
2165 (define vect-or-settings
2166 (sym name '-or-settings))
2168 (define macro-check-vect-output-port
2169 (sym 'macro-check- name '-output-port))
2171 (define ##fail-check-vect-or-settings
2172 (sym '##fail-check- name '-or-settings))
2174 (define ##fail-check-vect (sym '##fail-check- name))
2175 (define ##make-vect (sym '##make- name))
2176 (define ##vect? (sym "##" name '?))
2177 (define ##vect-ref (sym "##" name '-ref))
2178 (define ##vect-set! (sym "##" name '-set!))
2179 (define ##vect-length (sym "##" name '-length))
2180 (define ##vect-shrink! (sym "##" name '-shrink!))
2181 (define ##subvect (sym '##sub name))
2182 (define ##subvect-move! (sym '##sub name '-move!))
2183 (define ##subvect->fifo (sym '##sub name '->fifo))
2184 (define ##fifo->vect (sym '##fifo-> name))
2185 (define ##open-vect-generic (sym '##open- name '-generic))
2186 (define ##open-vect-pipe-generic (sym '##open- name '-pipe-generic))
2187 (define ##open-input-vect (sym '##open-input- name))
2188 (define ##open-output-vect (sym '##open-output- name))
2189 (define ##open-vect (sym '##open- name))
2190 (define ##open-vect-pipe (sym '##open- name '-pipe))
2191 (define ##make-vect-port (sym '##make- name '-port))
2192 (define ##make-vect-pipe-port (sym '##make- name '-pipe-port))
2193 (define ##get-output-vect (sym '##get-output- name))
2195 (define open-vect (sym 'open- name))
2196 (define open-vect-pipe (sym 'open- name '-pipe))
2197 (define open-input-vect (sym 'open-input- name))
2198 (define open-output-vect (sym 'open-output- name))
2199 (define get-output-vect (sym 'get-output- name))
2201 (define call-with-input-vect (sym 'call-with-input- name))
2202 (define call-with-output-vect (sym 'call-with-output- name))
2203 (define with-input-from-vect (sym 'with-input-from- name))
2204 (define with-output-to-vect (sym 'with-output-to- name))
2206 (define define-vect-port-methods
2207 (sym 'define- name '-port-methods))
2209 (define macro-vect-port-rbuf
2210 (sym 'macro- vector/character/byte '-port-rbuf))
2211 (define macro-vect-port-rbuf-set!
2212 (sym 'macro- vector/character/byte '-port-rbuf-set!))
2213 (define macro-vect-port-rlo
2214 (sym 'macro- vector/character/byte '-port-rlo))
2215 (define macro-vect-port-rlo-set!
2216 (sym 'macro- vector/character/byte '-port-rlo-set!))
2217 (define macro-vect-port-rhi
2218 (sym 'macro- vector/character/byte '-port-rhi))
2219 (define macro-vect-port-rhi-set!
2220 (sym 'macro- vector/character/byte '-port-rhi-set!))
2221 (define macro-vect-port-rbuf-fill
2222 (sym 'macro- vector/character/byte '-port-rbuf-fill))
2223 (define macro-vect-port-rbuf-fill-set!
2224 (sym 'macro- vector/character/byte '-port-rbuf-fill-set!))
2225 (define macro-vect-port-wbuf
2226 (sym 'macro- vector/character/byte '-port-wbuf))
2227 (define macro-vect-port-wbuf-set!
2228 (sym 'macro- vector/character/byte '-port-wbuf-set!))
2229 (define macro-vect-port-wlo
2230 (sym 'macro- vector/character/byte '-port-wlo))
2231 (define macro-vect-port-wlo-set!
2232 (sym 'macro- vector/character/byte '-port-wlo-set!))
2233 (define macro-vect-port-whi
2234 (sym 'macro- vector/character/byte '-port-whi))
2235 (define macro-vect-port-whi-set!
2236 (sym 'macro- vector/character/byte '-port-whi-set!))
2237 (define macro-vect-port-wbuf-drain
2238 (sym 'macro- vector/character/byte '-port-wbuf-drain))
2239 (define macro-vect-port-wbuf-drain-set!
2240 (sym 'macro- vector/character/byte '-port-wbuf-drain-set!))
2242 (define macro-vect-port-peer
2243 (sym 'macro- name '-port-peer))
2244 (define macro-vect-port-peer-set!
2245 (sym 'macro- name '-port-peer-set!))
2246 (define macro-vect-port-fifo
2247 (sym 'macro- name '-port-fifo))
2248 (define macro-vect-port-fifo-set!
2249 (sym 'macro- name '-port-fifo-set!))
2250 (define macro-vect-port-rcondvar
2251 (sym 'macro- name '-port-rcondvar))
2252 (define macro-vect-port-rcondvar-set!
2253 (sym 'macro- name '-port-rcondvar-set!))
2254 (define macro-vect-port-wcondvar
2255 (sym 'macro- name '-port-wcondvar))
2256 (define macro-vect-port-wcondvar-set!
2257 (sym 'macro- name '-port-wcondvar-set!))
2258 (define macro-vect-port-buffering-limit
2259 (sym 'macro- name '-port-buffering-limit))
2260 (define macro-vect-port-buffering-limit-set!
2261 (sym 'macro- name '-port-buffering-limit-set!))
2263 (define vect-rbuf-fill
2264 (sym name '-rbuf-fill))
2266 (define vect-wbuf-drain
2267 (sym name '-wbuf-drain))
2269 `(begin
2271 (define-fail-check-type ,vect-input-port ',vect-input-port)
2272 (define-fail-check-type ,vect-output-port ',vect-output-port)
2273 (define-fail-check-type ,vect-or-settings ',vect-or-settings)
2275 (##define-macro (,define-vect-port-methods)
2276 `(begin
2278 (define (,',vect-rbuf-fill port want block?)
2280 ;; port is the vector input-port
2281 ;; want is the number of elements that the caller wants (#f = max)
2282 ;; block? is a boolean indicating whether it is OK for the
2283 ;; thread to block
2285 ;; This procedure returns one of the following values:
2286 ;; - #t if something was added to the read buffer,
2287 ;; - #f if nothing could be added to the read buffer
2288 ;; (because end-of-file was reached),
2289 ;; - fixnum indicating an error code (in particular,
2290 ;; only if block? is false or there was a read timeout
2291 ;; and the timeout thunk returned #f, ##err-code-EAGAIN
2292 ;; is returned to indicate that nothing is currently
2293 ;; available to be read).
2295 ;; It is assumed that the thread has exclusive access to the port.
2297 (##declare (not interrupts-enabled))
2299 (let loop ()
2301 #;
2302 (if (##u8vector? (,',macro-vect-port-rbuf port))
2303 (pp (##list (,',macro-vect-port-rlo port)
2304 (,',macro-vect-port-rhi port)
2305 (,',macro-vect-port-wlo port)
2306 (,',macro-vect-port-whi port)
2307 (,',macro-vect-port-rbuf port)
2308 (,',macro-vect-port-wbuf port)
2309 )
2310 ##stdout-port))
2312 (let* ((peer (,',macro-vect-port-peer port))
2313 (vect-rbuf (,',macro-vect-port-rbuf port))
2314 (vect-wbuf (,',macro-vect-port-wbuf peer)))
2315 (if (##not (##eq? vect-rbuf vect-wbuf))
2316 (let ((vect-rhi (,',macro-vect-port-rhi port))
2317 (len (,',##vect-length vect-rbuf)))
2318 (cond ((##fixnum.< vect-rhi len)
2319 (,',macro-vect-port-rhi-set! port len)
2320 #t)
2321 (else
2322 (let ((new-vect-rbuf
2323 (macro-fifo-advance!
2324 (,',macro-vect-port-fifo port))))
2325 (,',macro-vect-port-wlo-set!
2326 port
2327 (##fixnum.- (,',macro-vect-port-wlo port) len))
2328 (,',macro-vect-port-rbuf-set!
2329 port
2330 new-vect-rbuf)
2332 ,',(if (eq? name 'string)
2333 `(begin
2335 ;; keep track of number of characters read
2337 (macro-character-port-rchars-set!
2338 port
2339 (##fixnum.+ (macro-character-port-rchars port)
2340 (macro-character-port-rhi port))))
2342 #f)
2344 (,',macro-vect-port-rlo-set! port 0)
2345 (,',macro-vect-port-rhi-set! port 0)
2346 (##condvar-signal-no-reschedule!
2347 (,',macro-vect-port-wcondvar peer)
2348 #t)
2349 (loop)))))
2350 (let* ((vect-rhi (,',macro-vect-port-rhi port))
2351 (vect-whi (,',macro-vect-port-whi peer)))
2352 (cond ((##fixnum.< vect-rhi vect-whi)
2353 (,',macro-vect-port-rhi-set! port vect-whi)
2354 #t)
2355 ((macro-closed? (macro-port-woptions peer))
2356 (if (##not (macro-perm-close?
2357 (macro-port-woptions peer)))
2358 (macro-port-woptions-set!
2359 peer
2360 (macro-unclose! (macro-port-woptions peer))))
2361 #f)
2362 (block?
2363 (let ((continue?
2364 (or (##mutex-signal-and-condvar-wait!
2365 (macro-port-mutex port)
2366 (,',macro-vect-port-rcondvar port)
2367 (macro-port-rtimeout port))
2368 ((macro-port-rtimeout-thunk port)))))
2369 (macro-port-mutex-lock! port)
2370 (if continue?
2371 (loop)
2372 ##err-code-EAGAIN)))
2373 (else
2374 ##err-code-EAGAIN)))))))
2376 (define (,',vect-wbuf-drain port)
2378 ;; This procedure returns #f when the write buffer was
2379 ;; successfully drained or it returns an error code
2380 ;; (fixnum). In particular, only if there was a write
2381 ;; timeout and the timeout thunk returned #f,
2382 ;; ##err-code-EAGAIN is returned to indicate that nothing
2383 ;; could be written at this time.
2385 ;; It is assumed that the thread has exclusive access to the port.
2387 (##declare (not interrupts-enabled))
2389 ;;xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
2391 (let loop ()
2392 (let* ((peer
2393 (,',macro-vect-port-peer port))
2394 (buffering-limit
2395 (,',macro-vect-port-buffering-limit port)))
2396 (if (and buffering-limit
2397 (let ((unread
2398 (##fixnum.- (,',macro-vect-port-wlo peer)
2399 (,',macro-vect-port-rlo peer))))
2400 (##fixnum.< buffering-limit unread)))
2401 (let ((continue?
2402 (or (##mutex-signal-and-condvar-wait!
2403 (macro-port-mutex port)
2404 (,',macro-vect-port-wcondvar port)
2405 (macro-port-wtimeout port))
2406 ((macro-port-wtimeout-thunk port)))))
2407 (macro-port-mutex-lock! port)
2408 (if continue?
2409 (loop)
2410 ##err-code-EAGAIN))
2411 (let* ((new-vect-wbuf
2412 (,',##make-vect chunk-size))
2413 (vect-wbuf
2414 (,',macro-vect-port-wbuf port))
2415 (vect-whi
2416 (,',macro-vect-port-whi port)))
2417 (,',macro-vect-port-wlo-set!
2418 peer
2419 (##fixnum.+ (,',macro-vect-port-wlo peer) vect-whi))
2420 ,',(if (eq? name 'vector)
2421 #f
2422 `(macro-character-port-wchars-set!
2423 port
2424 (##fixnum.+
2425 (macro-character-port-wchars port)
2426 vect-whi)))
2427 (,',##vect-shrink! vect-wbuf vect-whi)
2428 (,',macro-vect-port-whi-set! port 0)
2429 (,',macro-vect-port-wbuf-set! port new-vect-wbuf)
2430 (macro-fifo-insert-at-tail!
2431 (,',macro-vect-port-fifo peer)
2432 new-vect-wbuf)
2433 (##condvar-signal-no-reschedule!
2434 (,',macro-vect-port-rcondvar peer)
2435 #t)
2436 #f)))))
2438 (define (name port)
2440 ;; It is assumed that the thread **does not** have exclusive
2441 ;; access to the port.
2443 (##declare (not interrupts-enabled))
2445 '(,',name))
2447 (define (force-output port level prim arg1 arg2 arg3 arg4)
2449 ;; It is assumed that the thread **does not** have exclusive
2450 ;; access to the port.
2452 (##declare (not interrupts-enabled))
2454 (macro-port-mutex-lock! port) ;; get exclusive access to port
2456 (let ((peer (,',macro-vect-port-peer port)))
2458 (##condvar-signal-no-reschedule!
2459 (,',macro-vect-port-rcondvar peer)
2460 #t)
2462 ,',(if drain-output
2463 `(let ((code (,drain-output port)))
2464 (macro-port-mutex-unlock! port)
2465 (if (##fixnum? code)
2466 (if (##fixnum.= code ##err-code-EAGAIN)
2467 #f;;;;;;;;;;;this doesn't appear to be right!
2468 (##raise-os-exception #f code prim arg1 arg2 arg3 arg4))
2469 (##void)))
2470 `(begin
2471 (macro-port-mutex-unlock! port)
2472 (##void)))))
2474 (define (close port prim arg1)
2476 ;; It is assumed that the thread **does not** have exclusive
2477 ;; access to the port.
2479 (##declare (not interrupts-enabled))
2481 ((macro-port-force-output port)
2482 port
2483 0
2484 prim
2485 arg1
2486 (macro-absent-obj)
2487 (macro-absent-obj)
2488 (macro-absent-obj))
2490 (macro-port-mutex-lock! port) ;; get exclusive access to port
2492 (let ((peer (,',macro-vect-port-peer port)))
2494 (if (##not (##eq? prim close-output-port))
2495 (begin
2496 (macro-port-roptions-set!
2497 port
2498 (macro-close! (macro-port-roptions port)))
2499 (##condvar-signal-no-reschedule!
2500 (,',macro-vect-port-wcondvar peer)
2501 #t)))
2503 (if (##not (##eq? prim close-input-port))
2504 (begin
2505 (macro-port-woptions-set!
2506 port
2507 (macro-close! (macro-port-woptions port)))
2508 (##condvar-signal-no-reschedule!
2509 (,',macro-vect-port-rcondvar peer)
2510 #t)))
2512 (macro-port-mutex-unlock! port)
2514 (##void)))
2516 (define (set-rtimeout port timeout thunk)
2518 ;; It is assumed that the thread **does not** have exclusive
2519 ;; access to the port.
2521 (##declare (not interrupts-enabled))
2523 (macro-port-mutex-lock! port) ;; get exclusive access to port
2525 (macro-port-rtimeout-set! port timeout)
2526 (macro-port-rtimeout-thunk-set! port thunk)
2527 (##condvar-signal-no-reschedule!
2528 (,',macro-vect-port-rcondvar port)
2529 #t)
2530 (macro-port-mutex-unlock! port)
2531 (##void))
2533 (define (set-wtimeout port timeout thunk)
2535 ;; It is assumed that the thread **does not** have exclusive
2536 ;; access to the port.
2538 (##declare (not interrupts-enabled))
2540 (macro-port-mutex-lock! port) ;; get exclusive access to port
2542 (macro-port-wtimeout-set! port timeout)
2543 (macro-port-wtimeout-thunk-set! port thunk)
2544 (##condvar-signal-no-reschedule!
2545 (,',macro-vect-port-wcondvar port)
2546 #t)
2547 (macro-port-mutex-unlock! port)
2548 (##void))))
2550 (define-prim (,##subvect->fifo vect start end chunk-size)
2551 (let ((fifo (macro-make-fifo)))
2552 (let loop ((lo start))
2553 (let ((hi (##fixnum.+ lo chunk-size)))
2554 (if (##fixnum.< hi end)
2555 (begin
2556 (macro-fifo-insert-at-tail! fifo (,##subvect vect lo hi))
2557 (loop hi))
2558 (begin
2559 (macro-fifo-insert-at-tail! fifo (,##subvect vect lo end))
2560 fifo))))))
2562 (define-prim (,##fifo->vect fifo start end)
2563 (let* ((len (##fixnum.max (##fixnum.- end start) 0))
2564 (vect (,##make-vect len)))
2565 (let loop ((elems (macro-fifo-next fifo))
2566 (hi end)
2567 (lo start)
2568 (i 0))
2569 (if (##fixnum.< lo hi)
2570 (let* ((chunk
2571 (macro-fifo-elem elems))
2572 (chunk-len
2573 (,##vect-length chunk))
2574 (n
2575 (##fixnum.min (##fixnum.- chunk-len lo)
2576 (##fixnum.- hi lo))))
2577 (,##subvect-move! chunk lo (##fixnum.+ lo n) vect i)
2578 (loop (macro-fifo-next elems)
2579 (##fixnum.- hi chunk-len)
2580 (##fixnum.- (##fixnum.+ lo n) chunk-len)
2581 (##fixnum.+ i n)))
2582 vect))))
2584 (define-prim (,##open-vect-generic
2585 direction
2586 cont
2587 prim
2588 #!optional
2589 (init-or-settings (macro-absent-obj))
2590 (arg2 (macro-absent-obj)))
2592 (define (fail)
2593 (,##fail-check-vect-or-settings 1 prim init-or-settings arg2))
2595 (##make-psettings
2596 direction
2597 ',allowed-settings
2598 (cond ((##eq? init-or-settings (macro-absent-obj))
2599 '())
2600 ((,##vect? init-or-settings)
2601 (##list 'init: init-or-settings))
2602 (else
2603 init-or-settings))
2604 fail
2605 (lambda (psettings)
2606 (let ((init
2607 (or (macro-psettings-init psettings)
2608 ',empty-vect)))
2609 (if (##not (,##vect? init))
2610 (fail)
2611 (cont
2612 (,##make-vect-port
2613 init
2614 0
2615 (,##vect-length init)
2616 psettings)))))))
2618 (define-prim (,##open-vect
2619 #!optional
2620 (init-or-settings (macro-absent-obj)))
2621 (,##open-vect-generic
2622 (macro-direction-inout)
2623 (lambda (port) port)
2624 ,open-vect
2625 init-or-settings))
2627 (define-prim (,open-vect
2628 #!optional
2629 (init-or-settings (macro-absent-obj)))
2630 (macro-force-vars (init-or-settings)
2631 (,##open-vect init-or-settings)))
2633 (define-prim (,##make-vect-pipe-port
2634 psettings1
2635 #!optional
2636 (psettings2 (macro-absent-obj)))
2637 (let* ((init1
2638 (or (macro-psettings-init psettings1)
2639 ',empty-vect))
2640 (port1
2641 (,##make-vect-port
2642 init1
2643 0
2644 (,##vect-length init1)
2645 psettings1))
2646 (port2
2647 (if (##eq? psettings2 (macro-absent-obj))
2648 (,##make-vect-port
2649 ',empty-vect
2650 0
2651 0
2652 (let ((roptions (macro-psettings-roptions psettings1))
2653 (woptions (macro-psettings-woptions psettings1)))
2654 (macro-psettings-roptions-set! psettings1 woptions)
2655 (macro-psettings-woptions-set! psettings1 roptions)
2656 (cond ((##fixnum.= (macro-psettings-direction psettings1)
2657 (macro-direction-in))
2658 (macro-psettings-direction-set!
2659 psettings1
2660 (macro-direction-out)))
2661 ((##fixnum.= (macro-psettings-direction psettings1)
2662 (macro-direction-out))
2663 (macro-psettings-direction-set!
2664 psettings1
2665 (macro-direction-in))))
2666 psettings1))
2667 (let ((init2
2668 (or (macro-psettings-init psettings2)
2669 ',empty-vect)))
2670 (,##make-vect-port
2671 init2
2672 0
2673 (,##vect-length init2)
2674 psettings2)))))
2675 (let ((wbuf1 (,macro-vect-port-wbuf port1))
2676 (wbuf2 (,macro-vect-port-wbuf port2))
2677 (whi1 (,macro-vect-port-whi port1))
2678 (whi2 (,macro-vect-port-whi port2)))
2679 (,macro-vect-port-wbuf-set! port1 wbuf2)
2680 (,macro-vect-port-wbuf-set! port2 wbuf1)
2681 (,macro-vect-port-whi-set! port1 whi2)
2682 (,macro-vect-port-whi-set! port2 whi1)
2683 (,macro-vect-port-peer-set! port1 port2)
2684 (,macro-vect-port-peer-set! port2 port1))
2685 (##values port1 port2)))
2687 (define-prim (,##open-vect-pipe-generic
2688 direction
2689 cont
2690 prim
2691 #!optional
2692 (init-or-settings1 (macro-absent-obj))
2693 (init-or-settings2 (macro-absent-obj)))
2695 (define (fail1)
2696 (,##fail-check-vect-or-settings 1 prim init-or-settings1 init-or-settings2))
2698 (define (fail2)
2699 (,##fail-check-vect-or-settings 2 prim init-or-settings1 init-or-settings2))
2701 (##make-psettings
2702 direction
2703 ',allowed-settings
2704 (cond ((##eq? init-or-settings1 (macro-absent-obj))
2705 '())
2706 ((,##vect? init-or-settings1)
2707 (##list 'init: init-or-settings1))
2708 (else
2709 init-or-settings1))
2710 fail1
2711 (lambda (psettings1)
2712 (let ((init1
2713 (or (macro-psettings-init psettings1)
2714 ',empty-vect)))
2715 (if (##not (,##vect? init1))
2716 (fail1)
2717 (if (##eq? init-or-settings2 (macro-absent-obj))
2718 (cont (,##make-vect-pipe-port psettings1))
2719 (##make-psettings
2720 direction
2721 ',allowed-settings
2722 (cond ((,##vect? init-or-settings2)
2723 (##list 'init: init-or-settings2))
2724 (else
2725 init-or-settings2))
2726 fail2
2727 (lambda (psettings2)
2728 (let ((init2
2729 (or (macro-psettings-init psettings2)
2730 ',empty-vect)))
2731 (if (##not (,##vect? init2))
2732 (fail2)
2733 (cont (,##make-vect-pipe-port psettings1 psettings2))))))))))))
2735 (define-prim (,##open-vect-pipe
2736 #!optional
2737 (init-or-settings1 (macro-absent-obj))
2738 (init-or-settings2 (macro-absent-obj)))
2739 (,##open-vect-pipe-generic
2740 (macro-direction-inout)
2741 (lambda (ports) ports)
2742 ,open-vect-pipe
2743 init-or-settings1
2744 init-or-settings2))
2746 (define-prim (,open-vect-pipe
2747 #!optional
2748 (init-or-settings1 (macro-absent-obj))
2749 (init-or-settings2 (macro-absent-obj)))
2750 (macro-force-vars (init-or-settings1 init-or-settings2)
2751 (,##open-vect-pipe init-or-settings1 init-or-settings2)))
2753 (define-prim (,##open-input-vect
2754 #!optional
2755 (init-or-settings (macro-absent-obj)))
2756 (,##open-vect-generic
2757 (macro-direction-in)
2758 (lambda (port) port)
2759 ,open-input-vect
2760 init-or-settings))
2762 (define-prim (,open-input-vect
2763 #!optional
2764 (init-or-settings (macro-absent-obj)))
2765 (macro-force-vars (init-or-settings)
2766 (,##open-input-vect init-or-settings)))
2768 (define-prim (,##open-output-vect
2769 #!optional
2770 (init-or-settings (macro-absent-obj)))
2771 (,##open-vect-generic
2772 (macro-direction-out)
2773 (lambda (port) port)
2774 ,open-output-vect
2775 init-or-settings))
2777 (define-prim (,open-output-vect
2778 #!optional
2779 (init-or-settings (macro-absent-obj)))
2780 (macro-force-vars (init-or-settings)
2781 (,##open-output-vect init-or-settings)))
2783 (define-prim (,##get-output-vect port)
2785 (##declare (not interrupts-enabled))
2787 (let ((peer
2788 (,macro-vect-port-peer port)))
2790 ((macro-port-force-output peer)
2791 peer
2792 0
2793 ,get-output-vect
2794 port
2795 (macro-absent-obj)
2796 (macro-absent-obj)
2797 (macro-absent-obj))
2799 (macro-port-mutex-lock! port) ;; get exclusive access to port
2801 (let* ((vect-fifo
2802 (,macro-vect-port-fifo peer))
2803 (result
2804 (,##fifo->vect
2805 vect-fifo
2806 (,macro-vect-port-rlo peer)
2807 (##fixnum.+ (,macro-vect-port-wlo peer)
2808 (,macro-vect-port-whi port))))
2809 (new-vect-buf
2810 (macro-fifo-advance-to-tail! vect-fifo)))
2812 ;; zap the entries of the buffer to avoid leaks
2814 ,(if vect-zap!
2815 `(let loop ((i
2816 (if (##eq?
2817 (,macro-vect-port-rbuf peer)
2818 new-vect-buf)
2819 (,macro-vect-port-rlo peer)
2820 0)))
2821 (if (##fixnum.< i (,macro-vect-port-whi port))
2822 (begin
2823 (,vect-zap! new-vect-buf i)
2824 (loop (##fixnum.+ i 1)))))
2825 #f)
2827 (,macro-vect-port-rbuf-set! peer new-vect-buf)
2828 (,macro-vect-port-rlo-set! peer 0)
2829 (,macro-vect-port-rhi-set! peer 0)
2831 (,macro-vect-port-wbuf-set! port new-vect-buf)
2832 (,macro-vect-port-wlo-set! peer 0) ;;;;;;;;;;;; peer or port ?
2833 (,macro-vect-port-whi-set! port 0)
2835 (macro-port-mutex-unlock! port)
2837 result)))
2839 (define-prim (,get-output-vect port)
2840 (macro-force-vars (port)
2841 (,macro-check-vect-output-port
2842 port
2843 1
2844 (,get-output-vect port)
2845 (,##get-output-vect port))))
2847 (define-prim (,call-with-input-vect init-or-settings proc)
2848 (macro-force-vars (init-or-settings proc)
2849 (macro-check-procedure
2850 proc
2851 2
2852 (,call-with-input-vect init-or-settings proc)
2853 (,##open-vect-generic
2854 (macro-direction-in)
2855 (lambda (port)
2856 (let ((results ;; may get bound to a multiple-values object
2857 (proc port)))
2858 (##close-input-port port)
2859 results))
2860 ,call-with-input-vect
2861 init-or-settings
2862 proc))))
2864 (define-prim (,call-with-output-vect init-or-settings proc)
2865 (macro-force-vars (init-or-settings proc)
2866 (macro-check-procedure
2867 proc
2868 2
2869 (,call-with-output-vect init-or-settings proc)
2870 (,##open-vect-generic
2871 (macro-direction-out)
2872 (lambda (port)
2873 (let ((results ;; may get bound to a multiple-values object
2874 (proc port)))
2875 (##force-output port)
2876 (##close-output-port port)
2877 (,##get-output-vect port)))
2878 ,call-with-output-vect
2879 init-or-settings
2880 proc))))
2882 (define-prim (,with-input-from-vect init-or-settings thunk)
2883 (macro-force-vars (init-or-settings thunk)
2884 (macro-check-procedure
2885 thunk
2886 2
2887 (,with-input-from-vect init-or-settings thunk)
2888 (,##open-vect-generic
2889 (macro-direction-in)
2890 (lambda (port)
2891 (let ((results ;; may get bound to a multiple-values object
2892 (macro-dynamic-bind input-port port thunk)))
2893 (##close-input-port port)
2894 results))
2895 ,with-input-from-vect
2896 init-or-settings
2897 thunk))))
2899 (define-prim (,with-output-to-vect init-or-settings thunk)
2900 (macro-force-vars (init-or-settings thunk)
2901 (macro-check-procedure
2902 thunk
2903 2
2904 (,with-output-to-vect init-or-settings thunk)
2905 (,##open-vect-generic
2906 (macro-direction-out)
2907 (lambda (port)
2908 (let ((results ;; may get bound to a multiple-values object
2909 (macro-dynamic-bind output-port port thunk)))
2910 (##force-output port)
2911 (##close-output-port port)
2912 (,##get-output-vect port)))
2913 ,with-output-to-vect
2914 init-or-settings
2915 thunk)))))))
2917 (define-prim (##vect-port-options options kind buffering)
2918 (##psettings-options->options
2919 options
2920 (##fixnum.+
2921 (##fixnum.* (macro-open-state-shift)
2922 (if (##fixnum.= kind (macro-none-kind))
2923 (macro-open-state-closed)
2924 (macro-open-state-open)))
2925 (##fixnum.* (macro-buffering-shift)
2926 buffering))))
2928 ;;;----------------------------------------------------------------------------
2930 ;;; Implementation of vector ports.
2932 (define-prim-vector-port-procedures
2933 vector
2934 #()
2935 (lambda (vect i) (##vector-set! vect i #f))
2936 #f
2937 (init:
2938 permanent-close:
2939 direction:
2940 input-buffering:
2941 output-buffering:
2942 buffering:))
2944 (define-prim (##make-vector-port src start end psettings)
2946 (define chunk-size 16)
2948 (let* ((direction
2949 (macro-psettings-direction psettings))
2950 (len
2951 (##fixnum.max (##fixnum.- end start) 0))
2952 (vector-fifo
2953 (##subvector->fifo src start end chunk-size))
2954 (mutex
2955 (macro-make-port-mutex))
2956 (rkind
2957 (if (##fixnum.= direction (macro-direction-out))
2958 (macro-none-kind)
2959 (macro-vector-kind)))
2960 (wkind
2961 (if (##fixnum.= direction (macro-direction-in))
2962 (macro-none-kind)
2963 (macro-vector-kind)))
2964 (roptions
2965 (##vect-port-options
2966 (macro-psettings-roptions psettings)
2967 rkind
2968 (macro-full-buffering)))
2969 (rtimeout
2970 #t)
2971 (rtimeout-thunk
2972 #f)
2973 (woptions
2974 (##vect-port-options
2975 (macro-psettings-woptions psettings)
2976 wkind
2977 (macro-full-buffering)))
2978 (wtimeout
2979 #t)
2980 (wtimeout-thunk
2981 #f)
2982 (vector-rbuf
2983 (macro-fifo-elem (macro-fifo-next vector-fifo)))
2984 (vector-rlo
2985 0)
2986 (vector-rhi
2987 (##vector-length vector-rbuf))
2988 (vector-wbuf
2989 (macro-fifo-elem (macro-fifo-tail vector-fifo)))
2990 (vector-whi
2991 (##vector-length vector-wbuf))
2992 (vector-wlo
2993 (##fixnum.- len vector-whi))
2994 (vector-rcondvar
2995 (##make-io-condvar #f #f))
2996 (vector-wcondvar
2997 (##make-io-condvar #f #t))
2998 (vector-buffering-limit
2999 #f))
3001 (define (read-datum port re)
3003 ;; It is assumed that the thread **does not** have exclusive
3004 ;; access to the port.
3006 (##declare (not interrupts-enabled))
3008 (macro-port-mutex-lock! port) ;; get exclusive access to port
3010 (let loop ()
3012 (let ((vector-rlo (macro-vector-port-rlo port))
3013 (vector-rhi (macro-vector-port-rhi port)))
3014 (if (##fixnum.< vector-rlo vector-rhi)
3016 ;; the next object is in the object read buffer
3018 (let* ((vector-rbuf
3019 (macro-vector-port-rbuf port))
3020 (obj
3021 (##vector-ref vector-rbuf vector-rlo)))
3023 ;; frequent simple case, just advance rlo and zap vector
3024 ;; to avoid retaining objects uselessly
3026 (##vector-set! vector-rbuf vector-rlo #f)
3027 (macro-vector-port-rlo-set! port (##fixnum.+ vector-rlo 1))
3028 (macro-port-mutex-unlock! port)
3029 obj)
3031 ;; try to get more objects into the object read
3032 ;; buffer, and try again if successful otherwise
3033 ;; signal an error or return end-of-file object
3035 (let ((code ((macro-vector-port-rbuf-fill port)
3036 port
3037 1
3038 #t)))
3040 (cond ((##fixnum? code)
3042 ;; the conversion or read caused an error
3044 (macro-port-mutex-unlock! port)
3045 (if (##fixnum.= code ##err-code-EAGAIN)
3046 #!eof ;; the read timeout thunk returned #f
3047 (##raise-os-exception #f code read port)))
3049 (code
3051 ;; some objects were added to object buffer
3053 (loop))
3055 (else
3057 ;; no objects were added to object buffer
3059 (macro-port-mutex-unlock! port)
3060 #!eof)))))))
3062 (define (write-datum port obj we)
3064 ;; It is assumed that the thread **does not** have exclusive
3065 ;; access to the port.
3067 (##declare (not interrupts-enabled))
3069 (macro-port-mutex-lock! port) ;; get exclusive access to port
3071 (let loop ()
3073 (let ((vector-wbuf (macro-vector-port-wbuf port))
3074 (vector-whi+1 (##fixnum.+ (macro-vector-port-whi port) 1)))
3075 (if (##not (##fixnum.< (##vector-length vector-wbuf) vector-whi+1))
3077 ;; there is enough space in the object write buffer, so add
3078 ;; object and increment whi
3080 (let ()
3082 (##vector-set! vector-wbuf (##fixnum.- vector-whi+1 1) obj)
3084 ;; advance whi
3086 (macro-vector-port-whi-set! port vector-whi+1)
3088 ;; force output if port is set for unbuffered output
3090 (if (macro-unbuffered? (macro-port-woptions port))
3091 (begin
3092 (macro-port-mutex-unlock! port)
3093 ((macro-port-force-output port)
3094 port
3095 0
3096 write
3097 obj
3098 port
3099 (macro-absent-obj)
3100 (macro-absent-obj)))
3101 (begin
3102 (macro-port-mutex-unlock! port)
3103 (##void))))
3105 ;; make some space in the object buffer and try again
3107 (let ((code ((macro-vector-port-wbuf-drain port) port)))
3108 (if (##fixnum? code)
3109 (begin
3110 (macro-port-mutex-unlock! port)
3111 (if (##fixnum.= code ##err-code-EAGAIN)
3112 #f
3113 (##raise-os-exception #f code write obj port)))
3114 (loop)))))))
3116 (define (newline port)
3118 ;; It is assumed that the thread **does not** have exclusive
3119 ;; access to the port.
3121 (##declare (not interrupts-enabled))
3123 (##void))
3125 (define-vector-port-methods)
3127 (let ((port
3128 (macro-make-vector-port
3129 mutex
3130 rkind
3131 wkind
3132 name
3133 read-datum
3134 write-datum
3135 newline
3136 force-output
3137 close
3138 roptions
3139 rtimeout
3140 rtimeout-thunk
3141 set-rtimeout
3142 woptions
3143 wtimeout
3144 wtimeout-thunk
3145 set-wtimeout
3146 vector-rbuf
3147 vector-rlo
3148 vector-rhi
3149 vector-rbuf-fill
3150 vector-wbuf
3151 vector-wlo
3152 vector-whi
3153 vector-wbuf-drain
3154 #f
3155 vector-fifo
3156 vector-rcondvar
3157 vector-wcondvar
3158 vector-buffering-limit)))
3159 (macro-vector-port-peer-set! port port)
3160 (##io-condvar-port-set! vector-rcondvar port)
3161 (##io-condvar-port-set! vector-wcondvar port)
3162 port)))
3164 ;;;----------------------------------------------------------------------------
3166 ;;; Implementation of string ports.
3168 (define-prim-vector-port-procedures
3169 string
3170 ""
3171 #f
3172 #f
3173 (output-width:
3174 init:
3175 permanent-close:
3176 direction:
3177 input-buffering:
3178 output-buffering:
3179 buffering:
3180 input-readtable:
3181 output-readtable:
3182 readtable:))
3184 (define-prim (##make-string-port src start end psettings)
3186 (define chunk-size 32)
3188 (let* ((direction
3189 (macro-psettings-direction psettings))
3190 (len
3191 (##fixnum.max (##fixnum.- end start) 0))
3192 (string-fifo
3193 (##substring->fifo src start end chunk-size))
3194 (mutex
3195 (macro-make-port-mutex))
3196 (rkind
3197 (if (##fixnum.= direction (macro-direction-out))
3198 (macro-none-kind)
3199 (macro-string-kind)))
3200 (wkind
3201 (if (##fixnum.= direction (macro-direction-in))
3202 (macro-none-kind)
3203 (macro-string-kind)))
3204 (roptions
3205 (##vect-port-options
3206 (macro-psettings-roptions psettings)
3207 rkind
3208 (macro-full-buffering)))
3209 (rtimeout
3210 #t)
3211 (rtimeout-thunk
3212 #f)
3213 (woptions
3214 (##vect-port-options
3215 (macro-psettings-woptions psettings)
3216 wkind
3217 (macro-full-buffering)))
3218 (wtimeout
3219 #t)
3220 (wtimeout-thunk
3221 #f)
3222 (string-rbuf
3223 (macro-fifo-elem (macro-fifo-next string-fifo)))
3224 (string-rlo
3225 0)
3226 (string-rhi
3227 (##string-length string-rbuf))
3228 (char-rchars
3229 0)
3230 (char-rlines
3231 0)
3232 (char-rcurline
3233 0)
3234 (char-peek-eof?
3235 #f)
3236 (string-wbuf
3237 (macro-fifo-elem (macro-fifo-tail string-fifo)))
3238 (string-whi
3239 (##string-length string-wbuf))
3240 (string-wlo
3241 (##fixnum.- len string-whi))
3242 (char-wchars
3243 0)
3244 (char-wlines
3245 0)
3246 (char-wcurline
3247 0)
3248 (input-readtable
3249 (##psettings->input-readtable psettings))
3250 (output-readtable
3251 (##psettings->output-readtable psettings))
3252 (string-rcondvar
3253 (##make-io-condvar #f #f))
3254 (string-wcondvar
3255 (##make-io-condvar #f #t))
3256 (string-width
3257 (##psettings->output-width psettings))
3258 (string-buffering-limit
3259 #f))
3261 (define (read-datum port re)
3263 ;; It is assumed that the thread **does not** have exclusive
3264 ;; access to the port.
3266 (##declare (not interrupts-enabled))
3268 (##read-datum-or-eof re))
3270 (define (write-datum port obj we)
3272 ;; It is assumed that the thread **does not** have exclusive
3273 ;; access to the port.
3275 (##declare (not interrupts-enabled))
3277 (##wr we obj))
3279 (define (newline port)
3281 ;; It is assumed that the thread **does not** have exclusive
3282 ;; access to the port.
3284 (##declare (not interrupts-enabled))
3286 (##write-char #\newline port))
3288 (define (output-width port)
3290 ;; It is assumed that the thread **does not** have exclusive
3291 ;; access to the port.
3293 (##declare (not interrupts-enabled))
3295 (macro-string-port-width port))
3297 (define-string-port-methods)
3299 (let ((port
3300 (macro-make-string-port
3301 mutex
3302 rkind
3303 wkind
3304 name
3305 read-datum
3306 write-datum
3307 newline
3308 force-output
3309 close
3310 roptions
3311 rtimeout
3312 rtimeout-thunk
3313 set-rtimeout
3314 woptions
3315 wtimeout
3316 wtimeout-thunk
3317 set-wtimeout
3318 string-rbuf
3319 string-rlo
3320 string-rhi
3321 char-rchars
3322 char-rlines
3323 char-rcurline
3324 string-rbuf-fill
3325 char-peek-eof?
3326 string-wbuf
3327 string-wlo
3328 string-whi
3329 char-wchars
3330 char-wlines
3331 char-wcurline
3332 string-wbuf-drain
3333 input-readtable
3334 output-readtable
3335 output-width
3336 #f
3337 string-fifo
3338 string-rcondvar
3339 string-wcondvar
3340 string-width
3341 string-buffering-limit)))
3342 (macro-string-port-peer-set! port port)
3343 (##io-condvar-port-set! string-rcondvar port)
3344 (##io-condvar-port-set! string-wcondvar port)
3345 port)))
3347 ;;;----------------------------------------------------------------------------
3349 ;;; Implementation of u8vector ports.
3351 (define-prim-vector-port-procedures
3352 u8vector
3353 #u8()
3354 #f
3355 (lambda (port) ((macro-character-port-wbuf-drain port) port))
3356 (input-char-encoding:
3357 output-char-encoding:
3358 char-encoding:
3359 input-char-encoding-errors:
3360 output-char-encoding-errors:
3361 char-encoding-errors:
3362 input-eol-encoding:
3363 output-eol-encoding:
3364 eol-encoding:
3365 output-width:
3366 init:
3367 permanent-close:
3368 direction:
3369 input-buffering:
3370 output-buffering:
3371 buffering:
3372 input-readtable:
3373 output-readtable:
3374 readtable:))
3376 (define-prim (##make-u8vector-port src start end psettings)
3378 (define char-buf-len 32) ;; character buffer length
3379 (define chunk-size 64)
3380 ;;; (define char-buf-len 3) ;; character buffer length
3381 ;;; (define chunk-size 6)
3383 (let* ((direction
3384 (macro-psettings-direction psettings))
3385 (len
3386 (##fixnum.max (##fixnum.- end start) 0))
3387 (u8vector-fifo
3388 (##subu8vector->fifo src start end chunk-size))
3389 (mutex
3390 (macro-make-port-mutex))
3391 (rkind
3392 (if (##fixnum.= direction (macro-direction-out))
3393 (macro-none-kind)
3394 (macro-u8vector-kind)))
3395 (wkind
3396 (if (##fixnum.= direction (macro-direction-in))
3397 (macro-none-kind)
3398 (macro-u8vector-kind)))
3399 (roptions
3400 (##vect-port-options
3401 (macro-psettings-roptions psettings)
3402 rkind
3403 (macro-full-buffering)))
3404 (rtimeout
3405 #t)
3406 (rtimeout-thunk
3407 #f)
3408 (woptions
3409 (##vect-port-options
3410 (macro-psettings-woptions psettings)
3411 wkind
3412 (macro-full-buffering)))
3413 (wtimeout
3414 #t)
3415 (wtimeout-thunk
3416 #f)
3417 (char-rbuf
3418 (and (##not (##fixnum.= rkind (macro-none-kind)))
3419 (##make-string (if (macro-unbuffered? roptions)
3420 1
3421 char-buf-len))))
3422 (char-rlo
3423 0)
3424 (char-rhi
3425 0)
3426 (char-rchars
3427 0)
3428 (char-rlines
3429 0)
3430 (char-rcurline
3431 0)
3432 (char-rbuf-fill
3433 ##char-rbuf-fill)
3434 (char-peek-eof?
3435 #f)
3436 (char-wbuf
3437 (and (##not (##fixnum.= wkind (macro-none-kind)))
3438 (##make-string (if (macro-unbuffered? woptions)
3439 1
3440 char-buf-len))))
3441 (char-wlo
3442 0)
3443 (char-whi
3444 0)
3445 (char-wchars
3446 0)
3447 (char-wlines
3448 0)
3449 (char-wcurline
3450 0)
3451 (char-wbuf-drain
3452 ##char-wbuf-drain)
3453 (input-readtable
3454 (##psettings->input-readtable psettings))
3455 (output-readtable
3456 (##psettings->output-readtable psettings))
3457 #|
3458 ;;;;;;;;;;;;;;;;;;;;;;;;
3459 (byte-rbuf
3460 (and (##not (##fixnum.= rkind (macro-none-kind)))
3461 (##make-u8vector byte-buf-len)))
3462 (byte-rlo
3463 0)
3464 (byte-rhi
3465 0)
3466 (byte-rbuf-fill
3467 ##byte-rbuf-fill)
3468 (byte-wbuf
3469 (and (##not (##fixnum.= wkind (macro-none-kind)))
3470 (##make-u8vector byte-buf-len)))
3471 (byte-wlo
3472 0)
3473 (byte-whi
3474 0)
3475 (byte-wbuf-drain
3476 ##byte-wbuf-drain)
3477 ;;;;;;;;;;;;;;;;;;;;;;;;
3478 |#
3479 (u8vector-rbuf
3480 (macro-fifo-elem (macro-fifo-next u8vector-fifo)))
3481 (u8vector-rlo
3482 0)
3483 (u8vector-rhi
3484 (##u8vector-length u8vector-rbuf))
3485 (u8vector-wbuf
3486 (macro-fifo-elem (macro-fifo-tail u8vector-fifo)))
3487 (u8vector-whi
3488 (##u8vector-length u8vector-wbuf))
3489 (u8vector-wlo
3490 (##fixnum.- len u8vector-whi))
3491 (u8vector-rcondvar
3492 (##make-io-condvar #f #f))
3493 (u8vector-wcondvar
3494 (##make-io-condvar #f #t))
3495 (u8vector-width
3496 (##psettings->output-width psettings))
3497 (u8vector-buffering-limit
3498 #f))
3500 (define (read-datum port re)
3502 ;; It is assumed that the thread **does not** have exclusive
3503 ;; access to the port.
3505 (##declare (not interrupts-enabled))
3507 (##read-datum-or-eof re))
3509 (define (write-datum port obj we)
3511 ;; It is assumed that the thread **does not** have exclusive
3512 ;; access to the port.
3514 (##declare (not interrupts-enabled))
3516 (##wr we obj))
3518 (define (newline port)
3520 ;; It is assumed that the thread **does not** have exclusive
3521 ;; access to the port.
3523 (##declare (not interrupts-enabled))
3525 (##write-char #\newline port))
3527 (define (output-width port)
3529 ;; It is assumed that the thread **does not** have exclusive
3530 ;; access to the port.
3532 (##declare (not interrupts-enabled))
3534 (macro-u8vector-port-width port))
3536 (define-u8vector-port-methods)
3538 (let ((fill u8vector-rbuf-fill)
3539 (drain u8vector-wbuf-drain))
3541 #;
3542 (define (u8vector-rbuf-fill port want block?)
3543 (pp (list 'u8vector-rbuf-fill port want block?))
3544 (##repl)
3545 (fill port want block?))
3547 #;
3548 (define (u8vector-wbuf-drain port)
3549 (pp (list 'u8vector-wbuf-drain port))
3550 (##repl)
3551 (drain port))
3553 (let ((port
3554 (macro-make-u8vector-port
3555 mutex
3556 rkind
3557 wkind
3558 name
3559 read-datum
3560 write-datum
3561 newline
3562 force-output
3563 close
3564 roptions
3565 rtimeout
3566 rtimeout-thunk
3567 set-rtimeout
3568 woptions
3569 wtimeout
3570 wtimeout-thunk
3571 set-wtimeout
3572 char-rbuf
3573 char-rlo
3574 char-rhi
3575 char-rchars
3576 char-rlines
3577 char-rcurline
3578 char-rbuf-fill
3579 char-peek-eof?
3580 char-wbuf
3581 char-wlo
3582 char-whi
3583 char-wchars
3584 char-wlines
3585 char-wcurline
3586 char-wbuf-drain
3587 input-readtable
3588 output-readtable
3589 output-width
3590 u8vector-rbuf
3591 u8vector-rlo
3592 u8vector-rhi
3593 u8vector-rbuf-fill
3594 u8vector-wbuf
3595 u8vector-wlo
3596 u8vector-whi
3597 u8vector-wbuf-drain
3598 #f
3599 u8vector-fifo
3600 u8vector-rcondvar
3601 u8vector-wcondvar
3602 u8vector-width
3603 u8vector-buffering-limit)))
3604 (macro-u8vector-port-peer-set! port port)
3605 (##io-condvar-port-set! u8vector-rcondvar port)
3606 (##io-condvar-port-set! u8vector-wcondvar port)
3607 port)))
3608 )
3610 ;;;----------------------------------------------------------------------------
3612 ;;; Implementation of generic object port procedures.
3614 (define-prim (##port-of-kind? obj kind)
3615 (##declare (not interrupts-enabled))
3616 (and (macro-port? obj)
3617 (##fixnum.= (##fixnum.bitwise-and (##port-kind obj) kind) kind)))
3619 (define-prim (##port-kind port)
3620 (##declare (not interrupts-enabled))
3621 (let ((rkind (macro-port-rkind port)))
3622 (if (##fixnum.= rkind (macro-none-kind))
3623 (macro-port-wkind port)
3624 rkind)))
3626 (define-prim (##port-device port)
3627 (##declare (not interrupts-enabled))
3628 (if (##fixnum.= (macro-port-rkind port) (macro-none-kind))
3629 (let ((wdevice-condvar (macro-device-port-wdevice-condvar port)))
3630 (macro-condvar-name wdevice-condvar))
3631 (let ((rdevice-condvar (macro-device-port-rdevice-condvar port)))
3632 (macro-condvar-name rdevice-condvar))))
3634 (define-prim (##port-name port)
3635 (##declare (not interrupts-enabled))
3636 ((macro-port-name port) port))
3638 (define-prim (##read port)
3640 (##declare (not interrupts-enabled))
3642 (if (macro-character-input-port? port)
3643 (let* ((noop
3644 (lambda (re x) x)) ;; do not wrap datum
3645 (re
3646 (##make-readenv
3647 port
3648 (macro-character-port-input-readtable port)
3649 noop
3650 noop
3651 #f)))
3652 ((macro-port-read-datum port) port re))
3653 ((macro-port-read-datum port) port #f)))
3655 (define-prim (read
3656 #!optional
3657 (port (macro-absent-obj)))
3658 (macro-force-vars (port)
3659 (let ((p
3660 (if (##eq? port (macro-absent-obj))
3661 (macro-current-input-port)
3662 port)))
3663 (macro-check-input-port p 1 (read p)
3664 (##read p)))))
3666 (define-prim (##write-generic-to-character-port style port rt force? limit obj)
3668 (##declare (not interrupts-enabled))
3670 (let* ((mt
3671 (and (macro-readtable-sharing-allowed? rt)
3672 (##make-marktable)))
3673 (width
3674 (##output-port-width port)))
3676 (if mt
3677 (let ((we1 (##make-writeenv 'mark port rt mt force? width 0 0 0 limit)))
3678 ((macro-port-write-datum port) port obj we1)))
3680 (let ((we2 (##make-writeenv style port rt mt force? width 0 0 0 limit)))
3681 ((macro-port-write-datum port) port obj we2)
3682 (##fixnum.- limit (macro-writeenv-limit we2)))))
3684 (define-prim (##write obj port #!optional (max-length ##max-fixnum))
3685 (if (macro-character-output-port? port)
3686 (begin
3687 (##write-generic-to-character-port
3688 'write
3689 port
3690 (macro-character-port-output-readtable port)
3691 (macro-if-forces #t #f)
3692 max-length
3693 obj)
3694 (##void))
3695 ((macro-port-write-datum port) port obj #f)))
3697 (define-prim (write
3698 obj
3699 #!optional
3700 (port (macro-absent-obj)))
3701 (macro-force-vars (obj port)
3702 (let ((p
3703 (if (##eq? port (macro-absent-obj))
3704 (macro-current-output-port)
3705 port)))
3706 (macro-check-output-port p 2 (write obj p)
3707 (##write obj p)))))
3709 (define-prim (##display obj port #!optional (max-length ##max-fixnum))
3710 (if (macro-character-output-port? port)
3711 (begin
3712 (##write-generic-to-character-port
3713 'display
3714 port
3715 (macro-character-port-output-readtable port)
3716 (macro-if-forces #t #f)
3717 max-length
3718 obj)
3719 (##void))
3720 ((macro-port-write-datum port) port obj #f)))
3722 (define-prim (display
3723 obj
3724 #!optional
3725 (port (macro-absent-obj)))
3726 (macro-force-vars (obj port)
3727 (let ((p
3728 (if (##eq? port (macro-absent-obj))
3729 (macro-current-output-port)
3730 port)))
3731 (macro-check-output-port p 2 (display obj p)
3732 (##display obj p)))))
3734 (define-prim (##pretty-print obj port #!optional (max-length ##max-fixnum))
3735 (if (macro-character-output-port? port)
3736 (begin
3737 (##write-generic-to-character-port
3738 'pretty-print
3739 port
3740 (macro-character-port-output-readtable port)
3741 (macro-if-forces #t #f)
3742 max-length
3743 obj)
3744 (##newline port))
3745 ((macro-port-write-datum port) port obj #f)))
3747 (define-prim (pretty-print
3748 obj
3749 #!optional
3750 (port (macro-absent-obj)))
3751 (macro-force-vars (obj port)
3752 (let ((p
3753 (if (##eq? port (macro-absent-obj))
3754 (macro-current-output-port)
3755 port)))
3756 (macro-check-output-port p 2 (pretty-print obj p)
3757 (##pretty-print obj p)))))
3759 (define-prim (##print-fringe obj port #!optional (max-length ##max-fixnum))
3760 (if (macro-character-output-port? port)
3761 (begin
3762 (##write-generic-to-character-port
3763 'print
3764 port
3765 (macro-character-port-output-readtable port)
3766 (macro-if-forces #t #f)
3767 max-length
3768 obj)
3769 (##void))
3770 ((macro-port-write-datum port) port obj #f)))
3772 (define-prim (print
3773 #!key (port (macro-absent-obj))
3774 #!rest body)
3775 (macro-force-vars (port)
3776 (let ((p
3777 (if (##eq? port (macro-absent-obj))
3778 (macro-current-output-port)
3779 port)))
3780 (macro-check-output-port p 2 (print port: p . body)
3781 (##print-fringe body p)))))
3783 (define-prim (println
3784 #!key (port (macro-absent-obj))
3785 #!rest body)
3786 (macro-force-vars (port)
3787 (let ((p
3788 (if (##eq? port (macro-absent-obj))
3789 (macro-current-output-port)
3790 port)))
3791 (macro-check-output-port p 2 (println port: p . body)
3792 (begin
3793 (##print-fringe body p)
3794 (##newline p))))))
3796 (define-prim (##newline port)
3797 (##declare (not interrupts-enabled))
3798 ((macro-port-newline port) port))
3800 (define-prim (newline
3801 #!optional
3802 (port (macro-absent-obj)))
3803 (macro-force-vars (port)
3804 (let ((p
3805 (if (##eq? port (macro-absent-obj))
3806 (macro-current-output-port)
3807 port)))
3808 (macro-check-output-port p 1 (newline p)
3809 (##newline p)))))
3811 (define-prim (##flush-input-buffering port)
3812 (##declare (not interrupts-enabled))
3813 (macro-character-port-peek-eof?-set! port #f)
3814 (macro-character-port-rlo-set! port (macro-character-port-rhi port))
3815 (if (macro-byte-input-port? port)
3816 (macro-byte-port-rlo-set! port (macro-byte-port-rhi port)))
3817 (##void))
3819 (define-prim (##force-output
3820 port
3821 #!optional
3822 (level (macro-absent-obj)))
3823 (##declare (not interrupts-enabled))
3824 ((macro-port-force-output port)
3825 port
3826 (if (##eq? level (macro-absent-obj)) 0 level)
3827 force-output
3828 port
3829 level
3830 (macro-absent-obj)
3831 (macro-absent-obj)))
3833 (define-prim (force-output
3834 #!optional
3835 (port (macro-absent-obj))
3836 (level (macro-absent-obj)))
3837 (macro-force-vars (port level)
3838 (let ((p
3839 (if (##eq? port (macro-absent-obj))
3840 (macro-current-output-port)
3841 port)))
3842 (macro-check-output-port
3843 p
3844 1
3845 (force-output p level)
3846 (if (##eq? level (macro-absent-obj))
3847 (##force-output p)
3848 (macro-check-index-range-incl
3849 level
3850 2
3851 0
3852 2
3853 (force-output p level)
3854 (##force-output p level)))))))
3856 (define-prim (##close-input-port port)
3857 (##declare (not interrupts-enabled))
3858 ((macro-port-close port) port close-input-port port))
3860 (define-prim (close-input-port port)
3861 (macro-force-vars (port)
3862 (macro-check-input-port port 1 (close-input-port port)
3863 (##close-input-port port))))
3865 (define-prim (##close-output-port port)
3866 (##declare (not interrupts-enabled))
3867 ((macro-port-close port) port close-output-port port))
3869 (define-prim (close-output-port port)
3870 (macro-force-vars (port)
3871 (macro-check-output-port port 1 (close-output-port port)
3872 (##close-output-port port))))
3874 (define-prim (##close-port port)
3875 (##declare (not interrupts-enabled))
3876 ((macro-port-close port) port close-port port))
3878 (define-prim (close-port port)
3879 (macro-force-vars (port)
3880 (macro-check-port port 1 (close-port port)
3881 (##close-port port))))
3883 (define-prim (input-port-readtable port)
3884 (macro-force-vars (port)
3885 (macro-check-character-input-port port 1 (input-port-readtable port)
3886 (macro-character-port-input-readtable port))))
3888 (define-prim (input-port-readtable-set! port rt)
3889 (macro-force-vars (port rt)
3890 (macro-check-character-input-port port 1 (input-port-readtable-set! port rt)
3891 (macro-check-readtable rt 2 (input-port-readtable-set! port rt)
3892 (begin
3893 (macro-character-port-input-readtable-set! port rt)
3894 (##void))))))
3896 (define-prim (output-port-readtable port)
3897 (macro-force-vars (port)
3898 (macro-check-character-output-port port 1 (output-port-readtable port)
3899 (macro-character-port-output-readtable port))))
3901 (define-prim (output-port-readtable-set! port rt)
3902 (macro-force-vars (port rt)
3903 (macro-check-character-output-port port 1 (output-port-readtable-set! port rt)
3904 (macro-check-readtable rt 2 (output-port-readtable-set! port rt)
3905 (begin
3906 (macro-character-port-output-readtable-set! port rt)
3907 (##void))))))
3909 (define-prim (##input-port-timeout-set! port absrel-timeout thunk)
3910 (##declare (not interrupts-enabled))
3911 (let ((timeout (##absrel-timeout->timeout absrel-timeout)))
3912 ((macro-port-set-rtimeout port) port timeout thunk)))
3914 (define-prim (input-port-timeout-set!
3915 port
3916 absrel-timeout
3917 #!optional
3918 (t (macro-absent-obj)))
3919 (macro-force-vars (port absrel-timeout t)
3920 (let ((thunk
3921 (if (##eq? t (macro-absent-obj))
3922 (lambda () #f)
3923 t)))
3924 (macro-check-input-port
3925 port
3926 1
3927 (input-port-timeout-set! port absrel-timeout t)
3928 (macro-check-absrel-time-or-false
3929 absrel-timeout
3930 2
3931 (input-port-timeout-set! port absrel-timeout t)
3932 (macro-check-procedure
3933 thunk
3934 3
3935 (input-port-timeout-set! port absrel-timeout t)
3936 (##input-port-timeout-set! port absrel-timeout thunk)))))))
3938 (define-prim (##output-port-timeout-set! port absrel-timeout thunk)
3939 (##declare (not interrupts-enabled))
3940 (let ((timeout (##absrel-timeout->timeout absrel-timeout)))
3941 ((macro-port-set-wtimeout port) port timeout thunk)))
3943 (define-prim (output-port-timeout-set!
3944 port
3945 absrel-timeout
3946 #!optional
3947 (t (macro-absent-obj)))
3948 (macro-force-vars (port absrel-timeout t)
3949 (let ((thunk
3950 (if (##eq? t (macro-absent-obj))
3951 (lambda () #f)
3952 t)))
3953 (macro-check-output-port
3954 port
3955 1
3956 (output-port-timeout-set! port absrel-timeout t)
3957 (macro-check-absrel-time-or-false
3958 absrel-timeout
3959 2
3960 (output-port-timeout-set! port absrel-timeout t)
3961 (macro-check-procedure
3962 thunk
3963 3
3964 (output-port-timeout-set! port absrel-timeout t)
3965 (##output-port-timeout-set! port absrel-timeout thunk)))))))
3967 (define-prim (##input-port-char-position port)
3968 (##fixnum.+ (macro-character-port-rchars port)
3969 (macro-character-port-rlo port)))
3971 (define-prim (input-port-char-position port)
3972 (macro-force-vars (port)
3973 (macro-check-character-input-port
3974 port
3975 1
3976 (input-port-char-position port)
3977 (##input-port-char-position port))))
3979 (define-prim (##output-port-char-position port)
3980 (##fixnum.+ (macro-character-port-wchars port)
3981 (macro-character-port-whi port)))
3983 (define-prim (output-port-char-position port)
3984 (macro-force-vars (port)
3985 (macro-check-character-output-port
3986 port
3987 1
3988 (output-port-char-position port)
3989 (##output-port-char-position port))))
3991 (define-prim (##input-port-line-set! port line)
3992 (##declare (not interrupts-enabled))
3993 (macro-character-port-rlines-set! port (##fixnum.- line 1)))
3995 (define-prim (##input-port-line port)
3996 (##declare (not interrupts-enabled))
3997 (##fixnum.+ (macro-character-port-rlines port) 1))
3999 (define-prim (input-port-line port)
4000 (macro-force-vars (port)
4001 (macro-check-character-input-port port 1 (input-port-line port)
4002 (##input-port-line port))))
4004 (define-prim (##input-port-column-set! port col)
4005 (##declare (not interrupts-enabled))
4006 (macro-character-port-rcurline-set!
4007 port
4008 (##fixnum.+ (##fixnum.- (##fixnum.+ (macro-character-port-rchars port)
4009 (macro-character-port-rlo port))
4010 col)
4011 1)))
4013 (define-prim (##input-port-column port)
4014 (##declare (not interrupts-enabled))
4015 (##fixnum.+ (##fixnum.- (##fixnum.+ (macro-character-port-rchars port)
4016 (macro-character-port-rlo port))
4017 (macro-character-port-rcurline port))
4018 1))
4020 (define-prim (input-port-column port)
4021 (macro-force-vars (port)
4022 (macro-check-character-input-port port 1 (input-port-column port)
4023 (##input-port-column port))))
4025 (define-prim (##output-port-line-set! port line)
4026 (##declare (not interrupts-enabled))
4027 (macro-character-port-wlines-set! port (##fixnum.- line 1)))
4029 (define-prim (##output-port-line port)
4030 (##declare (not interrupts-enabled))
4031 (##fixnum.+ (macro-character-port-wlines port) 1))
4033 (define-prim (output-port-line port)
4034 (macro-force-vars (port)
4035 (macro-check-character-output-port port 1 (output-port-line port)
4036 (##output-port-line port))))
4038 (define-prim (##output-port-column-set! port col)
4039 (##declare (not interrupts-enabled))
4040 (macro-character-port-wcurline-set!
4041 port
4042 (##fixnum.+ (##fixnum.- (##fixnum.+ (macro-character-port-wchars port)
4043 (macro-character-port-whi port))
4044 col)
4045 1)))
4047 (define-prim (##output-port-column port)
4048 (##declare (not interrupts-enabled))
4049 (##fixnum.+ (##fixnum.- (##fixnum.+ (macro-character-port-wchars port)
4050 (macro-character-port-whi port))
4051 (macro-character-port-wcurline port))
4052 1))
4054 (define-prim (output-port-column port)
4055 (macro-force-vars (port)
4056 (macro-check-character-output-port port 1 (output-port-column port)
4057 (##output-port-column port))))
4059 (define-prim (##output-port-width port)
4060 (##declare (not interrupts-enabled))
4061 ((macro-character-port-output-width port) port))
4063 (define-prim (output-port-width port)
4064 (macro-force-vars (port)
4065 (macro-check-character-output-port port 1 (output-port-width port)
4066 (##output-port-width port))))
4068 (define-prim (##object->truncated-string obj max-length)
4069 (let* ((port
4070 (##open-output-string))
4071 (we
4072 (##make-writeenv
4073 'write
4074 port
4075 (macro-character-port-output-readtable port)
4076 #f
4077 (macro-if-forces #t #f)
4078 0
4079 0
4080 0
4081 0
4082 max-length)))
4083 (##wr we obj)
4084 (##get-output-string port)))
4086 (define-prim (##object->string obj #!optional (max-length ##max-fixnum))
4087 (if (##fixnum.< 0 max-length)
4088 (let ((str
4089 (##object->truncated-string
4090 obj
4091 (if (##fixnum.< max-length ##max-fixnum)
4092 (##fixnum.+ max-length 1)
4093 ##max-fixnum))))
4094 (##string->limited-string str max-length))
4095 (##string)))
4097 (define-prim (object->string obj #!optional (m (macro-absent-obj)))
4098 (macro-force-vars (obj m)
4099 (if (##eq? m (macro-absent-obj))
4100 (##object->string obj)
4101 (let ()
4103 (define (type-error)
4104 (##fail-check-exact-integer 2 object->string obj m))
4106 (define (range-error)
4107 (##raise-range-exception 2 object->string obj m))
4109 (if (macro-exact-int? m)
4110 (if (or (##not (##fixnum? m)) (##fixnum.negative? m))
4111 (range-error)
4112 (##object->string obj m))
4113 (type-error))))))
4115 (define-prim (##string->limited-string str max-length)
4116 (if (##fixnum.< max-length (##string-length str))
4117 (##force-limited-string! (##substring str 0 max-length) max-length)
4118 str))
4120 (define-prim (##force-limited-string! str max-length)
4121 (if (##fixnum.< 0 max-length)
4122 (begin
4123 (##string-set! str (##fixnum.- max-length 1) #\.)
4124 (if (##fixnum.< 1 max-length)
4125 (begin
4126 (##string-set! str (##fixnum.- max-length 2) #\.)
4127 (if (##fixnum.< 2 max-length)
4128 (##string-set! str (##fixnum.- max-length 3) #\.))))))
4129 (##string-shrink! str max-length)
4130 str)
4132 ;;;----------------------------------------------------------------------------
4134 ;;; Implementation of generic char port procedures.
4136 (define-prim (##input-port-characters-buffered port)
4138 (##declare (not interrupts-enabled))
4140 (macro-port-mutex-lock! port) ;; get exclusive access to port
4142 (let* ((char-rlo
4143 (macro-character-port-rlo port))
4144 (char-rhi
4145 (macro-character-port-rhi port))
4146 (characters-buffered
4147 (if (macro-character-port-peek-eof? port)
4148 1
4149 (##fixnum.- char-rhi char-rlo))))
4150 (macro-port-mutex-unlock! port)
4151 characters-buffered))
4153 (define-prim (input-port-characters-buffered port)
4154 (macro-force-vars (port)
4155 (macro-check-character-input-port
4156 port
4157 1
4158 (input-port-characters-buffered port)
4159 (##input-port-characters-buffered port))))
4161 (define-prim (##char-ready? port)
4163 (##declare (not interrupts-enabled))
4165 (macro-port-mutex-lock! port) ;; get exclusive access to port
4167 (if (macro-character-port-peek-eof? port)
4169 (begin
4170 (macro-port-mutex-unlock! port)
4171 #t)
4173 (let ((char-rlo (macro-character-port-rlo port))
4174 (char-rhi (macro-character-port-rhi port)))
4175 (if (##fixnum.< char-rlo char-rhi)
4176 (begin
4177 (macro-port-mutex-unlock! port)
4178 #t)
4179 (let ((code ((macro-character-port-rbuf-fill port)
4180 port
4181 1
4182 #f)))
4183 (if (##fixnum? code)
4184 (if (##fixnum.= code ##err-code-EAGAIN)
4185 (begin
4186 (macro-port-mutex-unlock! port)
4187 #f) ;; a call to read-char would block
4188 (begin
4189 (macro-port-mutex-unlock! port)
4190 (##raise-os-exception #f code char-ready? port)))
4191 (begin
4192 (if (##not code)
4193 (macro-character-port-peek-eof?-set! port #t))
4194 (macro-port-mutex-unlock! port)
4195 #t)))))))
4197 (define-prim (char-ready?
4198 #!optional
4199 (port (macro-absent-obj)))
4200 (macro-force-vars (port)
4201 (let ((p
4202 (if (##eq? port (macro-absent-obj))
4203 (macro-current-input-port)
4204 port)))
4205 (macro-check-character-input-port p 1 (char-ready? p)
4206 (##char-ready? p)))))
4208 (define-prim (##peek-char port)
4210 (##declare (not interrupts-enabled))
4212 (macro-port-mutex-lock! port) ;; get exclusive access to port
4214 (let loop ()
4216 (let ((char-rlo (macro-character-port-rlo port))
4217 (char-rhi (macro-character-port-rhi port)))
4218 (if (##fixnum.< char-rlo char-rhi)
4220 ;; the next character is in the character read buffer
4222 (let ((c (##string-ref (macro-character-port-rbuf port) char-rlo)))
4223 (macro-port-mutex-unlock! port)
4224 c)
4226 (if (macro-character-port-peek-eof? port)
4228 (begin
4229 (macro-port-mutex-unlock! port)
4230 #!eof)
4232 ;; try to get more characters into the character read
4233 ;; buffer, and try again if successful otherwise
4234 ;; signal an error or return end-of-file object
4236 (let ((code ((macro-character-port-rbuf-fill port)
4237 port
4238 1
4239 #t)))
4241 (cond ((##fixnum? code)
4243 ;; the conversion or read caused an error
4245 (if (##fixnum.= code ##err-code-EAGAIN)
4246 (begin
4247 (macro-character-port-peek-eof?-set! port #t)
4248 (macro-port-mutex-unlock! port)
4249 #!eof) ;; the read timeout thunk returned #f
4250 (begin
4251 (macro-port-mutex-unlock! port)
4252 (##raise-os-exception #f code peek-char port))))
4254 (code
4256 ;; some characters were added to char buffer
4258 (loop))
4260 (else
4262 ;; no characters were added to char buffer
4264 (macro-character-port-peek-eof?-set! port #t)
4265 (macro-port-mutex-unlock! port)
4266 #!eof))))))))
4268 (define-prim (peek-char
4269 #!optional
4270 (port (macro-absent-obj)))
4271 (macro-force-vars (port)
4272 (let ((p
4273 (if (##eq? port (macro-absent-obj))
4274 (macro-current-input-port)
4275 port)))
4276 (macro-check-character-input-port p 1 (peek-char p)
4277 (##peek-char p)))))
4279 (define-prim (##read-char port)
4281 (##declare (not interrupts-enabled))
4283 (macro-port-mutex-lock! port) ;; get exclusive access to port
4285 (let loop ()
4287 (let ((char-rlo (macro-character-port-rlo port))
4288 (char-rhi (macro-character-port-rhi port)))
4289 (if (##fixnum.< char-rlo char-rhi)
4291 ;; the next character is in the character read buffer
4293 (let ((c (##string-ref (macro-character-port-rbuf port) char-rlo)))
4294 (if (##not (##char=? c #\newline))
4296 ;; frequent simple case, just advance rlo
4298 (begin
4299 (macro-character-port-rlo-set! port (##fixnum.+ char-rlo 1))
4300 (macro-port-mutex-unlock! port)
4301 c)
4303 ;; end-of-line processing requires updating counters
4305 (let ((char-rlo+1 (##fixnum.+ char-rlo 1)))
4307 ;; advance rlo
4309 (macro-character-port-rlo-set! port char-rlo+1)
4311 ;; keep track of number of characters read
4313 (let ((char-rchars (macro-character-port-rchars port)))
4314 (macro-character-port-rcurline-set! port
4315 (##fixnum.+ char-rchars char-rlo+1)))
4317 ;; keep track of number of lines read
4319 (let ((char-rlines (macro-character-port-rlines port)))
4320 (macro-character-port-rlines-set! port
4321 (##fixnum.+ char-rlines 1)))
4323 (macro-port-mutex-unlock! port)
4324 #\newline)))
4326 (if (macro-character-port-peek-eof? port)
4328 (begin
4329 (macro-character-port-peek-eof?-set! port #f)
4330 (macro-port-mutex-unlock! port)
4331 #!eof)
4333 ;; try to get more characters into the character read
4334 ;; buffer, and try again if successful otherwise
4335 ;; signal an error or return end-of-file object
4337 (let ((code ((macro-character-port-rbuf-fill port)
4338 port
4339 1
4340 #t)))
4342 (cond ((##fixnum? code)
4344 ;; the conversion or read caused an error
4346 (macro-port-mutex-unlock! port)
4347 (if (##fixnum.= code ##err-code-EAGAIN)
4348 #!eof ;; the read timeout thunk returned #f
4349 (##raise-os-exception #f code read-char port)))
4351 (code
4353 ;; some characters were added to char buffer
4355 (loop))
4357 (else
4359 ;; no characters were added to char buffer
4361 (macro-port-mutex-unlock! port)
4362 #!eof))))))))
4364 (define-prim (read-char
4365 #!optional
4366 (port (macro-absent-obj)))
4367 (macro-force-vars (port)
4368 (let ((p
4369 (if (##eq? port (macro-absent-obj))
4370 (macro-current-input-port)
4371 port)))
4372 (macro-check-character-input-port p 1 (read-char p)
4373 (##read-char p)))))
4375 (define-prim (##read-substring
4376 str
4377 start
4378 end
4379 port
4380 #!optional
4381 (need (macro-absent-obj)))
4383 (##declare (not interrupts-enabled))
4385 (let loop ((n 0))
4386 (let ((remaining (##fixnum.- end (##fixnum.+ start n))))
4387 (if (##not (##fixnum.< 0 remaining))
4388 (begin
4389 (macro-port-mutex-unlock! port)
4390 n)
4391 (let* ((char-rlo
4392 (macro-character-port-rlo port))
4393 (char-rhi
4394 (macro-character-port-rhi port))
4395 (chars-buffered
4396 (##fixnum.- char-rhi char-rlo)))
4397 (if (##fixnum.< 0 chars-buffered)
4399 (let* ((to-transfer
4400 (##fixnum.min remaining chars-buffered))
4401 (limit
4402 (##fixnum.+ char-rlo to-transfer))
4403 (char-rbuf
4404 (macro-character-port-rbuf port)))
4405 (macro-character-port-rlo-set! port limit)
4406 (##substring-move!
4407 char-rbuf
4408 char-rlo
4409 limit
4410 str
4411 (##fixnum.+ start n))
4412 (let loop2 ((rlo char-rlo))
4413 (if (##fixnum.< rlo limit)
4414 (let ((c (##string-ref char-rbuf rlo))
4415 (rlo+1 (##fixnum.+ rlo 1)))
4417 (if (##char=? c #\newline)
4418 (begin
4420 ;; keep track of number of characters read
4422 (let ((char-rchars
4423 (macro-character-port-rchars port)))
4424 (macro-character-port-rcurline-set! port
4425 (##fixnum.+ char-rchars rlo+1)))
4427 ;; keep track of number of lines read
4429 (let ((char-rlines
4430 (macro-character-port-rlines port)))
4431 (macro-character-port-rlines-set! port
4432 (##fixnum.+ char-rlines 1)))))
4434 (loop2 rlo+1))))
4435 (loop (##fixnum.+ n to-transfer)))
4437 (let ((code
4438 ((macro-character-port-rbuf-fill port)
4439 port
4440 remaining
4441 (or (##not (##fixnum? need))
4442 (##fixnum.< n need)))))
4443 (cond ((##fixnum? code)
4445 ;; an error occurred, signal an error if no
4446 ;; chars were previously transferred from char
4447 ;; buffer and (in the case of a read timeout)
4448 ;; the timeout thunk returned #f
4450 (macro-port-mutex-unlock! port)
4452 (if (or (##fixnum.< 0 n)
4453 (##fixnum.= code ##err-code-EAGAIN))
4454 n
4455 (##raise-os-exception
4456 #f
4457 code
4458 read-substring
4459 str
4460 start
4461 end
4462 port
4463 need)))
4465 (code
4467 ;; chars were added to char buffer, so try again
4468 ;; to transfer chars from the char buffer
4470 (loop n))
4472 (else
4474 ;; no chars were added to char buffer
4475 ;; (end-of-file was reached)
4477 (macro-port-mutex-unlock! port)
4478 n)))))))))
4480 (define-prim (read-substring
4481 str
4482 start
4483 end
4484 #!optional
4485 (port (macro-absent-obj))
4486 (need (macro-absent-obj)))
4487 (macro-force-vars (str start end port need)
4488 (let ((p
4489 (if (##eq? port (macro-absent-obj))
4490 (macro-current-input-port)
4491 port)))
4492 (macro-check-string
4493 str
4494 1
4495 (read-substring str start end port need)
4496 (macro-check-index-range-incl
4497 start
4498 2
4499 0
4500 (##string-length str)
4501 (read-substring str start end port need)
4502 (macro-check-index-range-incl
4503 end
4504 3
4505 start
4506 (##string-length str)
4507 (read-substring str start end port need)
4508 (macro-check-character-input-port
4509 p
4510 4
4511 (read-substring str start end port need)
4512 (if (##eq? need (macro-absent-obj))
4513 (##read-substring str start end p)
4514 (macro-check-index
4515 need
4516 5
4517 (read-substring str start end port need)
4518 (##read-substring str start end p need))))))))))
4520 (define-prim (##read-line port separator include-separator? max-length)
4522 (define max-chunk-length 512)
4524 (define (read-chunk i ml)
4525 (if (##char? separator)
4526 (let loop ((i i))
4527 (if (##fixnum.< i ml)
4528 (let ((c (macro-read-char port)))
4529 (if (##char? c)
4530 (if (##eq? c separator)
4531 (if include-separator?
4532 (let ((s (##make-string (##fixnum.+ i 1))))
4533 (##string-set! s i c)
4534 s)
4535 (##make-string i))
4536 (let ((s (loop (##fixnum.+ i 1))))
4537 (##string-set! s i c)
4538 s))
4539 (##make-string i)))
4540 (##make-string i)))
4541 (let ((s (##make-string ml)))
4542 (let ((n (##read-substring s i ml port #f)))
4543 (##string-shrink! s (##fixnum.+ i n))
4544 s))))
4546 (if (##fixnum.< 0 max-length)
4547 (let ((first (macro-read-char port)))
4549 (define (start)
4550 (let* ((ml max-length)
4551 (m1 (##fixnum.min ml max-chunk-length))
4552 (chunk1 (read-chunk 1 m1)))
4553 (##string-set! chunk1 0 first)
4554 (if (or (##fixnum.< (##string-length chunk1) m1)
4555 (##eq? (##string-ref chunk1 (##fixnum.- m1 1))
4556 separator)
4557 (##fixnum.= ml m1))
4558 chunk1
4559 (let loop ((ml (##fixnum.- ml m1))
4560 (chunks (##list chunk1)))
4561 (let* ((m2 (##fixnum.min ml max-chunk-length))
4562 (new-chunk (read-chunk 0 m2))
4563 (new-chunks (##cons new-chunk chunks)))
4564 (if (or (##fixnum.< (##string-length new-chunk) m2)
4565 (##eq? (##string-ref new-chunk (##fixnum.- m2 1))
4566 separator)
4567 (##fixnum.= ml m2))
4568 (##append-strings (##reverse new-chunks))
4569 (loop (##fixnum.- ml m2)
4570 new-chunks)))))))
4572 (if (##char? first)
4573 (if (##eq? first separator)
4574 (if include-separator?
4575 (##string first)
4576 (##string))
4577 (start))
4578 first))
4579 (##string)))
4581 (define-prim (read-line
4582 #!optional
4583 (port (macro-absent-obj))
4584 (separator (macro-absent-obj))
4585 (include-separator? (macro-absent-obj))
4586 (max-length (macro-absent-obj)))
4587 (macro-force-vars (port separator include-separator? max-length)
4588 (let ((p
4589 (if (##eq? port (macro-absent-obj))
4590 (macro-current-input-port)
4591 port))
4592 (sep
4593 (if (##eq? separator (macro-absent-obj))
4594 #\newline
4595 separator))
4596 (inc-sep?
4597 (if (##eq? include-separator? (macro-absent-obj))
4598 #f
4599 include-separator?))
4600 (ml
4601 (if (##eq? max-length (macro-absent-obj))
4602 ##max-fixnum
4603 max-length)))
4604 (macro-check-character-input-port
4605 p
4606 1
4607 (read-line port separator include-separator? max-length)
4608 (macro-check-index
4609 ml
4610 4
4611 (read-line port separator include-separator? max-length)
4612 (##read-line p sep inc-sep? ml))))))
4614 (define-prim (##read-all port-or-readenv reader)
4615 (let ((fifo (macro-make-fifo)))
4616 (let loop ()
4617 (let ((obj (reader port-or-readenv)))
4618 (if (##eof-object? obj)
4619 (macro-fifo->list fifo)
4620 (begin
4621 (macro-fifo-insert-at-tail! fifo obj)
4622 (loop)))))))
4624 (define-prim (read-all
4625 #!optional
4626 (port (macro-absent-obj))
4627 (reader (macro-absent-obj)))
4628 (macro-force-vars (port reader)
4629 (let ((p
4630 (if (##eq? port (macro-absent-obj))
4631 (macro-current-input-port)
4632 port))
4633 (r
4634 (if (##eq? reader (macro-absent-obj))
4635 ##read
4636 reader)))
4637 (macro-check-input-port p 1 (read-all port reader)
4638 (macro-check-procedure r 2 (read-all port r)
4639 (##read-all p r))))))
4641 (define-prim (##read-all-as-a-begin-expr-from-path
4642 path
4643 readtable
4644 wrap
4645 unwrap)
4647 (define (fail)
4648 (##fail-check-string 1 open-input-file path))
4650 (##make-input-path-psettings
4651 (##list 'path: path)
4652 fail
4653 (lambda (psettings)
4654 (let ((path (macro-psettings-path psettings)))
4655 (if (##not path)
4656 (fail)
4657 (##read-all-as-a-begin-expr-from-psettings
4658 psettings
4659 path
4660 readtable
4661 wrap
4662 unwrap))))))
4664 (define-prim (##read-all-as-a-begin-expr-from-psettings
4665 psettings
4666 path-or-settings
4667 readtable
4668 wrap
4669 unwrap)
4671 (define (fail)
4672 (##fail-check-string-or-settings 1 open-input-file path-or-settings))
4674 (let ((path (macro-psettings-path psettings)))
4675 (if (##not path)
4676 (fail)
4677 (##open-file-generic-from-psettings
4678 psettings
4679 #f
4680 (lambda (port)
4681 (if (##fixnum? port)
4682 port
4683 (let* ((extension
4684 (##path-extension path))
4685 (start-syntax
4686 (let ((x (##assoc extension ##scheme-file-extensions)))
4687 (if x
4688 (##cdr x)
4689 (macro-readtable-start-syntax readtable)))))
4690 (##read-all-as-a-begin-expr-from-port
4691 port
4692 readtable
4693 wrap
4694 unwrap
4695 start-syntax
4696 #t))))
4697 open-input-file
4698 path-or-settings))))
4700 (define-prim (##read-all-as-a-begin-expr-from-port
4701 port
4702 readtable
4703 wrap
4704 unwrap
4705 start-syntax
4706 close-port?)
4707 (##with-exception-catcher
4708 (lambda (exc)
4709 (if close-port?
4710 (##close-input-port port))
4711 (macro-raise exc))
4712 (lambda ()
4713 (let ((rt
4714 (##readtable-copy-shallow readtable)))
4715 (macro-readtable-start-syntax-set! rt start-syntax)
4716 (let* ((re
4717 (##make-readenv port rt wrap unwrap 'script))
4718 (head
4719 (##cons (wrap re '##begin)
4720 '())) ;; tail will be replaced with expressions read
4721 (expr
4722 (wrap re head))
4723 (first
4724 (##read-datum-or-eof re))
4725 (script-line
4726 (and (##eq? first (##script-marker))
4727 (##read-line port #\newline #f ##max-fixnum)))
4728 (language-and-tail
4729 (##extract-language-and-tail script-line)))
4730 (if language-and-tail
4731 (let ((language (##car language-and-tail)))
4732 (##readtable-setup-for-language! rt language)))
4733 (let* ((rest
4734 (if (##eof-object? first)
4735 '()
4736 (##read-all re ##read-datum-or-eof)))
4737 (port-name
4738 (##port-name port)))
4739 (if close-port?
4740 (##close-input-port port))
4741 (cond ((##eof-object? first)
4742 (##vector #f expr port-name))
4743 ((##eq? first (##script-marker))
4744 (##set-cdr! head rest)
4745 (##vector script-line expr port-name))
4746 (else
4747 (##set-cdr! head (##cons first rest))
4748 (##vector #f expr port-name)))))))))
4750 (define-prim (##write-char c port)
4752 (##declare (not interrupts-enabled))
4754 (macro-port-mutex-lock! port) ;; get exclusive access to port
4756 (let loop ()
4758 (let ((char-wbuf (macro-character-port-wbuf port))
4759 (char-whi+1 (##fixnum.+ (macro-character-port-whi port) 1)))
4760 (if (##not (##fixnum.< (##string-length char-wbuf) char-whi+1))
4762 ;; there is enough space in the character write buffer, so add
4763 ;; character and increment whi
4765 (let ()
4767 (##string-set! char-wbuf (##fixnum.- char-whi+1 1) c)
4769 ;; advance whi
4771 (macro-character-port-whi-set! port char-whi+1)
4773 (if (##not (##char=? c #\newline))
4775 ;; force output if port is set for unbuffered output
4777 (if (macro-unbuffered? (macro-port-woptions port))
4778 (begin
4779 (macro-port-mutex-unlock! port)
4780 ((macro-port-force-output port)
4781 port
4782 0
4783 write-char
4784 c
4785 port
4786 (macro-absent-obj)
4787 (macro-absent-obj)))
4788 (begin
4789 (macro-port-mutex-unlock! port)
4790 (##void)))
4792 ;; end-of-line processing requires updating counters
4794 (begin
4796 ;; keep track of number of characters written
4798 (let ((char-wchars (macro-character-port-wchars port)))
4799 (macro-character-port-wcurline-set! port
4800 (##fixnum.+ char-wchars char-whi+1)))
4802 ;; keep track of number of lines written
4804 (let ((char-wlines (macro-character-port-wlines port)))
4805 (macro-character-port-wlines-set! port
4806 (##fixnum.+ char-wlines 1)))
4808 ;; force output if port is not fully buffered
4810 (if (##not (macro-fully-buffered?
4811 (macro-port-woptions port)))
4812 (begin
4813 (macro-port-mutex-unlock! port)
4814 ((macro-port-force-output port)
4815 port
4816 0
4817 write-char
4818 c
4819 port
4820 (macro-absent-obj)
4821 (macro-absent-obj)))
4822 (begin
4823 (macro-port-mutex-unlock! port)
4824 (##void))))))
4826 ;; make some space in the character buffer and try again
4828 (let ((code3 ((macro-character-port-wbuf-drain port) port)))
4829 (if (##fixnum? code3)
4830 (begin
4831 (macro-port-mutex-unlock! port)
4832 (if (##fixnum.= code3 ##err-code-EAGAIN)
4833 #f
4834 (##raise-os-exception #f code3 write-char c port)))
4835 (loop)))))))
4837 (define-prim (write-char
4838 c
4839 #!optional
4840 (port (macro-absent-obj)))
4841 (macro-force-vars (c port)
4842 (let ((p
4843 (if (##eq? port (macro-absent-obj))
4844 (macro-current-output-port)
4845 port)))
4846 (macro-check-char c 1 (write-char c port)
4847 (macro-check-character-output-port p 2 (write-char c p)
4848 (##write-char c p))))))
4850 (define-prim (##write-substring str start end port)
4851 (##declare (not interrupts-enabled))
4852 (let loop ((i start))
4853 (if (##fixnum.< i end)
4854 (begin
4855 (macro-write-char (##string-ref str i) port)
4856 (let ()
4857 (##declare (interrupts-enabled))
4858 (loop (##fixnum.+ i 1)))))))
4860 (define-prim (write-substring
4861 str
4862 start
4863 end
4864 #!optional
4865 (port (macro-absent-obj)))
4866 (macro-force-vars (str start end port)
4867 (let ((p
4868 (if (##eq? port (macro-absent-obj))
4869 (macro-current-output-port)
4870 port)))
4871 (macro-check-string str 1 (write-substring str start end port)
4872 (macro-check-index-range-incl
4873 start
4874 2
4875 0
4876 (##string-length str)
4877 (write-substring str start end port)
4878 (macro-check-index-range-incl
4879 end
4880 3
4881 start
4882 (##string-length str)
4883 (write-substring str start end port)
4884 (macro-check-character-output-port
4885 p
4886 4
4887 (write-substring str start end p)
4888 (##write-substring str start end p))))))))
4890 (define-prim (##write-string str port)
4891 (##declare (not interrupts-enabled))
4892 (##write-substring str 0 (##string-length str) port))
4894 ;;;----------------------------------------------------------------------------
4896 ;;; Implementation of generic byte port procedures.
4898 (##define-macro (macro-lock-and-check-input-port-character-buffer-empty
4899 port
4900 form
4901 expr)
4902 `(begin
4904 (macro-port-mutex-lock! ,port) ;; get exclusive access to port
4906 (if (or (##fixnum.< (macro-character-port-rlo ,port)
4907 (macro-character-port-rhi ,port))
4908 (macro-character-port-peek-eof? ,port))
4910 (begin
4911 (macro-port-mutex-unlock! ,port)
4912 (##raise-nonempty-input-port-character-buffer-exception ,@form))
4914 ,expr)))
4916 (define-prim (##input-port-bytes-buffered port)
4918 (##declare (not interrupts-enabled))
4920 (macro-port-mutex-lock! port) ;; get exclusive access to port
4922 (let* ((byte-rlo
4923 (macro-byte-port-rlo port))
4924 (byte-rhi
4925 (macro-byte-port-rhi port))
4926 (bytes-buffered
4927 (##fixnum.- byte-rhi byte-rlo)))
4928 (macro-port-mutex-unlock! port)
4929 bytes-buffered))
4931 (define-prim (input-port-bytes-buffered port)
4932 (macro-force-vars (port)
4933 (macro-check-byte-input-port
4934 port
4935 1
4936 (input-port-bytes-buffered port)
4937 (##input-port-bytes-buffered port))))
4939 (define-prim (##read-u8 port)
4941 (##declare (not interrupts-enabled))
4943 (macro-lock-and-check-input-port-character-buffer-empty
4944 port
4945 (read-u8 port)
4946 (let loop ()
4947 (let* ((byte-rlo
4948 (macro-byte-port-rlo port))
4949 (byte-rhi
4950 (macro-byte-port-rhi port)))
4951 (if (##fixnum.< byte-rlo byte-rhi)
4952 (let* ((byte-rbuf
4953 (macro-byte-port-rbuf port))
4954 (result
4955 (##u8vector-ref byte-rbuf byte-rlo)))
4956 (macro-byte-port-rlo-set! port (##fixnum.+ byte-rlo 1))
4957 (macro-port-mutex-unlock! port)
4958 result)
4959 (let ((code
4960 ((macro-byte-port-rbuf-fill port)
4961 port
4962 1
4963 #t)))
4964 (cond ((##fixnum? code)
4966 ;; an error occurred
4968 (macro-port-mutex-unlock! port)
4970 (if (##fixnum.= code ##err-code-EAGAIN)
4971 #!eof ;; the read timeout thunk returned #f
4972 (##raise-os-exception
4973 #f
4974 code
4975 read-u8
4976 port)))
4978 (code
4980 ;; bytes were added to byte buffer, so try again
4981 ;; to transfer bytes from the byte buffer
4983 (loop))
4985 (else
4987 ;; no bytes were added to byte buffer
4988 ;; (end-of-file was reached)
4990 (macro-port-mutex-unlock! port)
4991 #!eof))))))))
4993 (define-prim (read-u8
4994 #!optional
4995 (port (macro-absent-obj)))
4996 (macro-force-vars (port)
4997 (let ((p
4998 (if (##eq? port (macro-absent-obj))
4999 (macro-current-input-port)
5000 port)))
5001 (macro-check-byte-input-port
5002 p
5003 1
5004 (read-u8 p)
5005 (##read-u8 p)))))
5007 (define-prim (##read-subu8vector
5008 u8vect
5009 start
5010 end
5011 port
5012 #!optional
5013 (need (macro-absent-obj)))
5015 (##declare (not interrupts-enabled))
5017 (macro-lock-and-check-input-port-character-buffer-empty
5018 port
5019 (read-subu8vector u8vect start end port need)
5020 (let loop ((n 0))
5021 (let ((remaining (##fixnum.- end (##fixnum.+ start n))))
5022 (if (##not (##fixnum.< 0 remaining))
5023 (begin
5024 (macro-port-mutex-unlock! port)
5025 n)
5026 (let* ((byte-rlo
5027 (macro-byte-port-rlo port))
5028 (byte-rhi
5029 (macro-byte-port-rhi port))
5030 (bytes-buffered
5031 (##fixnum.- byte-rhi byte-rlo)))
5032 (if (##fixnum.< 0 bytes-buffered)
5034 (let* ((to-transfer
5035 (##fixnum.min remaining bytes-buffered))
5036 (limit
5037 (##fixnum.+ byte-rlo to-transfer))
5038 (byte-rbuf
5039 (macro-byte-port-rbuf port)))
5040 (macro-byte-port-rlo-set! port limit)
5041 (##subu8vector-move!
5042 byte-rbuf
5043 byte-rlo
5044 limit
5045 u8vect
5046 (##fixnum.+ start n))
5047 (loop (##fixnum.+ n to-transfer)))
5049 (let ((code
5050 ((macro-byte-port-rbuf-fill port)
5051 port
5052 remaining
5053 (or (##not (##fixnum? need))
5054 (##fixnum.< n need)))))
5055 (cond ((##fixnum? code)
5057 ;; an error occurred, signal an error if no
5058 ;; bytes were previously transferred from byte
5059 ;; buffer and (in the case of a read timeout)
5060 ;; the timeout thunk returned #f
5062 (macro-port-mutex-unlock! port)
5064 (if (or (##fixnum.< 0 n)
5065 (##fixnum.= code ##err-code-EAGAIN))
5066 n
5067 (##raise-os-exception
5068 #f
5069 code
5070 read-subu8vector
5071 u8vect
5072 start
5073 end
5074 port
5075 need)))
5077 (code
5079 ;; bytes were added to byte buffer, so try again
5080 ;; to transfer bytes from the byte buffer
5082 (loop n))
5084 (else
5086 ;; no bytes were added to byte buffer
5087 ;; (end-of-file was reached)
5089 (macro-port-mutex-unlock! port)
5090 n))))))))))
5092 (define-prim (read-subu8vector
5093 u8vect
5094 start
5095 end
5096 #!optional
5097 (port (macro-absent-obj))
5098 (need (macro-absent-obj)))
5099 (macro-force-vars (u8vect start end port need)
5100 (let ((p
5101 (if (##eq? port (macro-absent-obj))
5102 (macro-current-input-port)
5103 port)))
5104 (macro-check-u8vector
5105 u8vect
5106 1
5107 (read-subu8vector u8vect start end port need)
5108 (macro-check-index-range-incl
5109 start
5110 2
5111 0
5112 (##u8vector-length u8vect)
5113 (read-subu8vector u8vect start end port need)
5114 (macro-check-index-range-incl
5115 end
5116 3
5117 start
5118 (##u8vector-length u8vect)
5119 (read-subu8vector u8vect start end port need)
5120 (macro-check-byte-input-port
5121 p
5122 4
5123 (read-subu8vector u8vect start end port need)
5124 (if (##eq? need (macro-absent-obj))
5125 (##read-subu8vector u8vect start end p)
5126 (macro-check-index
5127 need
5128 5
5129 (read-subu8vector u8vect start end port need)
5130 (##read-subu8vector u8vect start end p need))))))))))
5132 (define-prim (##write-u8 b port)
5134 (##declare (not interrupts-enabled))
5136 (macro-port-mutex-lock! port) ;; get exclusive access to port
5138 (let ((code
5139 (and (##fixnum.< (macro-character-port-wlo port)
5140 (macro-character-port-whi port))
5141 ((macro-character-port-wbuf-drain port) port))))
5142 (if (##fixnum? code)
5144 (begin
5145 (macro-port-mutex-unlock! port)
5146 (##raise-os-exception
5147 #f
5148 code
5149 write-u8
5150 b
5151 port))
5153 (let loop ()
5154 (let* ((byte-whi
5155 (macro-byte-port-whi port))
5156 (byte-wbuf
5157 (macro-byte-port-wbuf port))
5158 (bytes-free
5159 (##fixnum.- (##u8vector-length byte-wbuf) byte-whi)))
5160 (if (##fixnum.< 0 bytes-free)
5161 (begin
5162 (macro-byte-port-whi-set! port (##fixnum.+ byte-whi 1))
5163 (##u8vector-set! byte-wbuf byte-whi b)
5165 ;; force output if port is set for unbuffered output
5167 (if (macro-unbuffered? (macro-port-woptions port))
5168 (begin
5169 (macro-port-mutex-unlock! port)
5170 ((macro-port-force-output port)
5171 port
5172 0
5173 write-u8
5174 b
5175 port
5176 (macro-absent-obj)
5177 (macro-absent-obj)))
5178 (begin
5179 (macro-port-mutex-unlock! port)
5180 (##void))))
5181 (let ((code ((macro-byte-port-wbuf-drain port) port)))
5182 (if (##fixnum? code)
5183 (begin
5185 ;; an error occurred
5187 (macro-port-mutex-unlock! port)
5189 (##raise-os-exception
5190 #f
5191 code
5192 write-u8
5193 b
5194 port))
5196 ;; the byte buffer was successfully drained, so try
5197 ;; again to transfer bytes to the byte buffer
5199 (loop)))))))))
5201 (define-prim (write-u8
5202 b
5203 #!optional
5204 (port (macro-absent-obj)))
5205 (macro-force-vars (b port)
5206 (let ((p
5207 (if (##eq? port (macro-absent-obj))
5208 (macro-current-output-port)
5209 port)))
5210 (macro-check-exact-unsigned-int8 b 1 (write-u8 b port)
5211 (macro-check-byte-output-port p 2 (write-u8 b p)
5212 (##write-u8 b p))))))
5214 (define-prim (##write-subu8vector u8vect start end port)
5216 (##declare (not interrupts-enabled))
5218 (macro-port-mutex-lock! port) ;; get exclusive access to port
5220 (let ((code
5221 (and (##fixnum.< (macro-character-port-wlo port)
5222 (macro-character-port-whi port))
5223 ((macro-character-port-wbuf-drain port) port))))
5224 (if (##fixnum? code)
5226 (begin
5227 (macro-port-mutex-unlock! port)
5228 (if (##fixnum.= code ##err-code-EAGAIN)
5229 0
5230 (##raise-os-exception
5231 #f
5232 code
5233 write-subu8vector
5234 u8vect
5235 start
5236 end
5237 port)))
5239 (let loop1 ((n 0))
5240 (let ((remaining (##fixnum.- end (##fixnum.+ start n))))
5241 (if (##not (##fixnum.< 0 remaining))
5242 (begin
5244 ;; force output if port is set for unbuffered output
5246 (if (and (##fixnum.< start end)
5247 (macro-unbuffered? (macro-port-woptions port)))
5248 (begin
5249 (macro-port-mutex-unlock! port)
5250 ((macro-port-force-output port)
5251 port
5252 0
5253 write-subu8vector
5254 u8vect
5255 start
5256 end
5257 port))
5258 (macro-port-mutex-unlock! port))
5260 n)
5261 (let* ((byte-whi
5262 (macro-byte-port-whi port))
5263 (byte-wbuf
5264 (macro-byte-port-wbuf port))
5265 (bytes-free
5266 (##fixnum.- (##u8vector-length byte-wbuf) byte-whi)))
5267 (if (##fixnum.< 0 bytes-free)
5268 (let* ((to-transfer
5269 (##fixnum.min remaining bytes-free))
5270 (limit
5271 (##fixnum.+ byte-whi to-transfer)))
5272 (macro-byte-port-whi-set! port limit)
5273 (let loop2 ((i (##fixnum.+ start n))
5274 (j byte-whi))
5275 (if (##fixnum.< j limit)
5276 (begin
5277 (##u8vector-set! byte-wbuf j (##u8vector-ref u8vect i))
5278 (loop2 (##fixnum.+ i 1)
5279 (##fixnum.+ j 1)))))
5280 (loop1 (##fixnum.+ n to-transfer)))
5281 (let ((code ((macro-byte-port-wbuf-drain port) port)))
5282 (if (##fixnum? code)
5283 (begin
5285 ;; an error occurred, signal an error if no bytes
5286 ;; were previously transferred from byte buffer
5287 ;; and (in the case of a write timeout) the
5288 ;; timeout thunk returned #f
5290 (macro-port-mutex-unlock! port)
5292 (if (or (##fixnum.< 0 n)
5293 (##fixnum.= code ##err-code-EAGAIN))
5294 n
5295 (##raise-os-exception
5296 #f
5297 code
5298 write-subu8vector
5299 u8vect
5300 start
5301 end
5302 port)))
5304 ;; the byte buffer was successfully drained, so try
5305 ;; again to transfer bytes to the byte buffer
5307 (loop1 n)))))))))))
5309 (define-prim (write-subu8vector
5310 u8vect
5311 start
5312 end
5313 #!optional
5314 (port (macro-absent-obj)))
5315 (macro-force-vars (u8vect start end port)
5316 (let ((p
5317 (if (##eq? port (macro-absent-obj))
5318 (macro-current-output-port)
5319 port)))
5320 (macro-check-u8vector u8vect 1 (write-subu8vector u8vect start end port)
5321 (macro-check-index-range-incl
5322 start
5323 2
5324 0
5325 (##u8vector-length u8vect)
5326 (write-subu8vector u8vect start end port)
5327 (macro-check-index-range-incl
5328 end
5329 3
5330 start
5331 (##u8vector-length u8vect)
5332 (write-subu8vector u8vect start end port)
5333 (macro-check-byte-output-port
5334 p
5335 4
5336 (write-subu8vector u8vect start end p)
5337 (##write-subu8vector u8vect start end p))))))))
5339 (define-prim (##options-set! port options)
5341 (##declare (not interrupts-enabled))
5343 (let* ((rdevice
5344 (if (##fixnum.= (macro-port-rkind port) (macro-none-kind))
5345 #f
5346 (macro-condvar-name (macro-device-port-rdevice-condvar port))))
5347 (wdevice
5348 (if (##fixnum.= (macro-port-wkind port) (macro-none-kind))
5349 #f
5350 (macro-condvar-name (macro-device-port-wdevice-condvar port)))))
5351 (if (##eq? rdevice wdevice)
5352 (let ((code1
5353 (##os-device-stream-options-set! rdevice options)))
5354 (if (##fixnum.< code1 0)
5355 code1
5356 (##void)))
5357 (let ((code2
5358 (if rdevice
5359 (##os-device-stream-options-set! rdevice options)
5360 0)))
5361 (if (##fixnum.< code2 0)
5362 code2
5363 (let ((code3
5364 (if wdevice
5365 (##os-device-stream-options-set! wdevice options)
5366 0)))
5367 (if (##fixnum.< code3 0)
5368 code3
5369 (##void))))))))
5371 (define-prim (##port-settings-set! port settings)
5373 (##declare (not interrupts-enabled))
5375 (define (fail)
5376 (##fail-check-settings 2 port-settings-set! port settings))
5378 (macro-lock-and-check-input-port-character-buffer-empty
5379 port
5380 (port-settings-set! port settings)
5381 (##make-psettings
5382 (macro-direction-inout)
5383 '(input-char-encoding:
5384 output-char-encoding:
5385 char-encoding:
5386 input-char-encoding-errors:
5387 output-char-encoding-errors:
5388 char-encoding-errors:
5389 input-eol-encoding:
5390 output-eol-encoding:
5391 eol-encoding:
5392 input-buffering:
5393 output-buffering:
5394 buffering:)
5395 settings
5396 fail
5397 (lambda (psettings)
5398 (let* ((old-roptions
5399 (macro-port-roptions port))
5400 (roptions
5401 (##psettings->roptions psettings
5402 old-roptions))
5403 (old-woptions
5404 (macro-port-woptions port))
5405 (woptions
5406 (##psettings->woptions psettings
5407 (##fixnum.* old-woptions
5408 (macro-stream-options-output-shift)))))
5409 (let ((code
5410 (and (macro-output-port? port)
5411 (##not (##fixnum.= woptions old-woptions))
5412 (##fixnum.< (macro-character-port-wlo port)
5413 (macro-character-port-whi port))
5414 ((macro-character-port-wbuf-drain port) port))))
5415 (if (##fixnum? code)
5417 (begin
5418 (macro-port-mutex-unlock! port)
5419 (##raise-os-exception
5420 #f
5421 code
5422 port-settings-set!
5423 port
5424 settings))
5426 (let ((result
5427 (##options-set!
5428 port
5429 (##fixnum.+ roptions
5430 (##fixnum.* woptions
5431 (macro-stream-options-output-shift))))))
5432 (if (##fixnum? result)
5433 (begin
5434 (macro-port-mutex-unlock! port)
5435 (##raise-os-exception #f result port-settings-set! port settings))
5436 (begin
5437 (macro-port-roptions-set! port roptions)
5438 (macro-port-woptions-set! port woptions)
5440 ;; change character buffers if needed
5442 (let ((rbuf (macro-character-port-rbuf port)))
5443 (if rbuf
5444 (let ((new-char-buf-len
5445 (if (macro-unbuffered? roptions)
5446 1
5447 512)))
5448 (if (##not (##fixnum.= (##string-length rbuf)
5449 new-char-buf-len))
5450 (let ((new-rbuf (##make-string new-char-buf-len)))
5451 (macro-character-port-rchars-set!
5452 port
5453 (##fixnum.+ (macro-character-port-rchars port)
5454 (macro-character-port-rlo port)))
5455 (macro-character-port-rlo-set! port 0)
5456 (macro-character-port-rhi-set! port 0)
5457 (macro-character-port-rbuf-set! port new-rbuf))))))
5459 (let ((wbuf (macro-character-port-wbuf port)))
5460 (if wbuf
5461 (let ((new-char-buf-len
5462 (if (macro-unbuffered? woptions)
5463 1
5464 512)))
5465 (if (##not (##fixnum.= (##string-length wbuf)
5466 new-char-buf-len))
5467 (let ((new-wbuf (##make-string new-char-buf-len)))
5468 (macro-character-port-rchars-set!
5469 port
5470 (##fixnum.+ (macro-character-port-wchars port)
5471 (macro-character-port-whi port)))
5472 (macro-character-port-wlo-set! port 0)
5473 (macro-character-port-whi-set! port 0)
5474 (macro-character-port-wbuf-set! port new-wbuf))))))
5476 (macro-port-mutex-unlock! port)
5477 result))))))))))
5479 (define-prim (port-settings-set! port settings)
5480 (macro-force-vars (port settings)
5481 (macro-check-byte-port
5482 port
5483 1
5484 (port-settings-set! port settings)
5485 (##port-settings-set! port settings))))
5487 ;;;----------------------------------------------------------------------------
5489 ;;; Implementation of tty device ports.
5491 (implement-check-type-tty-port)
5493 (define-prim (##tty? port)
5494 (##declare (not interrupts-enabled))
5495 (macro-tty-port? port))
5497 (define-prim (tty? port)
5498 (macro-force-vars (port)
5499 (##tty? port)))
5501 (define-prim (##tty-type-set! port term-type emacs-bindings)
5502 (let ((code
5503 (##os-device-tty-type-set!
5504 (##port-device port)
5505 term-type
5506 emacs-bindings)))
5507 (if (##fixnum.< code 0)
5508 (##raise-os-exception #f code tty-type-set! port term-type emacs-bindings)
5509 (##void))))
5511 (define-prim (tty-type-set! port term-type emacs-bindings)
5512 (macro-force-vars (port term-type emacs-bindings)
5513 (macro-check-tty-port
5514 port
5515 1
5516 (tty-type-set! port term-type emacs-bindings)
5517 (macro-check-string
5518 term-type
5519 2
5520 (tty-type-set! port term-type emacs-bindings)
5521 (##tty-type-set! port term-type emacs-bindings)))))
5523 (define-prim (##tty-text-attributes-set! port input output)
5524 (##os-device-tty-text-attributes-set! (##port-device port) input output))
5526 (define-prim (tty-text-attributes-set! port input output)
5527 (macro-force-vars (port input output)
5528 (macro-check-tty-port
5529 port
5530 1
5531 (tty-text-attributes-set! port input output)
5532 (macro-check-fixnum-range
5533 input
5534 2
5535 0
5536 1024
5537 (tty-text-attributes-set! port input output)
5538 (macro-check-fixnum-range
5539 output
5540 3
5541 0
5542 1024
5543 (tty-text-attributes-set! port input output)
5544 (##tty-text-attributes-set! port input output))))))
5546 (define-prim (##tty-history port)
5547 (let ((result (##os-device-tty-history (##port-device port))))
5548 (if (##fixnum? result)
5549 (##raise-os-exception #f result tty-history port)
5550 result)))
5552 (define-prim (tty-history port)
5553 (macro-force-vars (port)
5554 (macro-check-tty-port
5555 port
5556 1
5557 (tty-history port)
5558 (##tty-history port))))
5560 (define-prim (##tty-history-set! port history)
5561 (let ((code (##os-device-tty-history-set! (##port-device port) history)))
5562 (if (##fixnum.< code 0)
5563 (##raise-os-exception #f code tty-history-set! port history)
5564 (##void))))
5566 (define-prim (tty-history-set! port history)
5567 (macro-force-vars (port history)
5568 (macro-check-tty-port
5569 port
5570 1
5571 (tty-history-set! port history)
5572 (macro-check-string
5573 history
5574 2
5575 (tty-history-set! port history)
5576 (##tty-history-set! port history)))))
5578 (define-prim (##tty-history-max-length-set! port max-length)
5579 (##os-device-tty-history-max-length-set! (##port-device port) max-length))
5581 (define-prim (tty-history-max-length-set! port max-length)
5582 (macro-force-vars (port max-length)
5583 (macro-check-tty-port
5584 port
5585 1
5586 (tty-history-max-length-set! port max-length)
5587 (macro-check-index
5588 max-length
5589 2
5590 (tty-history-max-length-set! port max-length)
5591 (##tty-history-max-length-set! port max-length)))))
5593 (define-prim (##tty-paren-balance-duration-set! port duration)
5594 (##os-device-tty-paren-balance-duration-set! (##port-device port) duration))
5596 (define-prim (tty-paren-balance-duration-set! port duration)
5597 (macro-force-vars (port duration)
5598 (macro-check-tty-port
5599 port
5600 1
5601 (tty-paren-balance-duration-set! port duration)
5602 (macro-check-real
5603 duration
5604 2
5605 (tty-paren-balance-duration-set! port duration)
5606 (##tty-paren-balance-duration-set!
5607 port
5608 (macro-real->inexact duration))))))
5610 (define-prim (##tty-mode-set!
5611 port
5612 input-allow-special
5613 input-echo
5614 input-raw
5615 output-raw
5616 speed)
5617 (let ((code
5618 (##os-device-tty-mode-set!
5619 (##port-device port)
5620 input-allow-special
5621 input-echo
5622 input-raw
5623 output-raw
5624 speed)))
5625 (if (##fixnum.< code 0)
5626 (##raise-os-exception
5627 #f
5628 code
5629 tty-mode-set!
5630 port
5631 input-allow-special
5632 input-echo
5633 input-raw
5634 output-raw
5635 speed)
5636 (##void))))
5638 (define-prim (tty-mode-set!
5639 port
5640 input-allow-special
5641 input-echo
5642 input-raw
5643 output-raw
5644 #!optional
5645 (s (macro-absent-obj)))
5646 (macro-force-vars (port
5647 input-allow-special
5648 input-echo
5649 input-raw
5650 output-raw
5651 s)
5652 (let ((speed
5653 (if (##eq? s (macro-absent-obj))
5654 0
5655 s)))
5656 (macro-check-tty-port
5657 port
5658 1
5659 (tty-mode-set! port
5660 input-allow-special
5661 input-echo
5662 input-raw
5663 output-raw
5664 s)
5665 (##tty-mode-set! port
5666 input-allow-special
5667 input-echo
5668 input-raw
5669 output-raw
5670 speed)))))
5672 ;;;----------------------------------------------------------------------------
5674 ;;; Implementation of process device ports.
5676 (implement-check-type-process-port)
5678 (define-prim (##make-process-psettings
5679 direction
5680 settings
5681 fail
5682 succeed)
5683 (##make-psettings
5684 direction
5685 '(path:
5686 arguments:
5687 environment:
5688 directory:
5689 stdin-redirection:
5690 stdout-redirection:
5691 stderr-redirection:
5692 pseudo-terminal:
5693 show-console:
5694 output-width:
5695 input-char-encoding:
5696 output-char-encoding:
5697 char-encoding:
5698 input-char-encoding-errors:
5699 output-char-encoding-errors:
5700 char-encoding-errors:
5701 input-eol-encoding:
5702 output-eol-encoding:
5703 eol-encoding:
5704 direction:
5705 input-buffering:
5706 output-buffering:
5707 buffering:
5708 input-readtable:
5709 output-readtable:
5710 readtable:)
5711 settings
5712 fail
5713 succeed))
5715 (define-prim (##open-process-generic
5716 direction
5717 raise-os-exception?
5718 cont
5719 prim
5720 path-or-settings
5721 #!optional
5722 (arg2 (macro-absent-obj)))
5724 (define (psettings->options psettings)
5725 (let ((stdin-redir
5726 (macro-psettings-stdin-redir psettings))
5727 (stdout-redir
5728 (macro-psettings-stdout-redir psettings))
5729 (stderr-redir
5730 (macro-psettings-stderr-redir psettings))
5731 (pseudo-term
5732 (macro-psettings-pseudo-term psettings))
5733 (show-console
5734 (macro-psettings-show-console psettings)))
5735 (##fixnum.+
5736 stdin-redir
5737 (##fixnum.+
5738 (##fixnum.* 2 stdout-redir)
5739 (##fixnum.+
5740 (##fixnum.* 4 stderr-redir)
5741 (##fixnum.+
5742 (##fixnum.* 8 pseudo-term)
5743 (##fixnum.* 16 show-console)))))))
5745 (define (fail)
5746 (##fail-check-string-or-settings 1 prim path-or-settings arg2))
5748 (##make-process-psettings
5749 direction
5750 (if (##string? path-or-settings)
5751 (##list 'path: path-or-settings)
5752 path-or-settings)
5753 fail
5754 (lambda (psettings)
5755 (let ((path (macro-psettings-path psettings))
5756 (directory (macro-psettings-directory psettings)))
5757 (if (or (##not (##string? path))
5758 (##not (or (##not directory)
5759 (##string? directory))))
5760 (fail)
5761 (let* ((path-and-arguments
5762 (##cons path
5763 (macro-psettings-arguments psettings)))
5764 (environment
5765 (macro-psettings-environment psettings))
5766 (resolved-directory
5767 (if directory
5768 (##path-resolve directory)
5769 (##current-directory)))
5770 (direction
5771 (macro-psettings-direction psettings)))
5773 ;; force creation of a bidirectional port
5774 (macro-psettings-direction-set!
5775 psettings
5776 (macro-direction-inout))
5778 (let ((device
5779 (##os-device-stream-open-process
5780 path-and-arguments
5781 environment
5782 resolved-directory
5783 (psettings->options psettings))))
5784 (cond ((##fixnum? device)
5785 (if raise-os-exception?
5786 (##raise-os-exception
5787 #f
5788 device
5789 prim
5790 path-or-settings
5791 arg2)
5792 (cont device)))
5793 (else
5794 (let ((port
5795 (##make-device-port-from-single-device
5796 (##cons 'process path-and-arguments)
5797 device
5798 psettings)))
5800 ;; close unused direction
5801 (cond ((##fixnum.= direction (macro-direction-in))
5802 (##close-output-port port))
5803 ((##fixnum.= direction (macro-direction-out))
5804 (##close-input-port port)))
5806 (cont port)))))))))))
5808 (define-prim (##open-process path-or-settings)
5809 (##open-process-generic
5810 (macro-direction-inout)
5811 #t
5812 (lambda (port) port)
5813 open-process
5814 path-or-settings))
5816 (define-prim (open-process path-or-settings)
5817 (macro-force-vars (path-or-settings)
5818 (##open-process path-or-settings)))
5820 (define-prim (##open-input-process path-or-settings)
5821 (##open-process-generic
5822 (macro-direction-in)
5823 #t
5824 (lambda (port) port)
5825 open-input-process
5826 path-or-settings))
5828 (define-prim (open-input-process path-or-settings)
5829 (macro-force-vars (path-or-settings)
5830 (##open-input-process path-or-settings)))
5832 (define-prim (##open-output-process path-or-settings)
5833 (##open-process-generic
5834 (macro-direction-out)
5835 #t
5836 (lambda (port) port)
5837 open-output-process
5838 path-or-settings))
5840 (define-prim (open-output-process path-or-settings)
5841 (macro-force-vars (path-or-settings)
5842 (##open-output-process path-or-settings)))
5844 (define-prim (call-with-input-process path-or-settings proc)
5845 (macro-force-vars (path-or-settings proc)
5846 (macro-check-procedure
5847 proc
5848 2
5849 (call-with-input-process path-or-settings proc)
5850 (##open-process-generic
5851 (macro-direction-in)
5852 #t
5853 (lambda (port)
5854 (let ((results ;; may get bound to a multiple-values object
5855 (proc port)))
5856 (##close-port port)
5857 (##process-status port) ;; wait for process to terminate
5858 results))
5859 call-with-input-process
5860 path-or-settings
5861 proc))))
5863 (define-prim (call-with-output-process path-or-settings proc)
5864 (macro-force-vars (path-or-settings proc)
5865 (macro-check-procedure
5866 proc
5867 2
5868 (call-with-output-process path-or-settings proc)
5869 (##open-process-generic
5870 (macro-direction-out)
5871 #t
5872 (lambda (port)
5873 (let ((results ;; may get bound to a multiple-values object
5874 (proc port)))
5875 (##force-output port)
5876 (##close-port port)
5877 (##process-status port) ;; wait for process to terminate
5878 results))
5879 call-with-output-process
5880 path-or-settings
5881 proc))))
5883 (define-prim (with-input-from-process path-or-settings thunk)
5884 (macro-force-vars (path-or-settings thunk)
5885 (macro-check-procedure
5886 thunk
5887 2
5888 (with-input-from-process path-or-settings thunk)
5889 (##open-process-generic
5890 (macro-direction-in)
5891 #t
5892 (lambda (port)
5893 (let ((results ;; may get bound to a multiple-values object
5894 (macro-dynamic-bind input-port port thunk)))
5895 (##close-port port)
5896 (##process-status port) ;; wait for process to terminate
5897 results))
5898 with-input-from-process
5899 path-or-settings
5900 thunk))))
5902 (define-prim (with-output-to-process path-or-settings thunk)
5903 (macro-force-vars (path-or-settings thunk)
5904 (macro-check-procedure
5905 thunk
5906 2
5907 (with-output-to-process path-or-settings thunk)
5908 (##open-process-generic
5909 (macro-direction-out)
5910 #t
5911 (lambda (port)
5912 (let ((results ;; may get bound to a multiple-values object
5913 (macro-dynamic-bind output-port port thunk)))
5914 (##force-output port)
5915 (##close-port port)
5916 (##process-status port) ;; wait for process to terminate
5917 results))
5918 with-output-to-process
5919 path-or-settings
5920 thunk))))
5922 (define-prim (##process-pid port)
5923 (##os-device-process-pid (##port-device port)))
5925 (define-prim (process-pid port)
5926 (macro-force-vars (port)
5927 (macro-check-process-port
5928 port
5929 1
5930 (process-pid port)
5931 (##process-pid port))))
5933 (define-prim (##process-status
5934 port
5935 #!optional
5936 (absrel-timeout (macro-absent-obj))
5937 (timeout-val (macro-absent-obj)))
5938 (let ((timeout
5939 (macro-time-point
5940 (##timeout->time
5941 (if (##eq? absrel-timeout (macro-absent-obj))
5942 #f
5943 absrel-timeout)))))
5944 (let loop ((poll-interval 0.001))
5945 (let ((result (##os-device-process-status (##port-device port))))
5946 (cond ((##not result)
5947 (let ((now (##current-time-point)))
5948 (if (##flonum.< now timeout)
5949 (begin
5950 ;; Polling is evil but fixing this would require
5951 ;; substantial changes to the I/O subsystem. We'll
5952 ;; tackle that in a future release.
5953 (##thread-sleep! poll-interval)
5954 (loop (##flonum.min 0.2 (##flonum.* 1.2 poll-interval))))
5955 (if (##eq? timeout-val (macro-absent-obj))
5956 (##raise-unterminated-process-exception
5957 process-status
5958 port
5959 timeout-val)
5960 timeout-val))))
5961 ((##fixnum.< result 0)
5962 (##raise-os-exception #f result process-status port))
5963 (else
5964 result))))))
5966 (define-prim (process-status
5967 port
5968 #!optional
5969 (absrel-timeout (macro-absent-obj))
5970 (timeout-val (macro-absent-obj)))
5971 (macro-force-vars (port absrel-timeout)
5972 (macro-check-process-port
5973 port
5974 1
5975 (process-status port absrel-timeout timeout-val)
5976 (if (or (##eq? absrel-timeout (macro-absent-obj))
5977 (macro-absrel-time-or-false? absrel-timeout))
5978 (##process-status port absrel-timeout timeout-val)
5979 (##fail-check-absrel-time-or-false
5980 2
5981 process-status
5982 port
5983 absrel-timeout
5984 timeout-val)))))
5986 ;;;----------------------------------------------------------------------------
5988 ;;; Implementation of host-info objects.
5990 (implement-library-type-host-info)
5992 (define-prim (##host-info host)
5993 (let ((result (##os-host-info host)))
5994 (if (##fixnum? result)
5995 (##raise-os-exception #f result host-info host)
5996 (begin
5997 (##structure-type-set! result (macro-type-host-info))
5998 (##subtype-set! result (macro-subtype-structure))
5999 result))))
6001 (define-prim (host-info host)
6002 (macro-force-vars (host)
6003 (macro-check-string-or-ip-address host 1 (host-info host)
6004 (##host-info host))))
6006 (define-prim (##host-name)
6007 (let ((result (##os-host-name)))
6008 (if (##fixnum? result)
6009 (##raise-os-exception #f result host-name)
6010 result)))
6012 (define-prim (host-name)
6013 (##host-name))
6015 (define-prim (##string-or-ip-address? obj)
6016 (or (##string? obj)
6017 (##ip-address? obj)))
6019 (define-prim (##ip-address? obj)
6020 (cond ((##u8vector? obj)
6021 (##fixnum.= (##u8vector-length obj) 4))
6022 ((##u16vector? obj)
6023 (##fixnum.= (##u16vector-length obj) 8))
6024 (else
6025 #f)))
6027 ;;;----------------------------------------------------------------------------
6029 ;;; Implementation of service-info objects.
6031 (implement-library-type-service-info)
6033 (define-prim (##service-info
6034 service
6035 #!optional
6036 (protocol (macro-absent-obj)))
6037 (let ((result
6038 (##os-service-info
6039 service
6040 (cond ((##string? protocol)
6041 protocol)
6042 ((##fixnum? protocol)
6043 (let ((p (##protocol-info protocol)))
6044 (macro-protocol-info-name p)))
6045 ((macro-protocol-info? protocol)
6046 (macro-protocol-info-name protocol))
6047 (else
6048 #f)))))
6049 (if (##fixnum? result)
6050 (##raise-os-exception #f result service-info service protocol)
6051 (begin
6052 (##structure-type-set! result (macro-type-service-info))
6053 (##subtype-set! result (macro-subtype-structure))
6054 result))))
6056 (define-prim (service-info
6057 service
6058 #!optional
6059 (protocol (macro-absent-obj)))
6060 (macro-force-vars (service protocol)
6061 (macro-check-string-or-nonnegative-fixnum
6062 service
6063 1
6064 (service-info service protocol)
6065 (if (##eq? protocol (macro-absent-obj))
6066 (##service-info service)
6067 (macro-check-string-or-nonnegative-fixnum
6068 protocol
6069 2
6070 (service-info service protocol)
6071 (##service-info service protocol))))))
6073 ;;;----------------------------------------------------------------------------
6075 ;;; Implementation of protocol-info objects.
6077 (implement-library-type-protocol-info)
6079 (define-prim (##protocol-info protocol)
6080 (let ((result
6081 (##os-protocol-info protocol)))
6082 (if (##fixnum? result)
6083 (##raise-os-exception #f result protocol-info protocol)
6084 (begin
6085 (##structure-type-set! result (macro-type-protocol-info))
6086 (##subtype-set! result (macro-subtype-structure))
6087 result))))
6089 (define-prim (protocol-info protocol)
6090 (macro-force-vars (protocol)
6091 (macro-check-string-or-nonnegative-fixnum
6092 protocol
6093 1
6094 (protocol-info protocol)
6095 (##protocol-info protocol))))
6097 ;;;----------------------------------------------------------------------------
6099 ;;; Implementation of network-info objects.
6101 (implement-library-type-network-info)
6103 (define-prim (##network-info network)
6104 (let ((result
6105 (##os-network-info network)))
6106 (if (##fixnum? result)
6107 (##raise-os-exception #f result network-info network)
6108 (begin
6109 (##structure-type-set! result (macro-type-network-info))
6110 (##subtype-set! result (macro-subtype-structure))
6111 result))))
6113 (define-prim (network-info network)
6114 (macro-force-vars (network)
6115 (macro-check-string-or-nonnegative-fixnum
6116 network
6117 1
6118 (network-info network)
6119 (##network-info network))))
6121 ;;;----------------------------------------------------------------------------
6123 ;;; Implementation of TCP client device ports.
6125 (implement-check-type-tcp-client-port)
6127 (define-prim (##make-tcp-psettings
6128 client?
6129 settings
6130 fail
6131 succeed)
6133 (define allowed-client-settings
6134 '(; broadcast:
6135 server-address:
6136 port-number:
6137 ;; socket-type:
6138 keep-alive:
6139 coalesce:
6140 output-width:
6141 input-char-encoding:
6142 output-char-encoding:
6143 char-encoding:
6144 input-char-encoding-errors:
6145 output-char-encoding-errors:
6146 char-encoding-errors:
6147 input-eol-encoding:
6148 output-eol-encoding:
6149 eol-encoding:
6150 input-buffering:
6151 output-buffering:
6152 buffering:
6153 input-readtable:
6154 output-readtable:
6155 readtable:))
6157 (define allowed-server-settings
6158 '(reuse-address:
6159 backlog:
6160 server-address:
6161 port-number:
6162 ;; socket-type:
6163 keep-alive:
6164 coalesce:
6165 output-width:
6166 input-char-encoding:
6167 output-char-encoding:
6168 char-encoding:
6169 input-char-encoding-errors:
6170 output-char-encoding-errors:
6171 char-encoding-errors:
6172 input-eol-encoding:
6173 output-eol-encoding:
6174 eol-encoding:
6175 input-buffering:
6176 output-buffering:
6177 buffering:
6178 input-readtable:
6179 output-readtable:
6180 readtable:))
6182 (##make-psettings
6183 (macro-direction-inout)
6184 (if client?
6185 allowed-client-settings
6186 allowed-server-settings)
6187 settings
6188 fail
6189 succeed))
6191 (define-prim (##make-tcp-client-port name device psettings)
6192 (##make-device-port-from-single-device
6193 name
6194 device
6195 psettings))
6197 (define-prim (##open-tcp-client
6198 raise-os-exception?
6199 cont
6200 prim
6201 port-number-or-address-or-settings)
6203 (define (psettings->options psettings)
6204 (let ((coalesce
6205 (macro-psettings-coalesce psettings))
6206 (keep-alive
6207 (macro-psettings-keep-alive psettings)))
6208 (##fixnum.+
6209 (##fixnum.* 2 coalesce)
6210 keep-alive)))
6212 (define (fail)
6213 (##fail-check-exact-integer-or-string-or-settings 1 prim port-number-or-address-or-settings))
6215 (##make-tcp-psettings
6216 #t
6217 (cond ((##fixnum? port-number-or-address-or-settings)
6218 (##list 'port-number: port-number-or-address-or-settings))
6219 ((##string? port-number-or-address-or-settings)
6220 (##list 'server-address: port-number-or-address-or-settings))
6221 (else
6222 port-number-or-address-or-settings))
6223 fail
6224 (lambda (psettings)
6225 (let ((server-address-or-host
6226 (macro-psettings-server-address psettings)))
6228 (define (open server-address)
6229 (let ((port-number
6230 (macro-psettings-port-number psettings)))
6231 (if (or (##eq? server-address #f)
6232 (##not port-number))
6233 (fail)
6234 (let ((device
6235 (##os-device-tcp-client-open
6236 server-address
6237 port-number
6238 (psettings->options psettings))))
6239 (if (##fixnum? device)
6240 (if raise-os-exception?
6241 (##raise-os-exception #f device prim port-number-or-address-or-settings)
6242 (cont device))
6243 (let ((port
6244 (##make-tcp-client-port
6245 (##list 'tcp-client
6246 server-address-or-host
6247 port-number)
6248 device
6249 psettings)))
6250 ;; wait for connection to be established
6251 ;; (##wait-for-io!
6252 ;; (macro-device-port-wdevice-condvar port)
6253 ;; (macro-port-wtimeout port))
6254 (cont port)))))))
6256 (if (##string? server-address-or-host)
6257 (let ((info (##os-host-info server-address-or-host)))
6258 (if (##fixnum? info)
6259 (if raise-os-exception?
6260 (##raise-os-exception #f info prim port-number-or-address-or-settings)
6261 (cont info))
6262 (open (##car (macro-host-info-addresses info)))))
6263 (open server-address-or-host))))))
6265 (define-prim (open-tcp-client port-number-or-address-or-settings)
6266 (macro-force-vars (port-number-or-address-or-settings)
6267 (##open-tcp-client
6268 #t
6269 (lambda (port) port)
6270 open-tcp-client
6271 port-number-or-address-or-settings)))
6273 (implement-library-type-socket-info)
6275 (define-prim (##socket-info-setup! si)
6276 (##vector-set! si 1 (##net-family-decode (##vector-ref si 1)))
6277 (##structure-type-set! si (macro-type-socket-info))
6278 (##subtype-set! si (macro-subtype-structure))
6279 si)
6281 (define-prim (##tcp-client-socket-info port prim)
6282 (let loop ()
6283 (let ((result
6284 (##os-device-tcp-client-socket-info
6285 (macro-condvar-name (macro-device-port-rdevice-condvar port))
6286 (##eq? prim tcp-client-peer-socket-info))))
6287 (if (##fixnum? result)
6289 (if (and (##fixnum.= result ##err-code-EAGAIN)
6290 (or (##wait-for-io!
6291 (macro-device-port-wdevice-condvar port)
6292 (macro-port-wtimeout port))
6293 ((macro-port-wtimeout-thunk port))))
6294 (loop)
6295 (##raise-os-exception #f result prim port))
6297 (##socket-info-setup! result)))))
6299 (define-prim (##tcp-client-self-socket-info port)
6300 (##tcp-client-socket-info port tcp-client-self-socket-info))
6302 (define-prim (tcp-client-self-socket-info port)
6303 (macro-force-vars (port)
6304 (macro-check-tcp-client-port port 1 (tcp-client-self-socket-info port)
6305 (##tcp-client-self-socket-info port))))
6307 (define-prim (##tcp-client-peer-socket-info port)
6308 (##tcp-client-socket-info port tcp-client-peer-socket-info))
6310 (define-prim (tcp-client-peer-socket-info port)
6311 (macro-force-vars (port)
6312 (macro-check-tcp-client-port port 1 (tcp-client-peer-socket-info port)
6313 (##tcp-client-peer-socket-info port))))
6315 (implement-library-type-address-info)
6317 (define-prim (##net-family-encode x)
6318 (case x
6319 ((INET) -1)
6320 ((INET6) -2)
6321 (else x)))
6323 (define-prim (##net-family-decode x)
6324 (case x
6325 ((-1) 'INET)
6326 ((-2) 'INET6)
6327 (else x)))
6329 (define-prim (##net-socket-type-encode x)
6330 (case x
6331 ((STREAM) -1)
6332 ((DGRAM) -2)
6333 ((RAW) -3)
6334 (else x)))
6336 (define-prim (##net-socket-type-decode x)
6337 (case x
6338 ((-1) 'STREAM)
6339 ((-2) 'DGRAM)
6340 ((-3) 'RAW)
6341 (else x)))
6343 (define-prim (##net-protocol-encode x)
6344 (case x
6345 ((UDP) -1)
6346 ((TCP) -2)
6347 (else x)))
6349 (define-prim (##net-protocol-decode x)
6350 (case x
6351 ((-1) 'UDP)
6352 ((-2) 'TCP)
6353 (else x)))
6355 (define-prim (##address-info-setup! ai)
6356 (##vector-set! ai 1 (##net-family-decode (##vector-ref ai 1)))
6357 (##vector-set! ai 2 (##net-socket-type-decode (##vector-ref ai 2)))
6358 (##vector-set! ai 3 (##net-protocol-decode (##vector-ref ai 3)))
6359 (let ((si (##vector-ref ai 4)))
6360 (##socket-info-setup! si))
6361 (##structure-type-set! ai (macro-type-address-info))
6362 (##subtype-set! ai (macro-subtype-structure))
6363 ai)
6365 (define-prim (##address-infos
6366 #!key
6367 (host (macro-absent-obj))
6368 (service (macro-absent-obj))
6369 ;;(flags (macro-absent-obj))
6370 (family (macro-absent-obj))
6371 (socket-type (macro-absent-obj))
6372 (protocol (macro-absent-obj)))
6373 (macro-force-vars (host service flags family socket-type protocol)
6374 (let ((flags (macro-absent-obj)))
6376 (define (check-host arg-num)
6377 (if (##eq? host (macro-absent-obj))
6378 (check-service arg-num "")
6379 (let ((arg-num (##fixnum.+ arg-num 2)))
6380 (macro-check-string
6381 host
6382 arg-num
6383 (address-infos host: host
6384 service: service
6385 flags: flags
6386 family: family
6387 socket-type: socket-type
6388 protocol: protocol)
6389 (check-service arg-num host)))))
6391 (define (check-service arg-num h)
6392 (if (##eq? service (macro-absent-obj))
6393 (check-flags arg-num h "")
6394 (let ((arg-num (##fixnum.+ arg-num 2)))
6395 (macro-check-string
6396 service
6397 arg-num
6398 (address-infos host: host
6399 service: service
6400 flags: flags
6401 family: family
6402 socket-type: socket-type
6403 protocol: protocol)
6404 (check-flags arg-num h service)))))
6406 (define (check-flags arg-num h s)
6407 (if (##eq? flags (macro-absent-obj))
6408 (check-family arg-num h s 0)
6409 (let ((arg-num (##fixnum.+ arg-num 2)))
6410 (macro-check-fixnum-range-incl
6411 flags
6412 arg-num
6413 0
6414 65535
6415 (address-infos host: host
6416 service: service
6417 flags: flags
6418 family: family
6419 socket-type: socket-type
6420 protocol: protocol)
6421 (check-family arg-num h s flags)))))
6423 (define (check-family arg-num h s f)
6424 (if (##eq? family (macro-absent-obj))
6425 (check-socket-type arg-num h s f 0)
6426 (let ((arg-num (##fixnum.+ arg-num 2)))
6427 (let ((x (##net-family-encode family)))
6428 (if (##eq? x family)
6429 (##raise-type-exception
6430 arg-num
6431 'network-family
6432 (##list address-infos
6433 host: host
6434 service: service
6435 flags: flags
6436 family: family
6437 socket-type: socket-type
6438 protocol: protocol)
6439 '())
6440 (check-socket-type arg-num h s f x))))))
6442 (define (check-socket-type arg-num h s f fam)
6443 (if (##eq? socket-type (macro-absent-obj))
6444 (check-protocol arg-num h s f fam 0)
6445 (let ((arg-num (##fixnum.+ arg-num 2)))
6446 (let ((x (##net-socket-type-encode socket-type)))
6447 (if (##eq? x socket-type)
6448 (##raise-type-exception
6449 arg-num
6450 'network-socket-type
6451 (##list address-infos
6452 host: host
6453 service: service
6454 flags: flags
6455 family: family
6456 socket-type: socket-type
6457 protocol: protocol)
6458 '())
6459 (check-protocol arg-num h s f fam x))))))
6461 (define (check-protocol arg-num h s f fam st)
6462 (if (##eq? protocol (macro-absent-obj))
6463 (checks-done h s f fam st 0)
6464 (let ((arg-num (##fixnum.+ arg-num 2)))
6465 (let ((x (##net-protocol-encode protocol)))
6466 (if (##eq? x protocol)
6467 (##raise-type-exception
6468 arg-num
6469 'network-protocol
6470 (##list address-infos
6471 host: host
6472 service: service
6473 flags: flags
6474 family: family
6475 socket-type: socket-type
6476 protocol: protocol)
6477 '())
6478 (checks-done h s f fam st x))))))
6480 (define (checks-done h s f fam st p)
6481 (let ((result (##os-address-infos h s f fam st p)))
6482 (if (##fixnum? result)
6483 (##raise-os-exception
6484 #f
6485 result
6486 (##list address-infos
6487 host: host
6488 service: service
6489 flags: flags
6490 family: family
6491 socket-type: socket-type
6492 protocol: protocol))
6493 (begin
6494 (##for-each ##address-info-setup! result)
6495 result))))
6497 (check-host 0))))
6499 (define-prim (address-infos
6500 #!key
6501 (host (macro-absent-obj))
6502 (service (macro-absent-obj))
6503 ;;(flags (macro-absent-obj))
6504 (family (macro-absent-obj))
6505 (socket-type (macro-absent-obj))
6506 (protocol (macro-absent-obj)))
6507 (##address-infos host: host
6508 service: service
6509 ;;flags: flags
6510 family: family
6511 socket-type: socket-type
6512 protocol: protocol))
6514 ;;;----------------------------------------------------------------------------
6516 ;; Implementation of TCP server ports.
6518 (implement-check-type-tcp-server-port)
6520 (define-prim (##make-tcp-server-port rdevice client-psettings)
6521 (let ((mutex
6522 (macro-make-port-mutex))
6523 (rkind
6524 (macro-tcp-server-kind))
6525 (wkind
6526 (macro-none-kind))
6527 (roptions
6528 0)
6529 (rtimeout
6530 #t)
6531 (rtimeout-thunk
6532 #f)
6533 (woptions
6534 0)
6535 (wtimeout
6536 #t)
6537 (wtimeout-thunk
6538 #f)
6539 (rdevice-condvar
6540 (##make-rdevice-condvar rdevice)))
6542 (define (server-name port)
6544 ;; It is assumed that the thread **does not** have exclusive
6545 ;; access to the port.
6547 (##declare (not interrupts-enabled))
6549 (##list 'tcp-server
6550 (macro-psettings-port-number
6551 (macro-tcp-server-port-client-psettings port))))
6553 ;; This code gives a more informative name to the tcp-client port but
6554 ;; if ##os-device-tcp-client-socket-info raises an exception it leads
6555 ;; to an infinite loop.
6556 ;;
6557 ;; (define (client-name port)
6558 ;;
6559 ;; ;; It is assumed that the thread **does not** have exclusive
6560 ;; ;; access to the port.
6561 ;;
6562 ;; (##declare (not interrupts-enabled))
6563 ;;
6564 ;; (let ((info
6565 ;; (##os-device-tcp-client-socket-info
6566 ;; (macro-condvar-name
6567 ;; (macro-device-port-wdevice-condvar port))
6568 ;; #t)))
6569 ;; (if (##fixnum? info)
6570 ;; (##list 'tcp-client
6571 ;; (macro-psettings-port-number
6572 ;; (macro-tcp-server-port-client-psettings port)))
6573 ;; (let ((address
6574 ;; (macro-socket-info-address info))
6575 ;; (port-num
6576 ;; (macro-socket-info-port-number info)))
6577 ;; (##list 'tcp-client
6578 ;; address
6579 ;; port-num)))))
6581 (define (read-datum port re)
6583 ;; It is assumed that the thread **does not** have exclusive
6584 ;; access to the port.
6586 (##declare (not interrupts-enabled))
6588 (macro-port-mutex-lock! port) ;; get exclusive access to port
6590 (let loop ()
6591 (let ((client-device
6592 (##os-device-tcp-server-read
6593 (macro-condvar-name
6594 (macro-tcp-server-port-rdevice-condvar port)))))
6595 (if (##fixnum? client-device)
6597 (cond ((##fixnum.= client-device ##err-code-EINTR)
6599 ;; the read was interrupted, so try again
6601 (loop))
6603 ((##fixnum.= client-device ##err-code-EAGAIN)
6605 ;; the read would block, so wait and then try again
6607 (macro-port-mutex-unlock! port)
6608 (let ((continue?
6609 (or (##wait-for-io!
6610 (macro-tcp-server-port-rdevice-condvar port)
6611 (macro-port-rtimeout port))
6612 ((macro-port-rtimeout-thunk port)))))
6613 (if continue?
6614 (begin
6615 (macro-port-mutex-lock! port) ;; regain access to port
6616 (loop))
6617 #!eof)))
6619 (else
6621 ;; signal an error
6623 (macro-port-mutex-unlock! port)
6624 (##raise-os-exception #f client-device read port)))
6626 (begin
6627 (macro-port-mutex-unlock! port)
6628 (let ((port
6629 (##make-tcp-client-port
6630 '(tcp-client)
6631 client-device
6632 (macro-tcp-server-port-client-psettings port))))
6633 ;; (macro-port-name-set! port client-name)
6634 port))))))
6636 (define write-datum #f)
6638 (define newline #f)
6640 (define force-output #f)
6642 (define (set-rtimeout port timeout thunk)
6644 ;; It is assumed that the thread **does not** have exclusive
6645 ;; access to the port.
6647 (##declare (not interrupts-enabled))
6649 (macro-port-mutex-lock! port) ;; get exclusive access to port
6651 (macro-port-rtimeout-set! port timeout)
6652 (macro-port-rtimeout-thunk-set! port thunk)
6653 (##condvar-signal-no-reschedule!
6654 (macro-tcp-server-port-rdevice-condvar port)
6655 #t)
6656 (macro-port-mutex-unlock! port)
6657 (##void))
6659 (define set-wtimeout #f)
6661 (define (close port prim arg1)
6663 ;; It is assumed that the thread **does not** have exclusive
6664 ;; access to the port.
6666 (##declare (not interrupts-enabled))
6668 (macro-port-mutex-lock! port) ;; get exclusive access to port
6670 (let ((result
6671 (##close-device
6672 port
6673 (macro-tcp-server-port-rdevice-condvar port)
6674 #f
6675 prim)))
6676 (macro-port-mutex-unlock! port)
6677 (if (##fixnum? result)
6678 (##raise-os-exception #f result prim arg1)
6679 result)))
6681 (let ((port
6682 (macro-make-tcp-server-port
6683 mutex
6684 rkind
6685 wkind
6686 server-name
6687 read-datum
6688 write-datum
6689 newline
6690 force-output
6691 close
6692 roptions
6693 rtimeout
6694 rtimeout-thunk
6695 set-rtimeout
6696 woptions
6697 wtimeout
6698 wtimeout-thunk
6699 set-wtimeout
6700 rdevice-condvar
6701 client-psettings)))
6702 (##io-condvar-port-set! rdevice-condvar port)
6703 port)))
6705 (define-prim (##process-tcp-server-psettings
6706 raise-os-exception?
6707 cont
6708 prim
6709 port-number-or-address-or-settings
6710 arg2
6711 arg3
6712 arg4)
6714 (define (fail)
6715 (##fail-check-exact-integer-or-string-or-settings 1 prim port-number-or-address-or-settings arg2 arg3 arg4))
6717 (##make-tcp-psettings
6718 #f
6719 (cond ((##fixnum? port-number-or-address-or-settings)
6720 (##list 'port-number: port-number-or-address-or-settings))
6721 ((##string? port-number-or-address-or-settings)
6722 (##list 'server-address: port-number-or-address-or-settings))
6723 (else
6724 port-number-or-address-or-settings))
6725 fail
6726 (lambda (psettings)
6728 (define (continue-with-address server-address)
6729 (if (##eq? server-address #t)
6730 (fail)
6731 (cont (##cons psettings server-address))))
6733 (if (##not (macro-psettings-port-number psettings))
6734 (fail)
6735 (let ((server-address-or-host
6736 (macro-psettings-server-address psettings)))
6737 (if (##string? server-address-or-host)
6738 (let ((info (##os-host-info server-address-or-host)))
6739 (if (##fixnum? info)
6740 (if raise-os-exception?
6741 (##raise-os-exception #f info prim port-number-or-address-or-settings arg2 arg3 arg4)
6742 (cont info))
6743 (continue-with-address
6744 (##car (macro-host-info-addresses info)))))
6745 (continue-with-address
6746 server-address-or-host)))))))
6748 (define-prim (##open-tcp-server-aux
6749 raise-os-exception?
6750 psettings-and-server-address
6751 cont
6752 prim
6753 port-number-or-address-or-settings
6754 arg2
6755 arg3
6756 arg4)
6758 (define (psettings->options psettings)
6759 (let ((reuse-address
6760 (macro-psettings-reuse-address psettings))
6761 (coalesce
6762 (macro-psettings-coalesce psettings))
6763 (keep-alive
6764 (macro-psettings-keep-alive psettings)))
6765 (##fixnum.+
6766 (##fixnum.* 2048 reuse-address)
6767 (##fixnum.+
6768 (##fixnum.* 2 coalesce)
6769 keep-alive))))
6771 (let* ((psettings
6772 (##car psettings-and-server-address))
6773 (server-address
6774 (##cdr psettings-and-server-address))
6775 (port-number
6776 (macro-psettings-port-number psettings))
6777 (rdevice
6778 (##os-device-tcp-server-open
6779 server-address
6780 port-number
6781 (macro-psettings-backlog psettings)
6782 (psettings->options psettings))))
6783 (if (##fixnum? rdevice)
6784 (if raise-os-exception?
6785 (##raise-os-exception #f rdevice prim port-number-or-address-or-settings arg2 arg3 arg4)
6786 (cont rdevice))
6787 (cont (##make-tcp-server-port rdevice psettings)))))
6789 (define-prim (##open-tcp-server
6790 raise-os-exception?
6791 cont
6792 prim
6793 port-number-or-address-or-settings
6794 arg2
6795 arg3
6796 arg4)
6797 (##process-tcp-server-psettings
6798 raise-os-exception?
6799 (lambda (psettings-and-server-address)
6800 (##open-tcp-server-aux
6801 raise-os-exception?
6802 psettings-and-server-address
6803 cont
6804 prim
6805 port-number-or-address-or-settings
6806 arg2
6807 arg3
6808 arg4))
6809 prim
6810 port-number-or-address-or-settings
6811 arg2
6812 arg3
6813 arg4))
6815 (define-prim (open-tcp-server port-number-or-address-or-settings)
6816 (macro-force-vars (port-number-or-address-or-settings)
6817 (##open-tcp-server
6818 #t
6819 (lambda (port) port)
6820 open-tcp-server
6821 port-number-or-address-or-settings
6822 (macro-absent-obj)
6823 (macro-absent-obj)
6824 (macro-absent-obj))))
6826 (define-prim (##tcp-server-socket-info port)
6827 (let ((result
6828 (##os-device-tcp-server-socket-info
6829 (macro-condvar-name (macro-tcp-server-port-rdevice-condvar port)))))
6830 (if (##fixnum? result)
6832 (##raise-os-exception #f result tcp-server-socket-info port))
6834 (##socket-info-setup! result)))
6836 (define-prim (tcp-server-socket-info port)
6837 (macro-force-vars (port)
6838 (macro-check-tcp-server-port port 1 (tcp-server-socket-info port)
6839 (##tcp-server-socket-info port))))
6841 (define-prim (##string->address-and-port-number
6842 str
6843 default-address
6844 default-port-num)
6846 (define (err)
6847 #f)
6849 (define (addr str)
6850 (if (##string=? str "*")
6851 #f
6852 str))
6854 (let ((len (if str (##string-length str) 0)))
6855 (let loop ((i 0) (colon #f))
6856 (if (##fx< i len)
6857 (let ((c (##string-ref str i)))
6858 (cond ((##not colon)
6859 (loop (##fx+ i 1)
6860 (if (##char=? c #\:) i colon)))
6861 ((and (##char<=? #\0 c) (##char<=? c #\9))
6862 (loop (##fx+ i 1)
6863 colon))
6864 (else
6865 (err))))
6866 (if (##not colon)
6867 (##cons (if (##fx= len 0)
6868 default-address
6869 (addr str))
6870 default-port-num)
6871 (let ((port-num
6872 (##string->number
6873 (##substring str (##fx+ colon 1) len)
6874 10)))
6875 (if (and port-num
6876 (##fixnum? port-num)
6877 (##fx<= 0 port-num)
6878 (##fx<= port-num 65535))
6879 (##cons (if (##fx= colon 0)
6880 default-address
6881 (addr (##substring str 0 colon)))
6882 port-num)
6883 (err))))))))
6885 ;;;----------------------------------------------------------------------------
6887 ;;; Implementation of directory ports.
6889 (implement-check-type-directory-port)
6891 (define-prim (##make-directory-psettings
6892 direction
6893 settings
6894 fail
6895 succeed)
6896 (##make-psettings
6897 direction
6898 '(path:
6899 permissions:
6900 ignore-hidden:)
6901 settings
6902 fail
6903 succeed))
6905 (define-prim (##make-directory-port rdevice path)
6906 (let ((mutex
6907 (macro-make-port-mutex))
6908 (rkind
6909 (macro-directory-kind))
6910 (wkind
6911 (macro-none-kind))
6912 (roptions
6913 0)
6914 (rtimeout
6915 #t)
6916 (rtimeout-thunk
6917 #f)
6918 (woptions
6919 0)
6920 (wtimeout
6921 #t)
6922 (wtimeout-thunk
6923 #f)
6924 (rdevice-condvar
6925 (##make-rdevice-condvar rdevice)))
6927 (define (name port)
6929 ;; It is assumed that the thread **does not** have exclusive
6930 ;; access to the port.
6932 (##declare (not interrupts-enabled))
6934 (macro-directory-port-path port))
6936 (define (read-datum port re)
6938 ;; It is assumed that the thread **does not** have exclusive
6939 ;; access to the port.
6941 (##declare (not interrupts-enabled))
6943 (macro-port-mutex-lock! port) ;; get exclusive access to port
6945 (let loop ()
6946 (let ((datum
6947 (##os-device-directory-read
6948 (macro-condvar-name
6949 (macro-directory-port-rdevice-condvar port)))))
6950 (if (##fixnum? datum)
6952 (cond ((##fixnum.= datum ##err-code-EINTR)
6954 ;; the read was interrupted, so try again
6956 (loop))
6958 ((##fixnum.= datum ##err-code-EAGAIN)
6960 ;; the read would block, so wait and then try again
6962 (macro-port-mutex-unlock! port)
6963 (let ((continue?
6964 (or (##wait-for-io!
6965 (macro-directory-port-rdevice-condvar port)
6966 (macro-port-rtimeout port))
6967 ((macro-port-rtimeout-thunk port)))))
6968 (if continue?
6969 (begin
6970 (macro-port-mutex-lock! port) ;; regain access to port
6971 (loop))
6972 #!eof)))
6974 (else
6976 ;; signal an error
6978 (macro-port-mutex-unlock! port)
6979 (##raise-os-exception #f datum read port)))
6981 (begin
6982 (macro-port-mutex-unlock! port)
6983 datum)))))
6985 (define write-datum #f)
6987 (define newline #f)
6989 (define force-output #f)
6991 (define (set-rtimeout port timeout thunk)
6993 ;; It is assumed that the thread **does not** have exclusive
6994 ;; access to the port.
6996 (##declare (not interrupts-enabled))
6998 (macro-port-mutex-lock! port) ;; get exclusive access to port
7000 (macro-port-rtimeout-set! port timeout)
7001 (macro-port-rtimeout-thunk-set! port thunk)
7002 (##condvar-signal-no-reschedule!
7003 (macro-directory-port-rdevice-condvar port)
7004 #t)
7005 (macro-port-mutex-unlock! port)
7006 (##void))
7008 (define set-wtimeout #f)
7010 (define (close port prim arg1)
7012 ;; It is assumed that the thread **does not** have exclusive
7013 ;; access to the port.
7015 (##declare (not interrupts-enabled))
7017 (macro-port-mutex-lock! port) ;; get exclusive access to port
7019 (let ((result
7020 (##close-device
7021 port
7022 (macro-directory-port-rdevice-condvar port)
7023 #f
7024 prim)))
7025 (macro-port-mutex-unlock! port)
7026 (if (##fixnum? result)
7027 (##raise-os-exception #f result prim arg1)
7028 result)))
7030 (let ((port
7031 (macro-make-directory-port
7032 mutex
7033 rkind
7034 wkind
7035 name
7036 read-datum
7037 write-datum
7038 newline
7039 force-output
7040 close
7041 roptions
7042 rtimeout
7043 rtimeout-thunk
7044 set-rtimeout
7045 woptions
7046 wtimeout
7047 wtimeout-thunk
7048 set-wtimeout
7049 rdevice-condvar
7050 path)))
7051 (##io-condvar-port-set! rdevice-condvar port)
7052 port)))
7054 (define-prim (##open-directory
7055 raise-os-exception?
7056 cont
7057 prim
7058 #!optional
7059 (path-or-settings (macro-absent-obj)))
7061 (define (fail)
7062 (##fail-check-string-or-settings 1 prim path-or-settings))
7064 (##make-directory-psettings
7065 (macro-direction-in)
7066 (cond ((##eq? path-or-settings (macro-absent-obj))
7067 '())
7068 ((##string? path-or-settings)
7069 (##list 'path: path-or-settings))
7070 (else
7071 path-or-settings))
7072 fail
7073 (lambda (psettings)
7074 (let ((path
7075 (or (macro-psettings-path psettings)
7076 (##current-directory))))
7077 (if (##not (##string? path))
7078 (fail)
7079 (let* ((resolved-path
7080 (##path-resolve path))
7081 (rdevice
7082 (##os-device-directory-open-path
7083 resolved-path
7084 (macro-psettings-ignore-hidden psettings))))
7085 (if (##fixnum? rdevice)
7086 (if raise-os-exception?
7087 (##raise-os-exception #f rdevice open-directory path)
7088 (cont rdevice))
7089 (cont (##make-directory-port rdevice path)))))))))
7091 (define-prim (open-directory
7092 #!optional
7093 (path-or-settings (macro-absent-obj)))
7094 (macro-force-vars (path-or-settings)
7095 (##open-directory
7096 #t
7097 (lambda (port) port)
7098 open-directory
7099 path-or-settings)))
7101 ;;;----------------------------------------------------------------------------
7103 ;;; Implementation of event-queue ports.
7105 (implement-check-type-event-queue-port)
7107 (define-prim (##make-event-queue-port rdevice index)
7108 (let ((mutex
7109 (macro-make-port-mutex))
7110 (rkind
7111 (macro-event-queue-kind))
7112 (wkind
7113 (macro-none-kind))
7114 (roptions
7115 0)
7116 (rtimeout
7117 #t)
7118 (rtimeout-thunk
7119 #f)
7120 (woptions
7121 0)
7122 (wtimeout
7123 #t)
7124 (wtimeout-thunk
7125 #f)
7126 (rdevice-condvar
7127 (##make-rdevice-condvar rdevice)))
7129 (define (name port)
7131 ;; It is assumed that the thread **does not** have exclusive
7132 ;; access to the port.
7134 (##declare (not interrupts-enabled))
7136 (##list 'event-queue (macro-event-queue-port-index port)))
7138 (define (read-datum port re)
7140 ;; It is assumed that the thread **does not** have exclusive
7141 ;; access to the port.
7143 (##declare (not interrupts-enabled))
7145 (macro-port-mutex-lock! port) ;; get exclusive access to port
7147 (let loop ()
7148 (let ((datum
7149 (##os-device-event-queue-read
7150 (macro-condvar-name
7151 (macro-event-queue-port-rdevice-condvar port)))))
7152 (if (##fixnum? datum)
7154 (cond ((##fixnum.= datum ##err-code-EINTR)
7156 ;; the read was interrupted, so try again
7158 (loop))
7160 ((##fixnum.= datum ##err-code-EAGAIN)
7162 ;; the read would block, so wait and then try again
7164 (macro-port-mutex-unlock! port)
7165 (let ((continue?
7166 (or (##wait-for-io!
7167 (macro-event-queue-port-rdevice-condvar port)
7168 (macro-port-rtimeout port))
7169 ((macro-port-rtimeout-thunk port)))))
7170 (if continue?
7171 (begin
7172 (macro-port-mutex-lock! port) ;; regain access to port
7173 (loop))
7174 #!eof)))
7176 (else
7178 ;; signal an error
7180 (macro-port-mutex-unlock! port)
7181 (##raise-os-exception #f datum read port)))
7183 (begin
7184 (macro-port-mutex-unlock! port)
7185 datum)))))
7187 (define write-datum #f)
7189 (define newline #f)
7191 (define force-output #f)
7193 (define (set-rtimeout port timeout thunk)
7195 ;; It is assumed that the thread **does not** have exclusive
7196 ;; access to the port.
7198 (##declare (not interrupts-enabled))
7200 (macro-port-mutex-lock! port) ;; get exclusive access to port
7202 (macro-port-rtimeout-set! port timeout)
7203 (macro-port-rtimeout-thunk-set! port thunk)
7204 (##condvar-signal-no-reschedule!
7205 (macro-event-queue-port-rdevice-condvar port)
7206 #t)
7207 (macro-port-mutex-unlock! port)
7208 (##void))
7210 (define set-wtimeout #f)
7212 (define (close port prim arg1)
7214 ;; It is assumed that the thread **does not** have exclusive
7215 ;; access to the port.
7217 (##declare (not interrupts-enabled))
7219 (macro-port-mutex-lock! port) ;; get exclusive access to port
7221 (let ((result
7222 (##close-device
7223 port
7224 (macro-event-queue-port-rdevice-condvar port)
7225 #f
7226 prim)))
7227 (macro-port-mutex-unlock! port)
7228 (if (##fixnum? result)
7229 (##raise-os-exception #f result prim arg1)
7230 result)))
7232 (let ((port
7233 (macro-make-event-queue-port
7234 mutex
7235 rkind
7236 wkind
7237 name
7238 read-datum
7239 write-datum
7240 newline
7241 force-output
7242 close
7243 roptions
7244 rtimeout
7245 rtimeout-thunk
7246 set-rtimeout
7247 woptions
7248 wtimeout
7249 wtimeout-thunk
7250 set-wtimeout
7251 rdevice-condvar
7252 index)))
7253 (##io-condvar-port-set! rdevice-condvar port)
7254 port)))
7256 (define-prim (##open-event-queue
7257 raise-os-exception?
7258 cont
7259 prim
7260 index)
7262 (define (fail)
7263 (##fail-check-fixnum 1 prim index))
7265 (if (##not (##fixnum? index))
7266 (fail)
7267 (let ((rdevice
7268 (##os-device-event-queue-open index)))
7269 (if (##fixnum? rdevice)
7270 (if raise-os-exception?
7271 (##raise-os-exception #f rdevice open-event-queue index)
7272 (cont rdevice))
7273 (cont (##make-event-queue-port rdevice index))))))
7275 (define-prim (open-event-queue index)
7276 (macro-force-vars (index)
7277 (##open-event-queue
7278 #t
7279 (lambda (port) port)
7280 open-event-queue
7281 index)))
7283 ;;;----------------------------------------------------------------------------
7285 (define-prim (##make-path-psettings
7286 direction
7287 settings
7288 fail
7289 succeed)
7290 (##make-psettings
7291 direction
7292 '(path:
7293 append:
7294 create:
7295 truncate:
7296 permissions:
7297 output-width:
7298 input-char-encoding:
7299 output-char-encoding:
7300 char-encoding:
7301 input-char-encoding-errors:
7302 output-char-encoding-errors:
7303 char-encoding-errors:
7304 input-eol-encoding:
7305 output-eol-encoding:
7306 eol-encoding:
7307 direction:
7308 input-buffering:
7309 output-buffering:
7310 buffering:
7311 input-readtable:
7312 output-readtable:
7313 readtable:)
7314 settings
7315 fail
7316 succeed))
7318 (define-prim (##make-input-path-psettings
7319 settings
7320 fail
7321 succeed)
7322 (##make-psettings
7323 (macro-direction-in)
7324 '(path:
7325 input-char-encoding:
7326 char-encoding:
7327 input-char-encoding-errors:
7328 char-encoding-errors:
7329 input-eol-encoding:
7330 eol-encoding:
7331 input-buffering:
7332 buffering:
7333 input-readtable:
7334 readtable:)
7335 settings
7336 fail
7337 succeed))
7339 (define-prim (##open-file-generic
7340 direction
7341 raise-os-exception?
7342 cont
7343 prim
7344 path-or-settings
7345 #!optional
7346 (arg2 (macro-absent-obj)))
7348 (define (fail)
7349 (##fail-check-string-or-settings 1 prim path-or-settings arg2))
7351 (##make-path-psettings
7352 direction
7353 (if (##string? path-or-settings)
7354 (##list 'path: path-or-settings)
7355 path-or-settings)
7356 fail
7357 (lambda (psettings)
7358 (let ((path (macro-psettings-path psettings)))
7359 (if (##not (##string? path))
7360 (fail)
7361 (##open-file-generic-from-psettings
7362 psettings
7363 raise-os-exception?
7364 cont
7365 prim
7366 path-or-settings
7367 arg2))))))
7369 (define-prim (##open-file-generic-from-psettings
7370 psettings
7371 raise-os-exception?
7372 cont
7373 prim
7374 path-or-settings
7375 #!optional
7376 (arg2 (macro-absent-obj)))
7377 (let* ((path
7378 (macro-psettings-path psettings))
7379 (resolved-path
7380 (##path-resolve path))
7381 (device
7382 (##os-device-stream-open-path
7383 resolved-path
7384 (##psettings->device-flags psettings)
7385 (##psettings->permissions psettings #o666))))
7386 (if (##fixnum? device)
7387 (if raise-os-exception?
7388 (##raise-os-exception #f device prim path-or-settings arg2)
7389 (cont device))
7390 (cont
7391 (##make-device-port-from-single-device
7392 resolved-path
7393 device
7394 psettings)))))
7396 (define-prim (##path-reference path relative-to-path)
7397 (##path-expand
7398 path
7399 (if relative-to-path
7400 (##path-directory (##path-normalize relative-to-path))
7401 (##current-directory))))
7403 (define-prim (##open-file path-or-settings)
7404 (##open-file-generic
7405 (macro-direction-inout)
7406 #t
7407 (lambda (port) port)
7408 open-file
7409 path-or-settings))
7411 (define-prim (open-file path-or-settings)
7412 (macro-force-vars (path-or-settings)
7413 (##open-file path-or-settings)))
7415 (define-prim (##open-input-file path-or-settings)
7416 (##open-file-generic
7417 (macro-direction-in)
7418 #t
7419 (lambda (port) port)
7420 open-input-file
7421 path-or-settings))
7423 (define-prim (open-input-file path-or-settings)
7424 (macro-force-vars (path-or-settings)
7425 (##open-input-file path-or-settings)))
7427 (define-prim (##open-output-file path-or-settings)
7428 (##open-file-generic
7429 (macro-direction-out)
7430 #t
7431 (lambda (port) port)
7432 open-output-file
7433 path-or-settings))
7435 (define-prim (open-output-file path-or-settings)
7436 (macro-force-vars (path-or-settings)
7437 (##open-output-file path-or-settings)))
7439 (define-prim (call-with-input-file path-or-settings proc)
7440 (macro-force-vars (path-or-settings proc)
7441 (macro-check-procedure
7442 proc
7443 2
7444 (call-with-input-file path-or-settings proc)
7445 (##open-file-generic
7446 (macro-direction-in)
7447 #t
7448 (lambda (port)
7449 (let ((results ;; may get bound to a multiple-values object
7450 (proc port)))
7451 (##close-port port)
7452 results))
7453 call-with-input-file
7454 path-or-settings
7455 proc))))
7457 (define-prim (call-with-output-file path-or-settings proc)
7458 (macro-force-vars (path-or-settings proc)
7459 (macro-check-procedure
7460 proc
7461 2
7462 (call-with-output-file path-or-settings proc)
7463 (##open-file-generic
7464 (macro-direction-out)
7465 #t
7466 (lambda (port)
7467 (let ((results ;; may get bound to a multiple-values object
7468 (proc port)))
7469 (##force-output port)
7470 (##close-port port)
7471 results))
7472 call-with-output-file
7473 path-or-settings
7474 proc))))
7476 (define-prim (with-input-from-file path-or-settings thunk)
7477 (macro-force-vars (path-or-settings thunk)
7478 (macro-check-procedure
7479 thunk
7480 2
7481 (with-input-from-file path-or-settings thunk)
7482 (##open-file-generic
7483 (macro-direction-in)
7484 #t
7485 (lambda (port)
7486 (let ((results ;; may get bound to a multiple-values object
7487 (macro-dynamic-bind input-port port thunk)))
7488 (##close-port port)
7489 results))
7490 with-input-from-file
7491 path-or-settings
7492 thunk))))
7494 (define-prim (with-output-to-file path-or-settings thunk)
7495 (macro-force-vars (path-or-settings thunk)
7496 (macro-check-procedure
7497 thunk
7498 2
7499 (with-output-to-file path-or-settings thunk)
7500 (##open-file-generic
7501 (macro-direction-out)
7502 #t
7503 (lambda (port)
7504 (let ((results ;; may get bound to a multiple-values object
7505 (macro-dynamic-bind output-port port thunk)))
7506 (##force-output port)
7507 (##close-port port)
7508 results))
7509 with-output-to-file
7510 path-or-settings
7511 thunk))))
7513 ;;;----------------------------------------------------------------------------
7515 (define-prim (with-input-from-port port thunk)
7516 (macro-force-vars (port thunk)
7517 (macro-check-input-port port 1 (with-input-from-port port thunk)
7518 (macro-check-procedure thunk 2 (with-input-from-port port thunk)
7519 (macro-dynamic-bind input-port port thunk)))))
7521 (define-prim (with-output-to-port port thunk)
7522 (macro-force-vars (port thunk)
7523 (macro-check-output-port port 1 (with-output-to-port port thunk)
7524 (macro-check-procedure thunk 2 (with-output-to-port port thunk)
7525 (macro-dynamic-bind output-port port thunk)))))
7527 ;;;----------------------------------------------------------------------------
7529 (define-prim (##open-predefined
7530 direction
7531 name
7532 index
7533 #!optional
7534 (settings (macro-absent-obj)))
7536 (##make-path-psettings
7537 direction
7538 (##list 'readtable: ##main-readtable)
7539 ##exit-abnormally
7540 (lambda (psettings)
7541 (let ((device
7542 (##os-device-stream-open-predefined
7543 index
7544 (##psettings->device-flags psettings))))
7545 (if (##fixnum? device)
7546 (##exit-with-err-code device)
7547 (and device
7548 (##make-device-port-from-single-device
7549 name
7550 device
7551 psettings)))))))
7553 (define ##stdin-port #f)
7554 (define ##stdout-port #f)
7555 (define ##stderr-port #f)
7556 (define ##console-port #f)
7558 (define-prim (console-port)
7559 ##console-port)
7561 (define-prim (##open-all-predefined)
7562 (set! ##stdin-port
7563 (##open-predefined (macro-direction-in) '(stdin) -1))
7564 (set! ##stdout-port
7565 (##open-predefined (macro-direction-out) '(stdout) -2))
7566 (set! ##stderr-port
7567 (##open-predefined (macro-direction-out) '(stderr) -3))
7568 (set! ##console-port
7569 (##open-predefined (macro-direction-inout) '(console) -4)))
7571 (define-prim (##force-output-on-predefined)
7572 (let ((port ##stdout-port)) (and port (##force-output port)))
7573 (let ((port ##stderr-port)) (and port (##force-output port)))
7574 (let ((port ##console-port)) (and port (##force-output port))))
7576 (##add-exit-job! ##force-output-on-predefined)
7578 ;;;----------------------------------------------------------------------------
7580 (##define-macro (macro-peek-next-char-or-eof re) ;; possibly returns end-of-file
7581 `(macro-peek-char (macro-readenv-port ,re)))
7583 (##define-macro (macro-read-next-char-or-eof re) ;; possibly returns end-of-file
7584 `(macro-read-char (macro-readenv-port ,re)))
7586 (define-prim (##make-filepos line col char-count)
7587 (if (and (##fixnum.< line (macro-max-lines))
7588 (##not (##fixnum.< (macro-max-fixnum32-div-max-lines) col)))
7589 (##fixnum.+ line (##fixnum.* col (macro-max-lines)))
7590 (##fixnum.- 0 char-count)))
7592 (define-prim (##filepos-line filepos)
7593 (if (##fixnum.< filepos 0)
7594 0
7595 (##fixnum.modulo filepos (macro-max-lines))))
7597 (define-prim (##filepos-col filepos)
7598 (if (##fixnum.< filepos 0)
7599 (##fixnum.- 0 filepos)
7600 (##fixnum.quotient filepos (macro-max-lines))))
7602 ;;;----------------------------------------------------------------------------
7604 ;;; Implementation of readtables.
7606 (implement-check-type-readtable)
7608 (define-prim (##readtable? obj)
7609 (macro-readtable? obj))
7611 (define-prim (readtable? obj)
7612 (macro-force-vars (obj)
7613 (macro-readtable? obj)))
7615 (define-prim (##readtable-copy-shallow rt)
7616 (let ((copy (##vector-copy rt)))
7617 (##subtype-set! copy (macro-subtype-structure))
7618 copy))
7620 (define-prim (##readtable-copy rt)
7621 (let ((copy (##readtable-copy-shallow rt)))
7622 (macro-readtable-char-delimiter?-table-set!
7623 rt
7624 (##chartable-copy (macro-readtable-char-delimiter?-table rt)))
7625 (macro-readtable-char-handler-table-set!
7626 rt
7627 (##chartable-copy (macro-readtable-char-handler-table rt)))
7628 (macro-readtable-char-sharp-handler-table-set!
7629 rt
7630 (##chartable-copy (macro-readtable-char-sharp-handler-table rt)))
7631 copy))
7633 (define-prim (readtable-case-conversion? rt)
7634 (macro-force-vars (rt)
7635 (macro-check-readtable rt 1 (readtable-case-conversion? rt)
7636 (macro-readtable-case-conversion? rt))))
7638 (define-prim (readtable-case-conversion?-set rt conversion?)
7639 (macro-force-vars (rt conversion?)
7640 (macro-check-readtable rt 1 (readtable-case-conversion?-set rt conversion?)
7641 (let ((new-rt (##readtable-copy-shallow rt)))
7642 (macro-readtable-case-conversion?-set! new-rt conversion?)
7643 new-rt))))
7645 (define-prim (readtable-keywords-allowed? rt)
7646 (macro-force-vars (rt)
7647 (macro-check-readtable rt 1 (readtable-keywords-allowed? rt)
7648 (macro-readtable-keywords-allowed? rt))))
7650 (define-prim (readtable-keywords-allowed?-set rt allowed?)
7651 (macro-force-vars (rt allowed?)
7652 (macro-check-readtable rt 1 (readtable-keywords-allowed?-set rt allowed?)
7653 (let ((new-rt (##readtable-copy-shallow rt)))
7654 (macro-readtable-keywords-allowed?-set! new-rt allowed?)
7655 new-rt))))
7657 (define-prim (readtable-sharing-allowed? rt)
7658 (macro-force-vars (rt)
7659 (macro-check-readtable rt 1 (readtable-sharing-allowed? rt)
7660 (macro-readtable-sharing-allowed? rt))))
7662 (define-prim (readtable-sharing-allowed?-set rt allowed?)
7663 (macro-force-vars (rt allowed?)
7664 (macro-check-readtable rt 1 (readtable-sharing-allowed?-set rt allowed?)
7665 (let ((new-rt (##readtable-copy-shallow rt)))
7666 (macro-readtable-sharing-allowed?-set! new-rt allowed?)
7667 new-rt))))
7669 (define-prim (readtable-eval-allowed? rt)
7670 (macro-force-vars (rt)
7671 (macro-check-readtable rt 1 (readtable-eval-allowed? rt)
7672 (macro-readtable-eval-allowed? rt))))
7674 (define-prim (readtable-eval-allowed?-set rt allowed?)
7675 (macro-force-vars (rt allowed?)
7676 (macro-check-readtable rt 1 (readtable-eval-allowed?-set rt allowed?)
7677 (let ((new-rt (##readtable-copy-shallow rt)))
7678 (macro-readtable-eval-allowed?-set! new-rt allowed?)
7679 new-rt))))
7681 (define-prim (readtable-write-extended-read-macros? rt)
7682 (macro-force-vars (rt)
7683 (macro-check-readtable rt 1 (readtable-write-extended-read-macros? rt)
7684 (macro-readtable-write-extended-read-macros? rt))))
7686 (define-prim (readtable-write-extended-read-macros?-set rt allowed?)
7687 (macro-force-vars (rt allowed?)
7688 (macro-check-readtable rt 1 (readtable-write-extended-read-macros?-set rt allowed?)
7689 (let ((new-rt (##readtable-copy-shallow rt)))
7690 (macro-readtable-write-extended-read-macros?-set! new-rt allowed?)
7691 new-rt))))
7693 (define-prim (readtable-write-cdr-read-macros? rt)
7694 (macro-force-vars (rt)
7695 (macro-check-readtable rt 1 (readtable-write-cdr-read-macros? rt)
7696 (macro-readtable-write-cdr-read-macros? rt))))
7698 (define-prim (readtable-write-cdr-read-macros?-set rt allowed?)
7699 (macro-force-vars (rt allowed?)
7700 (macro-check-readtable rt 1 (readtable-write-cdr-read-macros?-set rt allowed?)
7701 (let ((new-rt (##readtable-copy-shallow rt)))
7702 (macro-readtable-write-cdr-read-macros?-set! new-rt allowed?)
7703 new-rt))))
7705 (define-prim (readtable-max-write-level rt)
7706 (macro-force-vars (rt)
7707 (macro-check-readtable rt 1 (readtable-max-write-level rt)
7708 (macro-readtable-max-write-level rt))))
7710 (define-prim (readtable-max-write-level-set rt level)
7711 (macro-force-vars (rt level)
7712 (macro-check-readtable rt 1 (readtable-max-write-level-set rt level)
7713 (macro-check-index level 2 (readtable-max-write-level-set rt level)
7714 (let ((new-rt (##readtable-copy-shallow rt)))
7715 (macro-readtable-max-write-level-set! new-rt level)
7716 new-rt)))))
7718 (define-prim (readtable-max-write-length rt)
7719 (macro-force-vars (rt)
7720 (macro-check-readtable rt 1 (readtable-max-write-length rt)
7721 (macro-readtable-max-write-length rt))))
7723 (define-prim (readtable-max-write-length-set rt length)
7724 (macro-force-vars (rt length)
7725 (macro-check-readtable rt 1 (readtable-max-write-length-set rt length)
7726 (macro-check-index length 2 (readtable-max-write-length-set rt length)
7727 (let ((new-rt (##readtable-copy-shallow rt)))
7728 (macro-readtable-max-write-length-set! new-rt length)
7729 new-rt)))))
7731 (define-prim (readtable-max-unescaped-char rt)
7732 (macro-force-vars (rt)
7733 (macro-check-readtable rt 1 (readtable-max-unescaped-char rt)
7734 (macro-readtable-max-unescaped-char rt))))
7736 (define-prim (readtable-max-unescaped-char-set rt char)
7737 (macro-force-vars (rt char)
7738 (macro-check-readtable rt 1 (readtable-max-unescaped-char-set rt char)
7739 (macro-check-char char 2 (readtable-max-unescaped-char-set rt char)
7740 (let ((new-rt (##readtable-copy-shallow rt)))
7741 (macro-readtable-max-unescaped-char-set! new-rt char)
7742 new-rt)))))
7744 (define-prim (readtable-start-syntax rt)
7745 (macro-force-vars (rt)
7746 (macro-check-readtable rt 1 (readtable-start-syntax rt)
7747 (macro-readtable-start-syntax rt))))
7749 (define-prim (readtable-start-syntax-set rt start)
7750 (macro-force-vars (rt start)
7751 (macro-check-readtable rt 1 (readtable-start-syntax-set rt start)
7752 (let ((new-rt (##readtable-copy-shallow rt)))
7753 (macro-readtable-start-syntax-set! new-rt start)
7754 new-rt))))
7756 (define ##scheme-file-extensions #f)
7757 (set! ##scheme-file-extensions
7758 '((".scm" . #f)
7759 (".six" . six)))
7761 (define ##language-specs #f)
7762 (set! ##language-specs '(
7763 ;; name keywords-allowed? start-syntax
7764 ;; \ case-conversion? \ / srfi-22?
7765 ;; \ \ \ / /
7766 #("gsi" #f #t scm #f)
7767 #("six" #f #t six #f)
7768 #("gsi-script" #f #t scm #f)
7769 #("six-script" #f #t six #f)
7770 #("scheme-srfi-0" #t #f scm #t)
7771 #("scheme-r5rs" #t #f scm #t)
7772 #("scheme-r4rs" #t #f scm #t)
7773 #("scheme-ieee-1178-1990" #t #f scm #t)
7774 ))
7776 (define-prim (##extract-language-and-tail script-line-or-program-path)
7778 (define (constituent? c)
7779 (or (##char-alphabetic? c)
7780 (##char-numeric? c)
7781 (##char=? c #\-)
7782 (##char=? c #\_)))
7784 (and script-line-or-program-path
7785 (let loop1 ((start 0))
7786 (let loop2 ((end start))
7788 (define (next)
7789 (if (##fixnum.< end
7790 (##string-length script-line-or-program-path))
7791 (loop1 (##fixnum.+ end 1))
7792 #f))
7794 (if (and (##fixnum.<
7795 end
7796 (##string-length script-line-or-program-path))
7797 (let ((c (##string-ref script-line-or-program-path end)))
7798 (constituent? c)))
7799 (loop2 (##fixnum.+ end 1))
7800 (if (##fixnum.= start end)
7801 (next)
7802 (let loop3 ((lst ##language-specs))
7803 (if (##pair? lst)
7804 (let* ((language (##car lst))
7805 (name (macro-language-name language))
7806 (len (##string-length name)))
7807 (if (##not (##fixnum.= (##fixnum.- end start) len))
7808 (loop3 (##cdr lst))
7809 (let loop4 ((j start) (k 0))
7810 (if (##fixnum.< j end)
7811 (if (##char=? (##string-ref
7812 script-line-or-program-path
7813 j)
7814 (##string-ref name k))
7815 (loop4 (##fixnum.+ j 1)
7816 (##fixnum.+ k 1))
7817 (loop3 (##cdr lst)))
7818 (let loop5 ((end end))
7819 (if (##fixnum.< (##fixnum.+ end 2)
7820 (##string-length
7821 script-line-or-program-path))
7822 (if (and (##char=? (##string-ref
7823 script-line-or-program-path
7824 end)
7825 #\space)
7826 (##char=? (##string-ref
7827 script-line-or-program-path
7828 (##fixnum.+ end 1))
7829 #\-)
7830 (##char=? (##string-ref
7831 script-line-or-program-path
7832 (##fixnum.+ end 2))
7833 #\:))
7834 (##cons language
7835 (##substring
7836 script-line-or-program-path
7837 (##fixnum.+ end 1)
7838 (##string-length
7839 script-line-or-program-path)))
7840 (loop5 (##fixnum.+ end 1)))
7841 (##cons language
7842 "")))))))
7843 (next)))))))))
7845 (define-prim (##readtable-setup-for-language! rt language)
7846 (macro-readtable-case-conversion?-set!
7847 rt
7848 (macro-language-case-conversion? language))
7849 (macro-readtable-keywords-allowed?-set!
7850 rt
7851 (macro-language-keywords-allowed? language))
7852 (macro-readtable-start-syntax-set!
7853 rt
7854 (macro-language-start-syntax language))
7855 (##readtable-setup-for-standard-level! rt))
7857 (define-prim (##readtable-setup-for-standard-level! rt)
7858 (let ((standard-level (##get-standard-level)))
7859 (cond ((##fixnum.= 1 standard-level)
7860 (macro-readtable-case-conversion?-set! rt #f)
7861 (macro-readtable-keywords-allowed?-set! rt #t))
7862 ((##fixnum.< 1 standard-level)
7863 (macro-readtable-case-conversion?-set! rt #t)
7864 (macro-readtable-keywords-allowed?-set! rt #f)))))
7866 (define-prim (##make-readtable-parameter readtable)
7867 (##make-parameter
7868 readtable
7869 (lambda (val)
7870 (macro-check-readtable val 1 (##make-readtable-parameter val)
7871 val))))
7873 ;;(define main #f)
7874 ;;(set! main #f)
7875 ;;
7876 ;;(define-prim (main . args) ;; predefine main procedure so scripts don't have to
7877 ;; 0)
7879 (define-prim (##start-main language)
7880 (cond ((macro-language-srfi-22? language)
7881 (lambda ()
7882 (let ((status (##eval '(main (##cdr ##processed-command-line)))))
7883 (if (##fixnum? status)
7884 (##exit status)
7885 (##exit-abnormally)))))
7886 (else
7887 (lambda ()
7888 (##eval '(##apply main (##cdr ##processed-command-line)))
7889 (##exit)))))
7891 (##define-macro (macro-ctrl-char? c)
7892 `(or (##char<? ,c #\space) (##char=? ,c #\delete)))
7894 (##define-macro (macro-gt-max-unescaped-char? rt c)
7895 `(##char<? (macro-readtable-max-unescaped-char ,rt) ,c))
7897 (##define-macro (macro-must-escape-char? rt c)
7898 `(or (macro-ctrl-char? ,c)
7899 (macro-gt-max-unescaped-char? ,rt ,c)))
7901 ;;;----------------------------------------------------------------------------
7903 (begin
7905 (define-prim (##make-marktable)
7906 (##declare (not interrupts-enabled))
7907 (##vector -1 '()))
7909 (define-prim (##marktable-mark! table obj)
7910 (##declare (not interrupts-enabled))
7911 (let ((alist (##vector-ref table 1)))
7912 (let ((x (##assq obj alist)));;;;;;;;;;;;;
7913 (if x
7914 (begin
7915 (##set-cdr! x #t)
7916 #f)
7917 (begin
7918 (##vector-set! table 1 (##cons (##cons obj #f) alist))
7919 #t)))))
7921 (define-prim (##marktable-lookup! table obj stamp?)
7922 (##declare (not interrupts-enabled))
7923 (let ((alist (##vector-ref table 1)))
7924 (let ((x (##assq obj alist)));;;;;;;;;;;;;;;;
7925 (if x
7926 (let ((id (##cdr x)))
7927 (if (and stamp? (##eq? id #t))
7928 (let ((n (##fixnum.+ (##vector-ref table 0) 1)))
7929 (##vector-set! table 0 n)
7930 (##set-cdr! x n)
7931 x)
7932 id))
7933 #f))))
7935 (define-prim (##marktable-save table)
7936 (##declare (not interrupts-enabled))
7937 (##vector-ref table 0))
7939 (define-prim (##marktable-restore! table n)
7940 (##declare (not interrupts-enabled))
7941 (##vector-set! table 0 n)
7942 (let ((alist (##vector-ref table 1)))
7943 (let loop ((lst alist))
7944 (if (##pair? lst)
7945 (let* ((x (##car lst))
7946 (id (##cdr x)))
7947 (if (and (##fixnum? id)
7948 (##fixnum.< n id))
7949 (##set-cdr! x #t))
7950 (loop (##cdr lst)))))))
7951 )
7953 ;;;----------------------------------------------------------------------------
7955 (define-prim (##might-write-differently? old-obj new-obj)
7956 (cond ((##eq? old-obj new-obj)
7957 (or (##pair? new-obj)
7958 (and (##subtyped? new-obj)
7959 (##not (or (##complex? new-obj)
7960 (##symbol? new-obj)
7961 (##keyword? new-obj))))))
7962 ((##complex? old-obj)
7963 (##not (and (##complex? new-obj)
7964 (##= old-obj new-obj))))
7965 (else
7966 #t)))
7968 ;;;----------------------------------------------------------------------------
7970 (define-prim (##default-wr we obj)
7971 (let ((limit (macro-writeenv-limit we)))
7972 (if (##fixnum.< 0 limit)
7973 (cond ((##symbol? obj)
7974 (##wr-symbol we obj))
7975 ((##keyword? obj)
7976 (##wr-keyword we obj))
7977 ((##pair? obj)
7978 (##wr-pair we obj))
7979 ((##complex? obj)
7980 (##wr-complex we obj))
7981 ((##char? obj)
7982 (##wr-char we obj))
7983 ((##string? obj)
7984 (##wr-string we obj))
7985 ((##vector? obj)
7986 (##wr-vector we obj))
7987 ((##foreign? obj)
7988 (##wr-foreign we obj))
7989 ((##procedure? obj)
7990 (##wr-procedure we obj))
7991 ((##will? obj)
7992 (##wr-will we obj))
7993 ((##promise? obj)
7994 (##wr-promise we obj))
7995 ((##s8vector? obj)
7996 (##wr-s8vector we obj))
7997 ((##u8vector? obj)
7998 (##wr-u8vector we obj))
7999 ((##s16vector? obj)
8000 (##wr-s16vector we obj))
8001 ((##u16vector? obj)
8002 (##wr-u16vector we obj))
8003 ((##s32vector? obj)
8004 (##wr-s32vector we obj))
8005 ((##u32vector? obj)
8006 (##wr-u32vector we obj))
8007 ((##s64vector? obj)
8008 (##wr-s64vector we obj))
8009 ((##u64vector? obj)
8010 (##wr-u64vector we obj))
8011 ((##f32vector? obj)
8012 (##wr-f32vector we obj))
8013 ((##f64vector? obj)
8014 (##wr-f64vector we obj))
8015 ((##structure? obj)
8016 (##wr-structure we obj))
8017 ((##gc-hash-table? obj)
8018 (##wr-gc-hash-table we obj))
8019 ((##continuation? obj)
8020 (##wr-continuation we obj))
8021 ((##frame? obj)
8022 (##wr-frame we obj))
8023 ((##return? obj)
8024 (##wr-return we obj))
8025 ((##meroon? obj)
8026 (##wr-meroon we obj))
8027 ((##jazz? obj)
8028 (##wr-jazz we obj))
8029 ((##box? obj)
8030 (##wr-box we obj))
8031 (else
8032 (##wr-other we obj))))))
8034 (define ##wr #f)
8035 (set! ##wr ##default-wr)
8037 (define-prim (##wr-str we s)
8038 (##wr-substr we s 0 (##string-length s)))
8040 (define-prim (##wr-substr we s i j)
8041 (let ((limit (macro-writeenv-limit we)))
8042 (if (##fixnum.< 0 limit)
8043 (let ((len (##fixnum.- j i))
8044 (port (macro-writeenv-port we)))
8045 (if (##fixnum.< limit len)
8046 (begin
8047 (##write-substring s i (##fixnum.+ i limit) port)
8048 (macro-writeenv-limit-set! we 0))
8049 (begin
8050 (##write-substring s i j port)
8051 (macro-writeenv-limit-set! we (##fixnum.- limit len))))))))
8053 (define-prim (##wr-ch we c)
8054 (let ((limit (macro-writeenv-limit we)))
8055 (if (##fixnum.< 0 limit)
8056 (begin
8057 (##write-char c (macro-writeenv-port we))
8058 (macro-writeenv-limit-set! we (##fixnum.- limit 1))))))
8060 (define-prim (##wr-filler we n str)
8061 (let ((len (##string-length str)))
8062 (let loop ((i n))
8063 (if (##fixnum.< 0 i)
8064 (let ((x (if (##fixnum.< len i) len i)))
8065 (##wr-substr we str 0 x)
8066 (loop (##fixnum.- i x)))))))
8068 (define-prim (##wr-spaces we n)
8069 (##wr-filler we n " "))
8071 (define ##pretty-print-shifting-allowed? #f)
8072 (set! ##pretty-print-shifting-allowed? #t)
8074 (define-prim (##wr-indent we shifted-col)
8075 (##wr-ch we #\newline)
8076 (let ((col
8077 (if ##pretty-print-shifting-allowed?
8078 (let loop ()
8079 (define margin-width 15)
8080 (let* ((shift
8081 (macro-writeenv-shift we))
8082 (width
8083 (macro-writeenv-width we))
8084 (width/2
8085 (##fixnum.quotient width 2))
8086 (lo-lim
8087 (##fixnum.min
8088 margin-width
8089 (##fixnum.quotient width 5)))
8090 (hi-lim
8091 (##fixnum.max
8092 (##fixnum.- width margin-width)
8093 (##fixnum.quotient (##fixnum.* width 4) 5)))
8094 (col
8095 (##fixnum.- shifted-col shift)))
8096 (cond ((##fixnum.< col lo-lim)
8097 (if (##fixnum.= shift 0)
8098 col
8099 (let ((s (##fixnum.min shift width/2)))
8100 (macro-writeenv-shift-set!
8101 we
8102 (##fixnum.- shift s))
8103 (##wr-str we ";;")
8104 (##wr-filler we s ">>>>>>>>")
8105 (##wr-ch we #\newline)
8106 (loop))))
8107 ((##fixnum.> col hi-lim)
8108 (let ((s width/2))
8109 (macro-writeenv-shift-set!
8110 we
8111 (##fixnum.+ shift s))
8112 (##wr-str we ";;")
8113 (##wr-filler we s "<<<<<<<<")
8114 (##wr-ch we #\newline)
8115 (loop)))
8116 (else
8117 col))))
8118 shifted-col)))
8119 (##wr-spaces we (##fixnum.- col 1))))
8121 (define-prim (##shifted-column we)
8122 (##fixnum.+ (macro-writeenv-shift we)
8123 (##output-port-column (macro-writeenv-port we))))
8125 (define-prim (##wr-sn we obj type name)
8126 (case (macro-writeenv-style we)
8127 ((mark)
8128 (if (##wr-mark we obj)
8129 (begin
8130 (##wr-no-display we type)
8131 (if (##not (##eq? name (##void)))
8132 (##wr-no-display we name)))))
8133 (else
8134 (if (##wr-stamp we obj)
8135 (begin
8136 (##wr-str we "#<")
8137 (##wr-no-display we type)
8138 (##wr-str we " #")
8139 (##wr-str we (##number->string (##object->serial-number obj) 10))
8140 (if (##not (##eq? name (##void)))
8141 (begin
8142 (##wr-ch we #\space)
8143 (##wr-no-display we name)))
8144 (##wr-ch we #\>))))))
8146 (define-prim (##wr-no-display we obj)
8147 (let ((style (macro-writeenv-style we)))
8148 (case style
8149 ((display print)
8150 (macro-writeenv-style-set! we 'write)
8151 (##wr we obj)
8152 (macro-writeenv-style-set! we style))
8153 (else
8154 (##wr we obj)))))
8156 (define-prim (##wr-mark we obj)
8157 (let ((mt (macro-writeenv-marktable we)))
8158 (if mt
8159 (##marktable-mark! mt obj)
8160 #t)))
8162 (define-prim (##wr-stamp we obj)
8163 (let ((mt (macro-writeenv-marktable we)))
8164 (if mt
8165 (let ((id (##marktable-lookup! mt obj #t)))
8166 (if id
8167 (begin
8168 (##wr-ch we #\#)
8169 (if (##fixnum? id)
8170 (begin
8171 (##wr-str we (##number->string id 10))
8172 (##wr-ch we #\#)
8173 #f)
8174 (begin
8175 (##wr-str we (##number->string (##cdr id) 10))
8176 (##wr-ch we #\=)
8177 #t)))
8178 #t))
8179 #t)))
8181 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
8183 ;;; Write methods for each object type
8185 (define-prim (##wr-symbol we obj)
8186 (let ((uninterned? (##uninterned-symbol? obj)))
8187 (case (macro-writeenv-style we)
8188 ((mark)
8189 (if uninterned?
8190 (##wr-mark we obj)))
8191 (else
8192 (if (or (##not uninterned?)
8193 (##wr-stamp we obj))
8194 (begin
8195 (if uninterned?
8196 (##wr-str we "#:"))
8197 (let ((str (##symbol->string obj)))
8198 (if (case (macro-writeenv-style we)
8199 ((display print) #t)
8200 (else (##not (##escape-symbol? we str))))
8201 (##wr-str we str)
8202 (##wr-escaped-string we str #\|)))))))))
8204 (define-prim (##escape-symbol? we str)
8205 (let ((n (##string-length str)))
8206 (or (##fixnum.= n 0)
8207 (and (##fixnum.= n 1)
8208 (##char=? (##string-ref str 0) #\.))
8209 (and (##char=? (##string-ref str 0) #\#)
8210 (or (##fixnum.= n 1)
8211 (let ((next (##string-ref str 1)))
8212 (and (##not (##char=? next #\#))
8213 (##not (##char=? next #\%))))))
8214 (##string->number str 10 #t)
8215 (and (##fixnum.< 1 n)
8216 (let ((keywords-allowed?
8217 (macro-readtable-keywords-allowed?
8218 (macro-writeenv-readtable we))))
8219 (and keywords-allowed?
8220 (##char=? (##string-ref
8221 str
8222 (if (##eq? keywords-allowed? 'prefix)
8223 0
8224 (##fixnum.- n 1)))
8225 #\:))))
8226 (##escape-symkey? we str))))
8228 (define-prim (##escape-symkey? we str);;;;;;;;;;;;;;;;;;;;;;;;;;
8229 (let ((n (##string-length str)))
8230 (let loop ((i (##fixnum.- n 1)))
8231 (if (##fixnum.< i 0)
8232 #f
8233 (let ((c (##string-ref str i))
8234 (rt (macro-writeenv-readtable we)))
8235 (or (macro-must-escape-char? rt c)
8236 (##readtable-char-delimiter? rt c)
8237 (##not (##char=? c (##readtable-convert-case rt c)))
8238 (loop (##fixnum.- i 1))))))))
8240 (define-prim (##wr-keyword we obj)
8241 (let ((uninterned? (##uninterned-keyword? obj)))
8242 (case (macro-writeenv-style we)
8243 ((mark)
8244 (if uninterned?
8245 (##wr-mark we obj)))
8246 (else
8247 (if (or (##not uninterned?)
8248 (##wr-stamp we obj))
8249 (begin
8250 (if uninterned?
8251 (##wr-str we "#:"))
8252 (let* ((str
8253 (##keyword->string obj))
8254 (keywords-allowed?
8255 (macro-readtable-keywords-allowed?
8256 (macro-writeenv-readtable we))))
8257 (if (##eq? keywords-allowed? 'prefix)
8258 (##wr-ch we #\:))
8259 (if (case (macro-writeenv-style we)
8260 ((display) #t)
8261 (else (##not (##escape-keyword? we str))))
8262 (##wr-str we str)
8263 (##wr-escaped-string we str #\|))
8264 (if (##not (##eq? keywords-allowed? 'prefix))
8265 (##wr-ch we #\:)))))))))
8267 (define-prim (##escape-keyword? we str)
8268 (let ((n (##string-length str)))
8269 (or (##fixnum.= n 0)
8270 (and (##char=? (##string-ref str 0) #\#)
8271 (or (##fixnum.= n 1)
8272 (let ((next (##string-ref str 1)))
8273 (and (##not (##char=? next #\#))
8274 (##not (##char=? next #\%)))))
8275 (let ((keywords-allowed?
8276 (macro-readtable-keywords-allowed?
8277 (macro-writeenv-readtable we))))
8278 (##not (##eq? keywords-allowed? 'prefix))))
8279 (##escape-symkey? we str))))
8281 (define-prim (##wr-pair we obj)
8283 (define (force-if-required we x)
8284 (if (macro-writeenv-force? we)
8285 (##force x)
8286 x))
8288 (define (read-macro-prefix we head tail)
8290 (define (check-for-at-sign str1 str2)
8292 ;; We have to check that the next character written after the
8293 ;; comma won't be an "@" because the reader would interpret this
8294 ;; as a ",@" or "#,@" readmacro. The algorithm is slow but
8295 ;; correct and modular.
8297 (let ((limit (macro-writeenv-limit we)))
8298 (if (##fixnum.< 1 limit) ;; speed up ",,,,,,xxx" case
8299 (let* ((mt
8300 (macro-writeenv-marktable we))
8301 (state
8302 (and mt (##marktable-save mt)))
8303 (port
8304 (##open-output-string))
8305 (we2
8306 (##make-writeenv
8307 (macro-writeenv-style we)
8308 port
8309 (macro-writeenv-readtable we)
8310 mt
8311 (macro-writeenv-force? we)
8312 (macro-writeenv-width we)
8313 (macro-writeenv-shift we)
8314 (macro-writeenv-close-parens we)
8315 (macro-writeenv-level we)
8316 1)))
8317 (##wr we2 (##car tail))
8318 (if mt (##marktable-restore! mt state))
8319 (let ((str (##get-output-string port)))
8320 (if (or (##fixnum.< (##string-length str) 1)
8321 (##char=? (##string-ref str 0) #\@))
8322 str2 ;; force a space after the comma
8323 str1)))
8324 str1)))
8326 (and head
8327 (##pair? tail)
8328 (##null? (force-if-required we (##cdr tail)))
8329 (let ((mt (macro-writeenv-marktable we)))
8330 (##not (and mt
8331 (##marktable-lookup! mt tail #f))))
8332 (cond ((##eq? head
8333 (macro-readtable-quote-keyword
8334 (macro-writeenv-readtable we)))
8335 "'")
8336 ((##eq? head
8337 (macro-readtable-quasiquote-keyword
8338 (macro-writeenv-readtable we)))
8339 "`")
8340 ((##eq? head
8341 (macro-readtable-unquote-keyword
8342 (macro-writeenv-readtable we)))
8343 (check-for-at-sign "," ", "))
8344 ((##eq? head
8345 (macro-readtable-unquote-splicing-keyword
8346 (macro-writeenv-readtable we)))
8347 ",@")
8348 (else
8349 (and (macro-readtable-write-extended-read-macros?
8350 (macro-writeenv-readtable we))
8351 (cond ((##eq? head
8352 (macro-readtable-sharp-quote-keyword
8353 (macro-writeenv-readtable we)))
8354 "#'")
8355 ((##eq? head
8356 (macro-readtable-sharp-quasiquote-keyword
8357 (macro-writeenv-readtable we)))
8358 "#`")
8359 ((##eq? head
8360 (macro-readtable-sharp-unquote-keyword
8361 (macro-writeenv-readtable we)))
8362 (check-for-at-sign "#," "#, "))
8363 ((##eq? head
8364 (macro-readtable-sharp-unquote-splicing-keyword
8365 (macro-writeenv-readtable we)))
8366 "#,@")
8367 (else
8368 #f)))))))
8370 (define (wr-list-possibly-with-read-macro-prefix we obj plain-pretty-print?)
8371 (let* ((head
8372 (force-if-required we (##car obj)))
8373 (tail
8374 (force-if-required we (##cdr obj))))
8376 (define (parenthesized-normal)
8377 (wr-list-using-format
8378 we
8379 obj
8380 (##reader->open-close we ##read-list '("(" . ")"))
8381 (case (macro-writeenv-style we)
8382 ((pretty-print)
8383 (if plain-pretty-print?
8384 plain-format
8385 (get-format we head tail)))
8386 (else
8387 space-format))))
8389 (define (parenthesized-read-macro open-close)
8390 (wr-list-using-format
8391 we
8392 tail
8393 open-close
8394 (case (macro-writeenv-style we)
8395 ((pretty-print) plain-format)
8396 (else space-format))))
8398 (if (and head
8399 (or (##null? tail)
8400 (##pair? tail)))
8401 (cond ((##head->open-close we head #f)
8402 =>
8403 (lambda (open-close)
8404 (parenthesized-read-macro open-close)))
8405 (else
8406 (let ((prefix
8407 (read-macro-prefix we head tail)))
8408 (if prefix
8409 (begin
8410 (##wr-str we prefix)
8411 (##wr we (##car tail)))
8412 (parenthesized-normal)))))
8413 (parenthesized-normal))))
8415 (define space-format
8416 '#(0 #f 0 #f -1))
8418 (define plain-format
8419 '#(0 #f 1 #f 0))
8421 (define (get-format we head tail)
8422 (if (##symbol? head)
8423 (let ((x
8424 (##assq head
8425 (macro-readtable-pretty-print-formats
8426 (macro-writeenv-readtable we)))))
8427 (cond (x
8428 (if (and (##eq? head 'let) ;; check for named let
8429 (##pair? tail)
8430 (##symbol? (force-if-required we (##car tail))))
8431 '#(2 #t 3 #f 1)
8432 (##cdr x)))
8433 ((##fixnum.< (##string-length (##symbol->string head))
8434 ##list-max-head)
8435 '#(1 #f 0 #f 1))
8436 (else
8437 plain-format)))
8438 plain-format))
8440 (define (wr-list-using-format we obj open-close format)
8442 (##wr-str we (##car open-close))
8444 (let ((level
8445 (macro-writeenv-level we)))
8446 (if (##not (##fixnum.< level
8447 (macro-readtable-max-write-level
8448 (macro-writeenv-readtable we))))
8449 (##wr-str we "...")
8450 (let* ((close-parens
8451 (macro-writeenv-close-parens we))
8452 (new-close-parens
8453 (##fixnum.+ close-parens 1)))
8454 (macro-writeenv-level-set! we (##fixnum.+ level 1))
8455 (let ((start-col (##shifted-column we)))
8456 (let loop ((lst obj)
8457 (i 0)
8458 (col start-col))
8460 (define (wr-elem elem)
8461 (let ((new-col
8462 (cond ((##fixnum.= i 0)
8463 col)
8464 ((or (##fixnum.< (##vector-ref format 4) 0)
8465 (##fixnum.< i (##vector-ref format 0)))
8466 (##wr-ch we #\space)
8467 col)
8468 ((##fixnum.= i (##vector-ref format 0))
8469 (##wr-ch we #\space)
8470 (##shifted-column we))
8471 ((##fixnum.= i (##vector-ref format 2))
8472 (let ((new-col
8473 (##fixnum.+ start-col
8474 (##vector-ref format 4))))
8475 (##wr-indent we new-col)
8476 new-col))
8477 (else
8478 (##wr-indent we col)
8479 col))))
8480 (if (##pair? elem)
8481 (wr-list
8482 we
8483 elem
8484 (if (##fixnum.< i (##vector-ref format 2))
8485 (##vector-ref format 1)
8486 (##vector-ref format 3)))
8487 (##wr we elem))
8488 new-col))
8490 (define (wr-str str)
8491 (let ((style (macro-writeenv-style we)))
8492 (macro-writeenv-style-set! we 'print)
8493 (wr-elem str)
8494 (macro-writeenv-style-set! we style)))
8496 (if (##fixnum.< 0 (macro-writeenv-limit we))
8497 (cond ((##pair? lst)
8498 (if (##not (##fixnum.< i
8499 (macro-readtable-max-write-length
8500 (macro-writeenv-readtable we))))
8501 (wr-str "...")
8502 (let ((mt (macro-writeenv-marktable we)))
8503 (if (and (##fixnum.< 0 i)
8504 mt
8505 (##marktable-lookup! mt lst #f))
8506 (begin
8507 (wr-str ".")
8508 (macro-writeenv-close-parens-set!
8509 we
8510 new-close-parens)
8511 (wr-elem lst))
8512 (let* ((head
8513 (force-if-required we (##car lst)))
8514 (tail
8515 (force-if-required we (##cdr lst)))
8516 (prefix
8517 (and (macro-readtable-write-cdr-read-macros?
8518 (macro-writeenv-readtable we))
8519 (read-macro-prefix we head tail))))
8520 (if prefix
8521 (begin
8522 (wr-str ".")
8523 (wr-str prefix)
8524 (macro-writeenv-close-parens-set!
8525 we
8526 new-close-parens)
8527 (##wr we (##car tail)))
8528 (begin
8529 (macro-writeenv-close-parens-set!
8530 we
8531 (if (##null? tail)
8532 new-close-parens
8533 0))
8534 (loop tail
8535 (##fixnum.+ i 1)
8536 (wr-elem head)))))))))
8537 ((##not (##null? lst))
8538 (wr-str ".")
8539 (macro-writeenv-close-parens-set! we new-close-parens)
8540 (wr-elem lst))))))
8541 (macro-writeenv-level-set! we level)
8542 (macro-writeenv-close-parens-set! we close-parens))))
8544 (##wr-str we (##cdr open-close)))
8546 (define (wr-list we obj plain-pretty-print?)
8547 (if (##wr-stamp we obj)
8548 (if (case (macro-writeenv-style we)
8549 ((pretty-print)
8550 (##not (##wr-one-line-pretty-print
8551 we
8552 obj
8553 (lambda (we obj)
8554 (wr-list-possibly-with-read-macro-prefix
8555 we
8556 obj
8557 plain-pretty-print?)))))
8558 (else
8559 #t))
8560 (wr-list-possibly-with-read-macro-prefix
8561 we
8562 obj
8563 plain-pretty-print?))))
8565 (case (macro-writeenv-style we)
8566 ((mark)
8567 (if (##wr-mark we obj)
8568 (begin;;;;;;;;;;;;;;;;;;;;;;;check level and length?
8569 (##wr we (##car obj))
8570 (##wr we (##cdr obj)))))
8571 ((print)
8572 (##wr we (##car obj))
8573 (##wr we (##cdr obj)))
8574 (else
8575 (wr-list we obj #f))))
8577 (define-prim (##wr-one-line-pretty-print we obj wr-obj)
8578 (let* ((col
8579 (##shifted-column we))
8580 (available-space-for-obj
8581 (##fixnum.-
8582 (##fixnum.-
8583 (##fixnum.+
8584 (macro-writeenv-shift we)
8585 (macro-writeenv-width we))
8586 (macro-writeenv-close-parens we))
8587 col))
8588 (str
8589 (##wr-fits-on-line
8590 we
8591 obj
8592 wr-obj
8593 available-space-for-obj)))
8594 (and str
8595 (begin
8596 (##wr-str we str)
8597 #t))))
8599 (define-prim (##wr-fits-on-line we obj wr-obj available-space-for-obj)
8600 (let* ((mt
8601 (macro-writeenv-marktable we))
8602 (state
8603 (and mt (##marktable-save mt)))
8604 (port
8605 (##open-output-string))
8606 (we2
8607 (##make-writeenv
8608 'write
8609 port
8610 (macro-writeenv-readtable we)
8611 mt
8612 (macro-writeenv-force? we)
8613 (macro-writeenv-width we)
8614 (macro-writeenv-shift we)
8615 (macro-writeenv-close-parens we)
8616 (macro-writeenv-level we)
8617 (##fixnum.+ available-space-for-obj 1))))
8618 (wr-obj we2 obj)
8619 (let ((str (##get-output-string port)))
8620 (if (##fixnum.< available-space-for-obj (##string-length str))
8621 (begin
8622 (if mt (##marktable-restore! mt state))
8623 #f)
8624 str))))
8626 (define-prim (##wr-complex we obj)
8627 (case (macro-writeenv-style we)
8628 ((mark)
8629 (if (##not (##fixnum? obj))
8630 (##wr-mark we obj)))
8631 (else
8632 (##wr-str we (##number->string obj 10)))))
8634 (define-prim (##wr-char we obj)
8635 (case (macro-writeenv-style we)
8636 ((mark)
8637 #f)
8638 ((display print)
8639 (##wr-ch we obj))
8640 (else
8641 (let ((x (##assq-cdr obj
8642 (macro-readtable-named-char-table
8643 (macro-writeenv-readtable we)))))
8644 (##wr-str we "#\\")
8645 (cond (x
8646 (##wr-str we (##car x)))
8647 ((##not (macro-must-escape-char?
8648 (macro-writeenv-readtable we)
8649 obj))
8650 (##wr-ch we obj))
8651 (else
8652 (let ((n (##fixnum.<-char obj)))
8653 (cond ((##fixnum.< #xffff n)
8654 (##wr-ch we #\U)
8655 (##wr-hex we n 8))
8656 ((##fixnum.< #xff n)
8657 (##wr-ch we #\u)
8658 (##wr-hex we n 4))
8659 (else
8660 (##wr-ch we #\x)
8661 (##wr-hex we n 2))))))))))
8663 (define-prim (##wr-hex we n nb-digits)
8664 (if (if nb-digits
8665 (##fixnum.< 1 nb-digits)
8666 (##fixnum.< 15 n))
8667 (##wr-hex we
8668 (##fixnum.arithmetic-shift-right n 4)
8669 (and nb-digits (##fixnum.- nb-digits 1))))
8670 (##wr-ch we
8671 (##string-ref ##digit-to-char-table (##fixnum.bitwise-and n 15))))
8673 (define-prim (##wr-oct we n nb-digits)
8674 (if (if nb-digits
8675 (##fixnum.< 1 nb-digits)
8676 (##fixnum.< 7 n))
8677 (##wr-oct we
8678 (##fixnum.arithmetic-shift-right n 3)
8679 (and nb-digits (##fixnum.- nb-digits 1))))
8680 (##wr-ch we
8681 (##string-ref ##digit-to-char-table (##fixnum.bitwise-and n 7))))
8683 (define-prim (##wr-string we obj)
8684 (case (macro-writeenv-style we)
8685 ((mark)
8686 (##wr-mark we obj))
8687 ((display print)
8688 (##wr-str we obj))
8689 (else
8690 (if (##wr-stamp we obj)
8691 (##wr-escaped-string we obj #\")))))
8693 (define-prim (##wr-escaped-string we s special-escape)
8694 (##wr-ch we special-escape)
8695 (let loop ((i 0) (j 0) (escape-digit-limit #f))
8696 (if (##fixnum.< j (##string-length s))
8697 (let* ((c
8698 (##string-ref s j))
8699 (n
8700 (##fixnum.<-char c))
8701 (ctrl-char?
8702 (macro-ctrl-char? c))
8703 (x
8704 (cond ((or (##char=? c #\\)
8705 (##char=? c special-escape))
8706 c)
8707 ((and ctrl-char?
8708 (##assq-cdr c
8709 (macro-readtable-escaped-char-table
8710 (macro-writeenv-readtable we))))
8711 =>
8712 ##car)
8713 (else
8714 #f)))
8715 (j+1
8716 (##fixnum.+ j 1)))
8717 (if (if ctrl-char?
8718 (macro-readtable-escape-ctrl-chars?
8719 (macro-writeenv-readtable we))
8720 (or x
8721 (macro-gt-max-unescaped-char? (macro-writeenv-readtable we) c)
8722 (and escape-digit-limit
8723 (##fixnum.< n 128)
8724 (##not (##char=? c #\#)) ;; avoid treating "#" like "0"
8725 (##fixnum.< (##u8vector-ref ##char-to-digit-table n)
8726 escape-digit-limit))))
8727 (begin
8728 (##wr-substr we s i j)
8729 (##wr-ch we #\\)
8730 (cond (x
8731 (##wr-ch we x)
8732 (loop j+1 j+1 #f))
8733 ((##fixnum.< #xffff n)
8734 (##wr-ch we #\U)
8735 (##wr-hex we n 8)
8736 (loop j+1 j+1 #f))
8737 ((##fixnum.< #xff n)
8738 (##wr-ch we #\u)
8739 (##wr-hex we n 4)
8740 (loop j+1 j+1 #f))
8741 #; ;; disable \x... escapes on output
8742 (#t
8743 (##wr-ch we #\x)
8744 (##wr-hex we n #f)
8745 (loop j+1 j+1 16))
8746 (else
8747 (##wr-oct we n #f)
8748 (loop j+1 j+1 (if (##fixnum.< n 32) 8 #f)))))
8749 (loop i j+1 #f)))
8750 (begin
8751 (##wr-substr we s i j)
8752 (##wr-ch we special-escape)))))
8754 (define-prim (##reader->open-close we reader default)
8755 (let ((rt (macro-writeenv-readtable we)))
8756 (cond ((##eq? (##readtable-char-handler rt #\() reader) '("(" . ")"))
8757 ((##eq? (##readtable-char-handler rt #\[) reader) '("[" . "]"))
8758 ((##eq? (##readtable-char-handler rt #\{) reader) '("{" . "}"))
8759 ((##eq? (##readtable-char-handler rt #\<) reader) '("<" . ">"))
8760 (else default))))
8762 (define-prim (##head->open-close we head default)
8763 (let ((rt (macro-writeenv-readtable we)))
8764 (cond ((##eq? head (macro-readtable-paren-keyword rt)) '("(" . ")"))
8765 ((##eq? head (macro-readtable-bracket-keyword rt)) '("[" . "]"))
8766 ((##eq? head (macro-readtable-brace-keyword rt)) '("{" . "}"))
8767 ((##eq? head (macro-readtable-angle-keyword rt)) '("<" . ">"))
8768 (else default))))
8770 (define-prim (##wr-vector we obj)
8771 (let* ((std-open-close
8772 '("#(" . ")"))
8773 (open-close
8774 (if (macro-readtable-r6rs-compatible-write?
8775 (macro-writeenv-readtable we))
8776 std-open-close
8777 (##reader->open-close we ##read-vector-or-list std-open-close))))
8778 (##wr-vector-aux1 we obj (##vector-length obj) ##vector-ref open-close)))
8780 (define-prim (##wr-vector-aux1 we obj len vect-ref open-close)
8781 (case (macro-writeenv-style we)
8782 ((mark)
8783 (if (##wr-mark we obj)
8784 (##wr-vector-aux2 we obj len vect-ref)))
8785 ((print)
8786 (##wr-vector-aux2 we obj len vect-ref))
8787 (else
8788 (if (##wr-stamp we obj)
8789 (##wr-vector-aux3 we obj len vect-ref open-close)))))
8791 (define-prim (##wr-vector-aux2 we obj len vect-ref)
8792 (let ((level
8793 (macro-writeenv-level we)))
8794 (if (##fixnum.< level
8795 (macro-readtable-max-write-level
8796 (macro-writeenv-readtable we)))
8797 (begin
8798 (macro-writeenv-level-set! we (##fixnum.+ level 1))
8799 (let loop ((i 0))
8800 (if (##fixnum.< i len)
8801 (if (##fixnum.< i
8802 (macro-readtable-max-write-length
8803 (macro-writeenv-readtable we)))
8804 (begin
8805 (##wr we (vect-ref obj i))
8806 (loop (##fixnum.+ i 1))))))
8807 (macro-writeenv-level-set! we level)))))
8809 (define-prim (##wr-vector-aux3 we obj len vect-ref open-close)
8811 (define (wr-vect we obj len vect-ref open-close)
8813 (##wr-str we (##car open-close))
8815 (let ((level
8816 (macro-writeenv-level we)))
8817 (if (##not (##fixnum.< level
8818 (macro-readtable-max-write-level
8819 (macro-writeenv-readtable we))))
8820 (##wr-str we "...")
8821 (let* ((close-parens
8822 (macro-writeenv-close-parens we))
8823 (new-close-parens
8824 (##fixnum.+ close-parens 1)))
8825 (macro-writeenv-level-set! we (##fixnum.+ level 1))
8826 (let ((start-col
8827 (##shifted-column we)))
8828 (let loop ((i 0))
8829 (if (##fixnum.< 0 (macro-writeenv-limit we))
8830 (if (##fixnum.< i len)
8831 (let ()
8832 (if (##fixnum.< 0 i)
8833 (case (macro-writeenv-style we)
8834 ((pretty-print) (##wr-indent we start-col))
8835 (else (##wr-ch we #\space))))
8836 (if (##not (##fixnum.< i
8837 (macro-readtable-max-write-length
8838 (macro-writeenv-readtable we))))
8839 (##wr-str we "...")
8840 (let ((elem
8841 (vect-ref obj i))
8842 (new-i
8843 (##fixnum.+ i 1)))
8844 (macro-writeenv-close-parens-set!
8845 we
8846 (if (##fixnum.= new-i len)
8847 new-close-parens
8848 0))
8849 (##wr we elem)
8850 (loop new-i))))))))
8851 (macro-writeenv-level-set! we level)
8852 (macro-writeenv-close-parens-set! we close-parens))))
8854 (##wr-str we (##cdr open-close)))
8856 (if (case (macro-writeenv-style we)
8857 ((pretty-print)
8858 (##not (##wr-one-line-pretty-print
8859 we
8860 obj
8861 (lambda (we obj)
8862 (wr-vect we obj len vect-ref open-close)))))
8863 (else
8864 #t))
8865 (wr-vect we obj len vect-ref open-close)))
8867 (define-prim (##wr-foreign we obj)
8868 (case (macro-writeenv-style we)
8869 ((mark)
8870 (##wr-mark we obj))
8871 (else
8872 (let ((tags (##foreign-tags obj)))
8873 (##wr-str we "#<")
8874 (if (##pair? tags)
8875 (##wr-no-display we (##car tags))
8876 (##wr-str we "foreign"))
8877 (##wr-str we " #")
8878 (##wr-str we (##number->string (##object->serial-number obj) 10))
8879 (##wr-str we " 0x")
8880 (##wr-str we (##number->string (##foreign-address obj) 16))
8881 (##wr-ch we #\>)))))
8883 (define-prim (##explode-object obj)
8884 (##vector-copy obj))
8886 (define-prim (##implode-object re fields subtype)
8887 (let* ((n (##vector-length fields))
8888 (v (##make-vector n)))
8889 (##subtype-set! v subtype)
8890 (let loop ((i (##fixnum.- n 1)))
8891 (if (##fixnum.< i 0)
8892 v
8893 (let ((obj (##vector-ref fields i)))
8894 (if (##label-marker? obj)
8895 (##label-marker-fixup-handler-add!
8896 re
8897 obj
8898 (lambda (resolved-obj)
8899 (##vector-set! v i resolved-obj)))
8900 (##vector-set! v i obj))
8901 (loop (##fixnum.- i 1)))))))
8903 (define-prim (##explode-structure obj)
8904 (##explode-object obj))
8906 (define-prim (##implode-structure re fields)
8907 (##implode-object re fields (macro-subtype-structure)))
8909 ';old version... more type checks but incomplete type checks so why bother?
8910 (define-prim (##implode-structure re fields)
8911 (let ((nb-fields (##vector-length fields)))
8912 (if (##fixnum.< 0 nb-fields)
8913 (let ((n (##vector-length fields)))
8914 (let ((s (##make-vector n)))
8916 (define (set-element! i obj)
8917 (##vector-set! s i obj)
8918 (if (##fixnum.= i 0)
8919 (let ((n (##vector-length s)))
8920 (##subtype-set! s (macro-subtype-structure))
8921 (if (##not (and (##type? obj)
8922 (##fixnum.= (##type-field-count obj)
8923 (##fixnum.- n 1))))
8924 (##subtype-set! s (macro-subtype-vector))))))
8926 (let loop ((i (##fixnum.- n 1)))
8927 (if (##fixnum.< i 0)
8928 s
8929 (let ((obj (##vector-ref fields i)))
8930 (if (##label-marker? obj)
8931 (##label-marker-fixup-handler-add!
8932 re
8933 obj
8934 (lambda (resolved-obj)
8935 (set-element! i resolved-obj)))
8936 (set-element! i obj))
8937 (loop (##fixnum.- i 1)))))))
8938 #f)))
8940 (define-prim (##implode-frame re fields)
8941 (##implode-object re fields (macro-subtype-frame)))
8943 (define-prim (##implode-continuation re fields)
8944 (##implode-object re fields (macro-subtype-continuation)))
8946 (define-prim (##explode-procedure proc)
8947 (cond ((##closure? proc)
8948 (##explode-closure proc))
8949 (else
8950 (##explode-subprocedure proc '()))))
8952 (define-prim (##explode-closure closure)
8953 (let loop ((i (##fixnum.- (##closure-length closure) 1))
8954 (lst '()))
8955 (if (##fixnum.< i 1)
8956 (##explode-subprocedure (##closure-code closure) lst)
8957 (loop (##fixnum.- i 1)
8958 (##cons (##closure-ref closure i) lst)))))
8960 (define-prim (##explode-subprocedure subproc lst)
8961 (let ((parent-name
8962 (##subprocedure-parent-name subproc)))
8963 (if parent-name
8964 (##list->vector
8965 (##cons parent-name
8966 (let ((id (##subprocedure-id subproc)))
8967 (if (and (##fixnum.= id 0) (##null? lst))
8968 '()
8969 (##cons id lst)))))
8970 '#())))
8972 (define-prim (##implode-procedure re fields)
8973 (let ((x (##implode-procedure-or-return re fields)))
8974 (if (##procedure? x)
8975 x
8976 #f)))
8978 (define-prim (##implode-procedure-or-return re fields)
8979 ;;;;; why bother with all these checks if they are incomplete?
8980 (let ((nb-fields (##vector-length fields)))
8981 (if (##fixnum.= nb-fields 0)
8982 #f
8983 (let ((proc-identifier (##vector-ref fields 0)))
8984 (if (##symbol? proc-identifier)
8985 (let* ((var (##make-global-var proc-identifier))
8986 (proc (##global-var-primitive-ref var)))
8987 (if (and (##procedure? proc)
8988 (##not (##subprocedure? proc))
8989 (##not (##closure? proc)))
8990 (if (##fixnum.= nb-fields 1)
8991 proc
8992 (let ((subproc-id (##vector-ref fields 1)))
8993 (if (and (##fixnum? subproc-id)
8994 (##fixnum.< 0 subproc-id))
8995 (let ((subproc (##make-subprocedure proc subproc-id)))
8996 (if subproc
8997 (let* ((nb-closed (##subprocedure-nb-closed subproc))
8998 (n (##fixnum.- (##vector-length fields) 1)))
8999 (if (##fixnum.= (##fixnum.+ nb-closed 1) n)
9000 (if (##fixnum.= nb-closed 0)
9001 subproc
9002 (let ((c (##make-vector n subproc)))
9003 (##subtype-set! c (macro-subtype-procedure))
9004 (let loop ((i (##fixnum.- n 1)))
9005 (if (##fixnum.< i 1)
9006 c
9007 (let ((obj
9008 (##vector-ref fields
9009 (##fixnum.+ i 1))))
9010 (if (##label-marker? obj)
9011 (##label-marker-fixup-handler-add!
9012 re
9013 obj
9014 (lambda (resolved-obj)
9015 (##closure-set! c i resolved-obj)))
9016 (##closure-set! c i obj))
9017 (loop (##fixnum.- i 1)))))))
9018 #f))
9019 #f))
9020 #f)))
9021 #f))
9022 #f)))))
9024 ;;;;;;;;;;;;;;;;;; FIX THIS:
9025 ;;;;> '#0=#procedure(##make-default-entry-hook 2 #0#)
9026 ;;;;#0=#procedure(##make-default-entry-hook 2 #(#(source1) #0# (stdin) 262149))
9028 (define-prim (##explode-return ret)
9029 (##explode-subprocedure ret '()))
9031 (define-prim (##implode-return re fields)
9032 (let ((x (##implode-procedure-or-return re fields)))
9033 (if (##return? x)
9034 x
9035 #f)))
9037 (define-prim (##wr-opaque we obj explode open-close type name)
9038 (if (##eq? (macro-readtable-sharing-allowed?
9039 (macro-writeenv-readtable we))
9040 'serialize)
9041 (##wr-serialize we obj explode open-close)
9042 (##wr-sn we obj type name)))
9044 (define-prim (##wr-serialize we obj explode open-close)
9045 (case (macro-writeenv-style we)
9046 ((mark)
9047 (if (##wr-mark we obj)
9048 (let ((vect (explode obj)))
9049 (##wr-vector-aux2
9050 we
9051 vect
9052 (##vector-length vect)
9053 ##vector-ref))))
9054 (else
9055 (if (##wr-stamp we obj)
9056 (let ((vect (explode obj)))
9057 (##wr-vector-aux3
9058 we
9059 vect
9060 (##vector-length vect)
9061 ##vector-ref
9062 open-close))))))
9064 (define-prim (##wr-s8vector we obj)
9065 (##wr-vector-aux1 we obj (##s8vector-length obj) ##s8vector-ref '("#s8(" . ")")))
9067 (define-prim (##wr-u8vector we obj)
9068 (##wr-vector-aux1 we obj (##u8vector-length obj) ##u8vector-ref '("#u8(" . ")")))
9070 (define-prim (##wr-s16vector we obj)
9071 (##wr-vector-aux1 we obj (##s16vector-length obj) ##s16vector-ref '("#s16(" . ")")))
9073 (define-prim (##wr-u16vector we obj)
9074 (##wr-vector-aux1 we obj (##u16vector-length obj) ##u16vector-ref '("#u16(" . ")")))
9076 (define-prim (##wr-s32vector we obj)
9077 (##wr-vector-aux1 we obj (##s32vector-length obj) ##s32vector-ref '("#s32(" . ")")))
9079 (define-prim (##wr-u32vector we obj)
9080 (##wr-vector-aux1 we obj (##u32vector-length obj) ##u32vector-ref '("#u32(" . ")")))
9082 (define-prim (##wr-s64vector we obj)
9083 (##wr-vector-aux1 we obj (##s64vector-length obj) ##s64vector-ref '("#s64(" . ")")))
9085 (define-prim (##wr-u64vector we obj)
9086 (##wr-vector-aux1 we obj (##u64vector-length obj) ##u64vector-ref '("#u64(" . ")")))
9088 (define-prim (##wr-f32vector we obj)
9089 (##wr-vector-aux1 we obj (##f32vector-length obj) ##f32vector-ref '("#f32(" . ")")))
9091 (define-prim (##wr-f64vector we obj)
9092 (##wr-vector-aux1 we obj (##f64vector-length obj) ##f64vector-ref '("#f64(" . ")")))
9094 (define-prim (##wr-structure we obj)
9096 (define (for-each-visible-field proc obj type last?)
9097 (if (##not type) ;; have we reached root of inheritance chain?
9098 1
9099 (let ((fields (##type-fields type)))
9100 (let loop1 ((i 0)
9101 (first #f)
9102 (last -1))
9103 (let ((i*3 (##fixnum.* i 3)))
9104 (if (##fixnum.< i*3 (##vector-length fields))
9105 (let ((field-attributes
9106 (##vector-ref fields (##fixnum.+ i*3 1))))
9107 (if (##fixnum.=
9108 (##fixnum.bitwise-and field-attributes 1)
9109 0)
9110 (loop1 (##fixnum.+ i 1)
9111 (or first i)
9112 i)
9113 (loop1 (##fixnum.+ i 1)
9114 first
9115 last)))
9116 (let ((start
9117 (for-each-visible-field
9118 proc
9119 obj
9120 (##type-super type)
9121 (if first #f last?))))
9122 (let loop2 ((i (or first 0)))
9123 (if (##not (##fixnum.< last i))
9124 (let* ((i*3
9125 (##fixnum.* i 3))
9126 (field-attributes
9127 (##vector-ref fields (##fixnum.+ i*3 1))))
9128 (if (##fixnum.=
9129 (##fixnum.bitwise-and field-attributes 1)
9130 0)
9131 (let ((field-name
9132 (##vector-ref fields i*3)))
9133 (proc (##string->keyword
9134 (##symbol->string field-name))
9135 (##unchecked-structure-ref
9136 obj
9137 (##fixnum.+ start i)
9138 type
9139 #f)
9140 (and last?
9141 (##fixnum.= i last)))))
9142 (loop2 (##fixnum.+ i 1)))))
9143 (##fixnum.+ start
9144 (##fixnum.quotient
9145 (##vector-length fields)
9146 3)))))))))
9148 (define (wr-structure we obj)
9149 (##wr-str we "#<")
9150 (let ((level
9151 (macro-writeenv-level we)))
9152 (if (##not (##fixnum.< level
9153 (macro-readtable-max-write-level
9154 (macro-writeenv-readtable we))))
9155 (##wr-str we "...")
9156 (let* ((type-col
9157 (##shifted-column we))
9158 (type
9159 (##structure-type obj))
9160 (close-parens
9161 (macro-writeenv-close-parens we))
9162 (new-close-parens
9163 (##fixnum.+ close-parens 1)))
9164 (macro-writeenv-level-set! we (##fixnum.+ level 1))
9165 (##wr-no-display we (##type-name type))
9166 (##wr-str we " ")
9167 (let* ((col
9168 (##shifted-column we))
9169 (start-col
9170 (if (##fixnum.< ##structure-max-head
9171 (##fixnum.- col type-col))
9172 (##fixnum.+ type-col ##structure-indent)
9173 col)))
9174 (##wr-str we "#")
9175 (##wr-str we (##number->string (##object->serial-number obj) 10))
9176 (for-each-visible-field
9177 (lambda (field-name value last?)
9178 (macro-writeenv-close-parens-set!
9179 we
9180 (if last?
9181 new-close-parens
9182 0))
9183 (case (macro-writeenv-style we)
9184 ((pretty-print)
9185 (##wr-indent we start-col)
9186 (##wr-no-display we field-name)
9187 (let ((col (##shifted-column we)))
9188 (if (##fixnum.< (##fixnum.- col start-col)
9189 ##structure-max-field)
9190 (begin
9191 (##wr-ch we #\space)
9192 (##wr-no-display we value))
9193 (let* ((available-space-for-obj
9194 (##fixnum.-
9195 (##fixnum.-
9196 (##fixnum.-
9197 (##fixnum.+
9198 (macro-writeenv-shift we)
9199 (macro-writeenv-width we))
9200 (macro-writeenv-close-parens we))
9201 col)
9202 1))
9203 (str
9204 (##wr-fits-on-line
9205 we
9206 value
9207 ##wr-no-display
9208 available-space-for-obj)))
9209 (if str
9210 (begin
9211 (##wr-ch we #\space)
9212 (##wr-str we str))
9213 (begin
9214 (##wr-indent
9215 we
9216 (##fixnum.+ start-col ##structure-indent))
9217 (##wr-no-display we value)))))))
9218 (else
9219 (##wr-ch we #\space)
9220 (##wr-no-display we field-name)
9221 (##wr-ch we #\space)
9222 (##wr-no-display we value))))
9223 obj
9224 type
9225 #t)
9226 (macro-writeenv-level-set! we level)))))
9227 (##wr-ch we #\>))
9229 (cond ((##eq? (macro-readtable-sharing-allowed?
9230 (macro-writeenv-readtable we))
9231 'serialize)
9232 (##wr-serialize we obj ##explode-structure '("#structure(" . ")")))
9233 ((macro-port? obj)
9234 (##wr-sn
9235 we
9236 obj
9237 (if (##input-port? obj)
9238 (if (##output-port? obj) 'input-output-port 'input-port)
9239 'output-port)
9240 (##port-name obj)))
9241 ((macro-thread? obj)
9242 (##wr-sn
9243 we
9244 obj
9245 'thread
9246 (macro-thread-name obj)))
9247 ((macro-mutex? obj)
9248 (##wr-sn
9249 we
9250 obj
9251 'mutex
9252 (macro-mutex-name obj)))
9253 ((macro-condvar? obj)
9254 (##wr-sn
9255 we
9256 obj
9257 'condition-variable
9258 (macro-condvar-name obj)))
9259 ((macro-tgroup? obj)
9260 (##wr-sn
9261 we
9262 obj
9263 'thread-group
9264 (macro-tgroup-name obj)))
9265 ((##type? obj);;;;;;;;;;;;;;;
9266 (##wr-sn
9267 we
9268 obj
9269 'type
9270 (##type-name obj)))
9271 (else
9272 (case (macro-writeenv-style we)
9273 ((mark)
9274 (if (##wr-mark we obj)
9275 (for-each-visible-field
9276 (lambda (field-name value last?)
9277 (##wr-no-display we field-name)
9278 (##wr-no-display we value))
9279 obj
9280 (##structure-type obj)
9281 #t)))
9282 (else
9283 (if (##wr-stamp we obj)
9284 (if (case (macro-writeenv-style we)
9285 ((pretty-print)
9286 (##not (##wr-one-line-pretty-print
9287 we
9288 obj
9289 (lambda (we obj)
9290 (wr-structure we obj)))))
9291 (else
9292 #t))
9293 (wr-structure we obj))))))))
9295 (define-prim (##wr-gc-hash-table we obj)
9296 (if (##eq? (macro-readtable-sharing-allowed?
9297 (macro-writeenv-readtable we))
9298 'serialize)
9299 (##wr-serialize we obj ##explode-gc-hash-table '("#gc-hash-table(" . ")"))
9300 (##wr-sn
9301 we
9302 obj
9303 'gc-hash-table
9304 (##void))))
9306 (define-prim (##explode-gc-hash-table gcht)
9307 (##declare (not interrupts-enabled))
9308 (let loop ((i (macro-gc-hash-table-key0))
9309 (key-vals '()))
9310 (let ((len (##vector-length gcht)))
9311 (if (##fixnum.< i len)
9312 (let ((key (##vector-ref gcht i)))
9313 (if (and (##not (##eq? key (macro-unused-obj)))
9314 (##not (##eq? key (macro-deleted-obj))))
9315 (let ((val (##vector-ref gcht (##fixnum.+ i 1))))
9316 (let ((new-key-vals (##cons (##cons key val) key-vals)))
9317 (##declare (interrupts-enabled))
9318 (loop (##fixnum.+ i 2) new-key-vals)))
9319 (let ()
9320 (##declare (interrupts-enabled))
9321 (loop (##fixnum.+ i 2) key-vals))))
9322 (let ((flags
9323 (macro-gc-hash-table-flags gcht))
9324 (count
9325 (macro-gc-hash-table-count gcht))
9326 (min-count
9327 (macro-gc-hash-table-min-count gcht))
9328 (free
9329 (macro-gc-hash-table-free gcht)))
9330 (##declare (interrupts-enabled))
9331 (##vector len flags count min-count free key-vals))))))
9333 (define-prim (##implode-gc-hash-table re fields)
9334 (let ((len (##vector-ref fields 0))
9335 (flags (##vector-ref fields 1))
9336 (count (##vector-ref fields 2))
9337 (min-count (##vector-ref fields 3))
9338 (free (##vector-ref fields 4))
9339 (key-vals (##vector-ref fields 5)))
9340 (let ((gcht (##make-vector len (macro-unused-obj))))
9341 (macro-gc-hash-table-flags-set!
9342 gcht
9343 (##fixnum.bitwise-ior ;; force rehash at next access!
9344 flags
9345 (##fixnum.+ (macro-gc-hash-table-flag-key-moved)
9346 (macro-gc-hash-table-flag-need-rehash))))
9347 (macro-gc-hash-table-count-set! gcht count)
9348 (macro-gc-hash-table-min-count-set! gcht min-count)
9349 (macro-gc-hash-table-free-set! gcht free)
9350 (let loop ((i (macro-gc-hash-table-key0))
9351 (key-vals key-vals))
9352 (if (##pair? key-vals)
9353 (if (##fixnum.< i (##vector-length gcht))
9354 (let ((key-val (##car key-vals)))
9355 (let ((key (##car key-val))
9356 (val (##cdr key-val)))
9357 (##vector-set! gcht i key)
9358 (##vector-set! gcht (##fixnum.+ i 1) val)
9359 (loop (##fixnum.+ i 2) (##cdr key-vals))))
9360 #f)
9361 (begin
9362 (##subtype-set!
9363 gcht
9364 (macro-subtype-weak))
9365 gcht))))))
9367 (define-prim (##wr-meroon we obj)
9368 (##wr-sn
9369 we
9370 obj
9371 'meroon
9372 (##void)))
9374 (define-prim (##wr-jazz we obj)
9375 (##wr-sn
9376 we
9377 obj
9378 'jazz
9379 (##void)))
9381 (define-prim (##wr-frame we obj)
9382 (if (##eq? (macro-readtable-sharing-allowed?
9383 (macro-writeenv-readtable we))
9384 'serialize)
9385 (##wr-serialize we obj ##explode-frame '("#frame(" . ")"))
9386 (##wr-sn
9387 we
9388 obj
9389 'frame
9390 (##void))))
9392 (define-prim (##wr-continuation we obj)
9393 (if (##eq? (macro-readtable-sharing-allowed?
9394 (macro-writeenv-readtable we))
9395 'serialize)
9396 (##wr-serialize we obj ##explode-continuation '("#continuation(" . ")"))
9397 (##wr-sn
9398 we
9399 obj
9400 'continuation
9401 (##void))))
9403 (define-prim (##wr-promise we obj)
9404 (if (##eq? (macro-readtable-sharing-allowed?
9405 (macro-writeenv-readtable we))
9406 'serialize)
9407 (##wr-serialize we obj ##explode-promise '("#promise(" . ")"))
9408 (if (macro-writeenv-force? we)
9409 (##wr we (##force obj))
9410 (##wr-sn
9411 we
9412 obj
9413 'promise
9414 (##void)))))
9416 (define-prim (##explode-promise obj)
9417 (##explode-object obj))
9419 (define-prim (##implode-promise re fields)
9420 (##implode-object re fields (macro-subtype-promise)))
9422 (define-prim (##wr-will we obj)
9423 (##wr-sn
9424 we
9425 obj
9426 'will
9427 (##void)))
9429 (define-prim (##wr-procedure we obj)
9430 (if (##eq? (macro-readtable-sharing-allowed?
9431 (macro-writeenv-readtable we))
9432 'serialize)
9433 (##wr-serialize we obj ##explode-procedure '("#procedure(" . ")"))
9434 (##wr-sn
9435 we
9436 obj
9437 'procedure
9438 (or (##procedure-name obj) (##void)))))
9440 (define-prim (##wr-return we obj)
9441 (##wr-opaque
9442 we
9443 obj
9444 ##explode-return
9445 '("#return(" . ")")
9446 'return
9447 (##void)))
9449 (define-prim (##wr-box we obj)
9450 (case (macro-writeenv-style we)
9451 ((mark)
9452 (if (##wr-mark we obj)
9453 (##wr we (##unbox obj))))
9454 (else
9455 (if (case (macro-writeenv-style we)
9456 ((print) #t)
9457 (else (##wr-stamp we obj)))
9458 (begin
9459 (##wr-str we "#&")
9460 (##wr we (##unbox obj)))))))
9462 (define-prim (##wr-other we obj)
9463 (case (macro-writeenv-style we)
9464 ((mark)
9465 #f)
9466 (else
9467 (cond ((##eq? obj #t)
9468 (##wr-str we "#t"))
9469 ((##eq? obj #f)
9470 (##wr-str we "#f"))
9471 ((##eq? obj '())
9472 (case (macro-writeenv-style we)
9473 ((print)
9474 (##void))
9475 (else
9476 (##wr-str we "()"))))
9477 ((##eq? obj (macro-absent-obj))
9478 (##wr-str we
9479 (if (##eq? (macro-readtable-sharing-allowed?
9480 (macro-writeenv-readtable we))
9481 'serialize)
9482 "#absent"
9483 "#<absent>")))
9484 (else
9485 (let ((x
9486 (##assq-cdr obj
9487 (macro-readtable-sharp-bang-table
9488 (macro-writeenv-readtable we)))))
9489 (if x
9490 (begin
9491 (##wr-str we "#!")
9492 (##wr-str we (##car x)))
9493 (##wr-str we "#<unknown>"))))))))
9495 ;;;----------------------------------------------------------------------------
9497 (define ##main-readtable #f)
9499 ;;;----------------------------------------------------------------------------
9501 ;;; IEEE Scheme procedures:
9503 (define-prim (##eof-object? x)
9504 (##eq? x #!eof))
9506 (define-prim (eof-object? x)
9507 (macro-force-vars (x)
9508 (##eof-object? x)))
9510 ;;;----------------------------------------------------------------------------
9512 ;;; R4RS Scheme procedures:
9514 (define-prim (transcript-on path)
9515 (macro-check-string path 1 (transcript-on path)
9516 (##void)))
9518 (define-prim (transcript-off)
9519 (##void))
9521 ;;;----------------------------------------------------------------------------
9523 ; The reader.
9525 (##declare (inlining-limit 300))
9527 (##define-macro (* . args) `(##fixnum.* ,@args))
9528 (##define-macro (+ . args) `(##fixnum.+ ,@args))
9529 (##define-macro (- . args) `(##fixnum.- ,@args))
9530 (##define-macro (< . args) `(##fixnum.< ,@args))
9531 (##define-macro (= . args) `(##fixnum.= ,@args))
9532 (##define-macro (assoc . args) `(##assoc ,@args))
9533 (##define-macro (assq . args) `(##assq ,@args))
9534 (##define-macro (car . args) `(##car ,@args))
9535 (##define-macro (cdr . args) `(##cdr ,@args))
9536 (##define-macro (char-downcase . args) `(##char-downcase ,@args))
9537 (##define-macro (char-upcase . args) `(##char-upcase ,@args))
9538 (##define-macro (char<? . args) `(##char<? ,@args))
9539 (##define-macro (char=? . args) `(##char=? ,@args))
9540 (##define-macro (char? . args) `(##char? ,@args))
9541 (##define-macro (cons . args) `(##cons ,@args))
9542 (##define-macro (eq? . args) `(##eq? ,@args))
9543 (##define-macro (complex? . args) `(##complex? ,@args))
9544 (##define-macro (exact? . args) `(##exact? ,@args))
9545 (##define-macro (for-each . args) `(##for-each ,@args))
9546 (##define-macro (integer? . args) `(##integer? ,@args))
9547 (##define-macro (list . args) `(##list ,@args))
9548 (##define-macro (make-string . args) `(##make-string ,@args))
9549 (##define-macro (make-vector . args) `(##make-vector ,@args))
9550 (##define-macro (map . args) `(##map ,@args))
9551 (##define-macro (modulo . args) `(##modulo ,@args))
9552 (##define-macro (not . args) `(##not ,@args))
9553 (##define-macro (null? . args) `(##null? ,@args))
9554 (##define-macro (pair? . args) `(##pair? ,@args))
9555 (##define-macro (quotient . args) `(##quotient ,@args))
9556 (##define-macro (real? . args) `(##real? ,@args))
9557 (##define-macro (reverse . args) `(##reverse ,@args))
9558 (##define-macro (box . args) `(##box ,@args))
9559 (##define-macro (set-box! . args) `(##set-box! ,@args))
9560 (##define-macro (set-car! . args) `(##set-car! ,@args))
9561 (##define-macro (set-cdr! . args) `(##set-cdr! ,@args))
9562 (##define-macro (string->number . args) `(##string->number ,@args))
9563 (##define-macro (string->symbol-object . args) `(##make-interned-symkey ,@args #t))
9564 (##define-macro (string->uninterned-symbol-object . args) `(##make-uninterned-symbol ,@args))
9565 (##define-macro (string? . args) `(##string? ,@args))
9566 (##define-macro (string-length . args) `(##string-length ,@args))
9567 (##define-macro (string-append . args) `(##string-append ,@args))
9568 (##define-macro (string-ref . args) `(##string-ref ,@args))
9569 (##define-macro (string-set! . args) `(##string-set! ,@args))
9570 (##define-macro (string=? . args) `(##string=? ,@args))
9571 (##define-macro (string-ci=? . args) `(##string-ci=? ,@args))
9572 (##define-macro (substring . args) `(##substring ,@args))
9573 (##define-macro (symbol? . args) `(##symbol? ,@args))
9574 (##define-macro (symbol->string . args) `(##symbol->string ,@args))
9575 (##define-macro (vector . args) `(##vector ,@args))
9576 (##define-macro (vector-copy . args) `(##vector-copy ,@args))
9577 (##define-macro (vector-length . args) `(##vector-length ,@args))
9578 (##define-macro (vector-ref . args) `(##vector-ref ,@args))
9579 (##define-macro (vector-set! . args) `(##vector-set! ,@args))
9580 (##define-macro (vector? . args) `(##vector? ,@args))
9582 (##define-macro (make-s8vect n) `(##make-s8vector ,n))
9583 (##define-macro (s8vect-set! . args) `(##s8vector-set! ,@args))
9584 (##define-macro (make-u8vect n) `(##make-u8vector ,n))
9585 (##define-macro (u8vect-set! . args) `(##u8vector-set! ,@args))
9586 (##define-macro (make-s16vect n) `(##make-s16vector ,n))
9587 (##define-macro (s16vect-set! . args) `(##s16vector-set! ,@args))
9588 (##define-macro (make-u16vect n) `(##make-u16vector ,n))
9589 (##define-macro (u16vect-set! . args) `(##u16vector-set! ,@args))
9590 (##define-macro (make-s32vect n) `(##make-s32vector ,n))
9591 (##define-macro (s32vect-set! . args) `(##s32vector-set! ,@args))
9592 (##define-macro (make-u32vect n) `(##make-u32vector ,n))
9593 (##define-macro (u32vect-set! . args) `(##u32vector-set! ,@args))
9594 (##define-macro (make-s64vect n) `(##make-s64vector ,n))
9595 (##define-macro (s64vect-set! . args) `(##s64vector-set! ,@args))
9596 (##define-macro (make-u64vect n) `(##make-u64vector ,n))
9597 (##define-macro (u64vect-set! . args) `(##u64vector-set! ,@args))
9598 (##define-macro (make-f32vect n) `(##make-f32vector ,n))
9599 (##define-macro (f32vect-set! . args) `(##f32vector-set! ,@args))
9600 (##define-macro (make-f64vect n) `(##make-f64vector ,n))
9601 (##define-macro (f64vect-set! . args) `(##f64vector-set! ,@args))
9603 (##define-macro (UCS-4->character . args) `(##fixnum.->char ,@args))
9604 (##define-macro (character->UCS-4 . args) `(##fixnum.<-char ,@args))
9605 (##define-macro (in-char-range? n)
9606 `(and (##not (##< ##max-char ,n))
9607 (or (##fixnum.< ,n #xd800)
9608 (##fixnum.< #xdfff ,n))))
9610 (##define-macro (string->keyword-object . args) `(##make-interned-symkey ,@args #f))
9611 (##define-macro (string->uninterned-keyword-object . args) `(##make-uninterned-keyword ,@args))
9613 (##define-macro (in-integer-range? n lo hi)
9614 `(and (##not (##< ,n ,lo)) (##not (##< ,hi ,n))))
9616 (##define-macro (false-obj) #f)
9618 ;;; Tables for reader and writer.
9620 (define ##standard-pretty-print-formats '(
9621 (lambda . #(1 #t 2 #f 1))
9622 (if . #(1 #f 0 #f 1))
9623 (set! . #(1 #f 0 #f 1))
9624 (cond . #(1 #t 0 #t 1))
9625 (case . #(1 #f 2 #t 1))
9626 (and . #(1 #f 0 #f 1))
9627 (or . #(1 #f 0 #f 1))
9628 (let . #(1 #t 2 #f 1)) ;; named let is handled in pretty printer
9629 (let* . #(1 #t 2 #f 1))
9630 (letrec . #(1 #t 2 #f 1))
9631 (begin . #(0 #f 1 #f 1))
9632 (do . #(1 #t 3 #f 1))
9633 (define . #(1 #f 2 #f 1))
9634 (##define-macro . #(1 #f 2 #f 1))
9635 (define-macro . #(1 #f 2 #f 1))
9636 (##declare . #(0 #f 1 #f 1))
9637 (declare . #(0 #f 1 #f 1))
9638 ))
9640 (define ##list-max-head 8)
9641 (set! ##list-max-head ##list-max-head)
9643 (define ##structure-max-head 8)
9644 (set! ##structure-max-head ##structure-max-head)
9646 (define ##structure-max-field 8)
9647 (set! ##structure-max-field ##structure-max-field)
9649 (define ##structure-indent 1)
9650 (set! ##structure-indent ##structure-indent)
9652 (define ##standard-escaped-char-table '(
9653 (#\\ . #\\)
9654 (#\a . #\x07)
9655 (#\b . #\x08)
9656 (#\t . #\x09)
9657 (#\n . #\x0A)
9658 (#\v . #\x0B)
9659 (#\f . #\x0C)
9660 (#\r . #\x0D)
9661 (#\space . #\space)
9662 (#\| . #\|)
9663 (#\" . #\")
9664 (#\' . #\')
9665 (#\? . #\?)
9666 ))
9668 (define ##standard-named-char-table '(
9669 ("newline" . #\newline) ;; here to take precedence over linefeed
9670 ("space" . #\space)
9671 ("nul" . #\x00)
9672 ("alarm" . #\x07)
9673 ("backspace" . #\x08)
9674 ("tab" . #\x09)
9675 ("linefeed" . #\x0A)
9676 ("vtab" . #\x0B)
9677 ("page" . #\x0C)
9678 ("return" . #\x0D)
9679 ("esc" . #\x1B)
9680 ("delete" . #\x7F)
9681 ))
9683 (define ##standard-sharp-bang-table '(
9684 ("eof" . #!eof)
9685 ("void" . #!void)
9686 ("unbound" . #!unbound)
9687 ("unbound2" . #!unbound2)
9688 ("optional" . #!optional)
9689 ("rest" . #!rest)
9690 ("key" . #!key)
9691 ;; ("body" . #!body)
9692 ))
9694 ;;;============================================================================
9696 ;; For compatibility between the interpreter and compiler, this section
9697 ;; must be the same as the corresponding section in the file
9698 ;; "gsc/_source.scm" (except that ## and ** are exchanged).
9700 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
9702 ;; A chartable structure is a vector-like data structure which is
9703 ;; indexed using a character.
9705 (define (##make-chartable default)
9706 (vector (make-vector 128 default) default '()))
9708 (define (##chartable-copy ct)
9709 (vector (vector-copy (vector-ref ct 0))
9710 (vector-ref ct 1)
9711 (map (lambda (x) (cons (car x) (cdr x))) (vector-ref ct 2))))
9713 (define (##chartable-ref ct c)
9714 (let ((i (character->UCS-4 c)))
9715 (if (< i 128)
9716 (vector-ref (vector-ref ct 0) i)
9717 (let ((x (assq i (vector-ref ct 2))))
9718 (if x
9719 (cdr x)
9720 (vector-ref ct 1))))))
9722 (define (##chartable-set! ct c val)
9723 (let ((i (character->UCS-4 c)))
9724 (if (< i 128)
9725 (vector-set! (vector-ref ct 0) i val)
9726 (let ((x (assq i (vector-ref ct 2))))
9727 (if x
9728 (set-cdr! x val)
9729 (vector-set! ct 2 (cons (cons i val) (vector-ref ct 2))))))))
9731 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
9733 ;; A readtable structure contains parsing information for the reader.
9734 ;; It indicates what action must be taken when a given character is
9735 ;; encountered.
9737 (define (##readtable-char-delimiter? rt c)
9738 (##chartable-ref (macro-readtable-char-delimiter?-table rt) c))
9740 (define (##readtable-char-delimiter?-set! rt c delimiter?)
9741 (##chartable-set! (macro-readtable-char-delimiter?-table rt) c delimiter?))
9743 (define (##readtable-char-handler rt c)
9744 (##chartable-ref (macro-readtable-char-handler-table rt) c))
9746 (define (##readtable-char-handler-set! rt c handler)
9747 (##chartable-set! (macro-readtable-char-handler-table rt) c handler))
9749 (define (##readtable-char-sharp-handler rt c)
9750 (##chartable-ref (macro-readtable-char-sharp-handler-table rt) c))
9752 (define (##readtable-char-sharp-handler-set! rt c handler)
9753 (##chartable-set! (macro-readtable-char-sharp-handler-table rt) c handler))
9755 (define (##readtable-char-class-set! rt c delimiter? handler)
9756 (##readtable-char-delimiter?-set! rt c delimiter?)
9757 (##readtable-char-handler-set! rt c handler))
9759 (define (##readtable-convert-case rt c)
9760 (let ((case-conversion? (macro-readtable-case-conversion? rt)))
9761 (if case-conversion?
9762 (if (eq? case-conversion? 'upcase)
9763 (char-upcase c)
9764 (char-downcase c))
9765 c)))
9767 (define (##readtable-string-convert-case! rt s)
9768 (let ((case-conversion? (macro-readtable-case-conversion? rt)))
9769 (if case-conversion?
9770 (if (eq? case-conversion? 'upcase)
9771 (let loop ((i (- (string-length s) 1)))
9772 (if (not (< i 0))
9773 (begin
9774 (string-set! s i (char-upcase (string-ref s i)))
9775 (loop (- i 1)))))
9776 (let loop ((i (- (string-length s) 1)))
9777 (if (not (< i 0))
9778 (begin
9779 (string-set! s i (char-downcase (string-ref s i)))
9780 (loop (- i 1)))))))))
9782 (define (##readtable-parse-keyword rt s intern? create?)
9783 (let ((keywords-allowed? (macro-readtable-keywords-allowed? rt)))
9784 (and keywords-allowed?
9785 (let ((len (string-length s)))
9786 (and (< 1 len)
9787 (if (eq? keywords-allowed? 'prefix)
9788 (and (char=? (string-ref s 0) #\:)
9789 (if create?
9790 (let ((key-str (substring s 1 len)))
9791 (if intern?
9792 (string->keyword-object key-str)
9793 (string->uninterned-keyword-object key-str)))
9794 #t))
9795 (and (char=? (string-ref s (- len 1)) #\:)
9796 (if create?
9797 (let ((key-str (substring s 0 (- len 1))))
9798 (if intern?
9799 (string->keyword-object key-str)
9800 (string->uninterned-keyword-object key-str)))
9801 #t))))))))
9803 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
9805 ;;; Procedures to read datums.
9807 ;; (##read-datum-or-eof re) attempts to read a datum in the read
9808 ;; environment "re", skipping all whitespace and comments in the
9809 ;; process. The "filepos" field of the read environment indicates the
9810 ;; position where the enclosing datum starts (e.g. list or vector). If
9811 ;; a datum is read it is returned (wrapped if the read environment asks
9812 ;; for it); if the end-of-file is reached the end-of-file object is
9813 ;; returned (never wrapped); otherwise an error is signaled. The read
9814 ;; environment's "pos" field is only modified if a datum was read, in
9815 ;; which case it is the position where the datum starts.
9817 (define (##read-datum-or-eof re)
9818 (case (macro-readtable-start-syntax (macro-readenv-readtable re))
9819 ((six)
9820 (##read-six-datum-or-eof re #t))
9821 (else
9822 (let loop ()
9823 (let* ((old-pos (macro-readenv-filepos re))
9824 (obj (##read-datum-or-label-or-none re)))
9825 (if (eq? obj (##none-marker))
9826 (let ((c (macro-peek-next-char-or-eof re)))
9827 (if (char? c)
9828 (begin
9829 (macro-readenv-filepos-set! re (##readenv-current-filepos re))
9830 (macro-read-next-char-or-eof re) ;; make sure reader progresses
9831 (##raise-datum-parsing-exception 'datum-or-eof-expected re)
9832 (macro-readenv-filepos-set! re old-pos) ;; restore pos
9833 (loop)) ;; skip error
9834 (begin
9835 (macro-read-next-char-or-eof re) ;; make sure reader progresses
9836 #!eof))) ;; end-of-file was reached so return end-of-file object
9837 (begin
9838 (##read-check-labels! re)
9839 obj)))))))
9841 ;; (##read-datum-or-label re) attempts to read a datum in the read
9842 ;; environment "re", skipping all whitespace and comments in the
9843 ;; process. The "filepos" field of the read environment indicates the
9844 ;; position where the enclosing datum starts (e.g. list or vector). If
9845 ;; a datum is read it is returned (wrapped if the read environment asks
9846 ;; for it); if a label reference is read (i.e. "#n#") a "label-marker"
9847 ;; is returned; if the end-of-file is reached or no datum can be read
9848 ;; an error is signaled. The read environment's "filepos" field is
9849 ;; only modified if a datum was read, in which case it is the position
9850 ;; where the datum starts.
9852 (define (##read-datum-or-label re)
9853 (let* ((old-pos (macro-readenv-filepos re))
9854 (obj (##read-datum-or-label-or-none re)))
9855 (if (eq? obj (##none-marker))
9856 (begin
9857 (macro-readenv-filepos-set! re (##readenv-current-filepos re))
9858 (let ((c (macro-read-next-char-or-eof re))) ;; force progress
9859 (##raise-datum-parsing-exception 'datum-expected re)
9860 (if (not (char? c))
9861 (macro-readenv-wrap re #f) ;; return something
9862 (begin
9863 (macro-readenv-filepos-set! re old-pos) ;; restore pos
9864 (##read-datum-or-label re))))) ;; skip error
9865 obj)))
9867 ;; (##read-datum-or-label-or-none re) attempts to read a datum in the
9868 ;; read environment "re", skipping all whitespace and comments in the
9869 ;; process. The "filepos" field of the read environment indicates the
9870 ;; position where the enclosing datum starts (e.g. list or vector). If
9871 ;; a datum is read it is returned (wrapped if the read environment asks
9872 ;; for it); if a label reference is read (i.e. "#n#") a "label-marker"
9873 ;; is returned; if the end-of-file is reached or no datum can be read
9874 ;; the "none-marker" is returned. The read environment's "filepos"
9875 ;; field is only modified if a datum was read, in which case it is the
9876 ;; position where the datum starts.
9878 (define (##read-datum-or-label-or-none re)
9879 (let* ((old-pos (macro-readenv-filepos re))
9880 (obj (##read-datum-or-label-or-none-or-dot re)))
9881 (if (eq? obj (##dot-marker))
9882 (begin
9883 (macro-readenv-filepos-set! re (##readenv-relative-filepos re 1))
9884 (##raise-datum-parsing-exception 'improperly-placed-dot re)
9885 (macro-readenv-filepos-set! re old-pos) ;; restore pos
9886 (##read-datum-or-label-or-none re)) ;; skip error
9887 obj)))
9889 ;; (##read-datum-or-label-or-none-or-dot re) attempts to read a datum
9890 ;; in the read environment "re", skipping all whitespace and comments
9891 ;; in the process. The "filepos" field of the read environment
9892 ;; indicates the position where the enclosing datum starts (e.g. list
9893 ;; or vector). If a datum is read it is returned (wrapped if the read
9894 ;; environment asks for it); if a label reference is read (i.e. "#n#")
9895 ;; a "label-marker" is returned; if a lone dot is read the "dot-marker"
9896 ;; is returned; if the end-of-file is reached or no datum can be read
9897 ;; the "none-marker" is returned. The read environment's "filepos"
9898 ;; field is only modified if a datum was read, in which case it is the
9899 ;; position where the datum starts.
9901 (define (##read-datum-or-label-or-none-or-dot re)
9902 (macro-readenv-allow-script?-set!
9903 re
9904 (eq? (macro-readenv-allow-script? re) 'script))
9905 (let ((next (macro-peek-next-char-or-eof re)))
9906 (if (char? next)
9907 ((##readtable-char-handler (macro-readenv-readtable re) next) re next)
9908 (##none-marker))))
9910 ;; Special objects returned by ##read-datum-or-label-or-none-or-dot.
9912 (define (##script-marker) '#(script)) ;; indicates a script
9913 (define (##none-marker) '#(none)) ;; indicates no following datum
9914 (define (##dot-marker) '#(dot)) ;; indicates an isolated dot
9915 (define ##label-marker-tag '#(label)) ;; indicates a label of the form "#n#"
9917 (define (##label-marker? obj)
9918 (and (vector? obj)
9919 (< 0 (vector-length obj))
9920 (eq? (vector-ref obj 0) ##label-marker-tag)))
9922 (define (##label-marker-enter! re n)
9923 (let* ((labels (macro-readenv-labels re))
9924 (x (assoc n labels)))
9925 (if x
9926 (cdr x)
9927 (let ((lm (vector ##label-marker-tag #f '())))
9928 (macro-readenv-labels-set! re (cons (cons n lm) labels))
9929 lm))))
9931 (define (##label-marker-reference re n)
9932 (let* ((lm (##label-marker-enter! re n))
9933 (handlers (vector-ref lm 2)))
9934 (if handlers
9935 lm
9936 (vector-ref lm 1))))
9938 (define (##label-marker-fixup-handler-add! re lm handler)
9939 (let ((handlers (vector-ref lm 2)))
9940 (if handlers
9941 (vector-set!
9942 lm
9943 2
9944 (vector handler
9945 (macro-readenv-wrapper re)
9946 (macro-readenv-filepos re)
9947 handlers))
9948 (handler (macro-readenv-wrap re (vector-ref lm 1))))))
9950 (define (##label-marker-define re n obj)
9951 (let* ((lm (##label-marker-enter! re n))
9952 (handlers (vector-ref lm 2)))
9953 (if handlers
9954 (begin
9955 (vector-set! lm 1 obj)
9956 (vector-set! lm 2 #f)
9957 (##label-marker-fixup! re handlers obj))
9958 (##raise-datum-parsing-exception 'duplicate-label-definition re n))))
9960 (define (##label-marker-fixup! re handlers obj)
9961 (let loop ((lst handlers))
9962 (if (vector? lst)
9963 (let* ((handler (vector-ref lst 0))
9964 (wrapper (vector-ref lst 1))
9965 (filepos (vector-ref lst 2))
9966 (old-wrapper (macro-readenv-wrapper re))
9967 (old-filepos (macro-readenv-filepos re)))
9968 (macro-readenv-wrapper-set! re wrapper)
9969 (macro-readenv-filepos-set! re filepos)
9970 (handler (macro-readenv-wrap re obj))
9971 (macro-readenv-wrapper-set! re old-wrapper)
9972 (macro-readenv-filepos-set! re old-filepos)
9973 (loop (vector-ref lst 3))))))
9975 (define (##read-check-labels! re)
9976 (let loop1 ((lst (macro-readenv-labels re)))
9977 (if (pair? lst)
9978 (let* ((x (car lst))
9979 (lm (cdr x)))
9980 (let ((handlers (vector-ref lm 2)))
9981 (if handlers
9982 (begin
9983 (##label-marker-fixup! re handlers (##void))
9984 (##raise-datum-parsing-exception
9985 'missing-label-definition
9986 re
9987 (car x)))))
9988 (loop1 (cdr lst))))))
9990 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
9992 ;;; Procedure to read a list of datums (possibly an improper list).
9994 (define (##build-list re allow-improper? start-pos close)
9995 (let ((obj (##read-datum-or-label-or-none re)))
9996 (if (eq? obj (##none-marker))
9997 (begin
9998 (##read-next-char-expecting re close)
9999 '())
10000 (begin
10001 (macro-readenv-filepos-set! re start-pos) ;; restore pos
10002 (let ((lst (cons obj '())))
10003 (if (##label-marker? obj)
10004 (##label-marker-fixup-handler-add!
10005 re
10006 obj
10007 (lambda (resolved-obj)
10008 (set-car! lst resolved-obj))))
10009 (let loop ((end lst))
10010 (let ((obj
10011 (if allow-improper?
10012 (##read-datum-or-label-or-none-or-dot re)
10013 (##read-datum-or-label-or-none re))))
10014 (cond ((eq? obj (##none-marker))
10015 (##read-next-char-expecting re close)
10016 lst)
10017 ((eq? obj (##dot-marker))
10018 (let ((obj (##read-datum-or-label re)))
10019 (macro-readenv-filepos-set! re start-pos) ;; restore pos
10020 (set-cdr! end obj)
10021 (if (##label-marker? obj)
10022 (##label-marker-fixup-handler-add!
10023 re
10024 obj
10025 (lambda (resolved-obj)
10026 (set-cdr! end resolved-obj))))
10027 (let ((x (##read-datum-or-label-or-none re))) ;; skip whitespace!
10028 (if (eq? x (##none-marker))
10029 (##read-next-char-expecting re close)
10030 (begin
10031 (macro-readenv-filepos-set! re start-pos) ;; restore pos
10032 (##raise-datum-parsing-exception 'incomplete-form re)))
10033 lst)))
10034 (else
10035 (macro-readenv-filepos-set! re start-pos) ;; restore pos
10036 (let ((tail (cons obj '())))
10037 (if (##label-marker? obj)
10038 (##label-marker-fixup-handler-add!
10039 re
10040 obj
10041 (lambda (resolved-obj)
10042 (set-car! tail resolved-obj))))
10043 (set-cdr! end tail)
10044 (loop tail)))))))))))
10046 (define (##read-next-char-expecting re c) ;; only accepts c as the next char
10047 (let ((next (macro-peek-next-char-or-eof re)))
10048 (if (char? next)
10049 (if (char=? next c)
10050 (macro-read-next-char-or-eof re)
10051 (##raise-datum-parsing-exception 'incomplete-form re))
10052 (##raise-datum-parsing-exception 'incomplete-form-eof-reached re))))
10054 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
10056 ;;; Procedure to read a vector or byte vector.
10058 (define (##build-vector re kind start-pos close)
10060 (define (exact-integer-check n lo hi)
10061 (and (integer? n)
10062 (exact? n)
10063 (in-integer-range? n lo hi)))
10065 (define (inexact-real-check n)
10066 (and (real? n)
10067 (not (exact? n))))
10069 (let loop ((i 0))
10070 (macro-readenv-filepos-set! re start-pos) ;; restore pos
10071 (let ((x (##read-datum-or-label-or-none re)))
10072 (if (eq? x (##none-marker))
10073 (begin
10074 (##read-next-char-expecting re close)
10075 (case kind
10076 ((s8vector) (make-s8vect i))
10077 ((u8vector) (make-u8vect i))
10078 ((s16vector) (make-s16vect i))
10079 ((u16vector) (make-u16vect i))
10080 ((s32vector) (make-s32vect i))
10081 ((u32vector) (make-u32vect i))
10082 ((s64vector) (make-s64vect i))
10083 ((u64vector) (make-u64vect i))
10084 ((f32vector) (make-f32vect i))
10085 ((f64vector) (make-f64vect i))
10086 (else (make-vector i))))
10087 (if (or (eq? kind 'deserialize)
10088 (eq? kind 'vector))
10089 (let ((vect (loop (+ i 1))))
10090 (vector-set! vect i x)
10091 (if (and (##not (eq? kind 'deserialize))
10092 (##label-marker? x))
10093 (##label-marker-fixup-handler-add!
10094 re;;;;;;;;;;;;;;;;;;;;;;;;
10095 x
10096 (lambda (resolved-obj)
10097 (vector-set! vect i resolved-obj))))
10098 vect)
10099 (let ((ux
10100 (and (not (##label-marker? x))
10101 (macro-readenv-unwrap re x))))
10102 (case kind
10103 ((s8vector)
10104 (if (exact-integer-check ux -128 127)
10105 (let ((vect (loop (+ i 1))))
10106 (s8vect-set! vect i ux)
10107 vect)
10108 (begin
10109 (##raise-datum-parsing-exception 's8-expected re)
10110 (loop i))))
10111 ((u8vector)
10112 (if (exact-integer-check ux 0 255)
10113 (let ((vect (loop (+ i 1))))
10114 (u8vect-set! vect i ux)
10115 vect)
10116 (begin
10117 (##raise-datum-parsing-exception 'u8-expected re)
10118 (loop i))))
10119 ((s16vector)
10120 (if (exact-integer-check ux -32768 32767)
10121 (let ((vect (loop (+ i 1))))
10122 (s16vect-set! vect i ux)
10123 vect)
10124 (begin
10125 (##raise-datum-parsing-exception 's16-expected re)
10126 (loop i))))
10127 ((u16vector)
10128 (if (exact-integer-check ux 0 65535)
10129 (let ((vect (loop (+ i 1))))
10130 (u16vect-set! vect i ux)
10131 vect)
10132 (begin
10133 (##raise-datum-parsing-exception 'u16-expected re)
10134 (loop i))))
10135 ((s32vector)
10136 (if (exact-integer-check ux -2147483648 2147483647)
10137 (let ((vect (loop (+ i 1))))
10138 (s32vect-set! vect i ux)
10139 vect)
10140 (begin
10141 (##raise-datum-parsing-exception 's32-expected re)
10142 (loop i))))
10143 ((u32vector)
10144 (if (exact-integer-check ux 0 4294967295)
10145 (let ((vect (loop (+ i 1))))
10146 (u32vect-set! vect i ux)
10147 vect)
10148 (begin
10149 (##raise-datum-parsing-exception 'u32-expected re)
10150 (loop i))))
10151 ((s64vector)
10152 (if (exact-integer-check ux -9223372036854775808 9223372036854775807)
10153 (let ((vect (loop (+ i 1))))
10154 (s64vect-set! vect i ux)
10155 vect)
10156 (begin
10157 (##raise-datum-parsing-exception 's64-expected re)
10158 (loop i))))
10159 ((u64vector)
10160 (if (exact-integer-check ux 0 18446744073709551615)
10161 (let ((vect (loop (+ i 1))))
10162 (u64vect-set! vect i ux)
10163 vect)
10164 (begin
10165 (##raise-datum-parsing-exception 'u64-expected re)
10166 (loop i))))
10167 ((f32vector)
10168 (if (inexact-real-check ux)
10169 (let ((vect (loop (+ i 1))))
10170 (f32vect-set! vect i ux)
10171 vect)
10172 (begin
10173 (##raise-datum-parsing-exception 'inexact-real-expected re)
10174 (loop i))))
10175 ((f64vector)
10176 (if (inexact-real-check ux)
10177 (let ((vect (loop (+ i 1))))
10178 (f64vect-set! vect i ux)
10179 vect)
10180 (begin
10181 (##raise-datum-parsing-exception 'inexact-real-expected re)
10182 (loop i)))))))))))
10184 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
10186 ;;; Procedures to read delimited tokens.
10188 (define (##build-delimited-string re c i)
10189 (let loop ((i i))
10190 (let ((next (macro-peek-next-char-or-eof re)))
10191 (if (or (not (char? next))
10192 (##readtable-char-delimiter? (macro-readenv-readtable re) next))
10193 (make-string i c)
10194 (begin
10195 (macro-read-next-char-or-eof re) ;; skip "next"
10196 (let ((s (loop (+ i 1))))
10197 (string-set! s i next)
10198 s))))))
10200 (define (##build-delimited-number/keyword/symbol re c intern?)
10202 (define (string->sym str)
10203 (if intern?
10204 (string->symbol-object str)
10205 (string->uninterned-symbol-object str)))
10207 (define (string->key str)
10208 (if intern?
10209 (string->keyword-object str)
10210 (string->uninterned-keyword-object str)))
10212 (cond ((char=? c #\|)
10213 (let* ((str
10214 (##build-escaped-string-up-to re #\|))
10215 (keywords-allowed?
10216 (macro-readtable-keywords-allowed?
10217 (macro-readenv-readtable re))))
10218 (if (and keywords-allowed?
10219 (not (eq? keywords-allowed? 'prefix))
10220 (eq? (macro-peek-next-char-or-eof re) #\:))
10221 (begin
10222 (macro-read-next-char-or-eof re) ;; skip #\:
10223 (string->key str))
10224 (string->sym str))))
10225 ((and (char=? c #\:)
10226 (let ((keywords-allowed?
10227 (macro-readtable-keywords-allowed?
10228 (macro-readenv-readtable re))))
10229 (eq? keywords-allowed? 'prefix))
10230 (eq? (macro-peek-next-char-or-eof re) #\|))
10231 (macro-read-next-char-or-eof re) ;; skip #\|
10232 (let ((str
10233 (##build-escaped-string-up-to re #\|)))
10234 (string->key str)))
10235 (else
10236 (##string->number/keyword/symbol
10237 re
10238 (##build-delimited-string re c 1)
10239 intern?))))
10241 (define (##string->number/keyword/symbol re str intern?)
10243 (define (string->sym str)
10244 (if intern?
10245 (string->symbol-object str)
10246 (string->uninterned-symbol-object str)))
10248 (or (and intern? (string->number str 10))
10249 (begin
10250 (##readtable-string-convert-case!
10251 (macro-readenv-readtable re)
10252 str)
10253 (or (##readtable-parse-keyword
10254 (macro-readenv-readtable re)
10255 str
10256 intern?
10257 #t)
10258 (string->sym str)))))
10260 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
10262 (define (##char-octal? c)
10263 (if (and (not (char<? c #\0)) (not (char<? #\7 c)))
10264 (- (character->UCS-4 c) (character->UCS-4 #\0))
10265 #f))
10267 (define (##char-hexadecimal? c)
10268 (cond ((and (not (char<? c #\0)) (not (char<? #\9 c)))
10269 (- (character->UCS-4 c) (character->UCS-4 #\0)))
10270 ((and (not (char<? c #\a)) (not (char<? #\f c)))
10271 (- (character->UCS-4 c) (- (character->UCS-4 #\a) 10)))
10272 ((and (not (char<? c #\A)) (not (char<? #\F c)))
10273 (- (character->UCS-4 c) (- (character->UCS-4 #\A) 10)))
10274 (else
10275 #f)))
10277 (define (##build-escaped-string-up-to re close)
10279 (define (UCS-4 n)
10280 (if (in-char-range? n)
10281 (UCS-4->character n)
10282 (begin
10283 (##raise-datum-parsing-exception 'character-out-of-range re)
10284 #\nul)))
10286 (define (read-escape-octal first-digit)
10287 (let loop ((i 1)
10288 (n first-digit))
10289 (let ((next (macro-peek-next-char-or-eof re)))
10290 (cond ((and (or (< i 2)
10291 (and (= i 2) (< first-digit 4)))
10292 (char? next)
10293 (##char-octal? next))
10294 =>
10295 (lambda (next-digit)
10296 (macro-read-next-char-or-eof re) ;; skip "next"
10297 (loop (+ i 1)
10298 (+ (* n 8) next-digit))))
10299 (else
10300 (UCS-4 n))))))
10302 (define (read-escape-hexadecimal nb-digits)
10303 (let loop ((i 0)
10304 (n 0))
10305 (if (or (not nb-digits)
10306 (< i nb-digits))
10307 (let ((next (macro-peek-next-char-or-eof re)))
10308 (cond ((and (char? next)
10309 (##char-hexadecimal? next))
10310 =>
10311 (lambda (next-digit)
10312 (macro-read-next-char-or-eof re) ;; skip "next"
10313 (loop (+ i 1)
10314 (if (< n ##max-char)
10315 (+ (* n 16) next-digit)
10316 n))))
10317 (else
10318 (if nb-digits
10319 (begin
10320 (##raise-datum-parsing-exception 'invalid-hex-escape re)
10321 #\nul)
10322 (UCS-4 n)))))
10323 (UCS-4 n))))
10325 (define (read-escape next)
10326 (cond ((not (char? next))
10327 ;; read-chunk will report the end-of-file error
10328 #\nul)
10329 ((##char-octal? next)
10330 =>
10331 read-escape-octal)
10332 ((char=? next #\x)
10333 (read-escape-hexadecimal #f))
10334 ((char=? next #\u)
10335 (read-escape-hexadecimal 4))
10336 ((char=? next #\U)
10337 (read-escape-hexadecimal 8))
10338 (else
10339 (let ((x (assq next
10340 (macro-readtable-escaped-char-table
10341 (macro-readenv-readtable re)))))
10342 (if x
10343 (cdr x)
10344 (begin
10345 (##raise-datum-parsing-exception 'invalid-escaped-character re next)
10346 #\nul))))))
10348 (define max-chunk-length 512)
10350 (define (read-chunk)
10351 (let loop1 ((i 0))
10352 (if (< i max-chunk-length)
10353 (let loop2 ((c (macro-read-next-char-or-eof re)))
10354 (cond ((not (char? c))
10355 (##raise-datum-parsing-exception 'incomplete-form-eof-reached re)
10356 (make-string i))
10357 ((char=? c close)
10358 (make-string i))
10359 ((char=? c #\\)
10360 (let ((next (macro-read-next-char-or-eof re)))
10361 (if (eq? next #\newline)
10362 (let loop3 ()
10363 (let ((c (macro-read-next-char-or-eof re)))
10364 (if (and (char? c)
10365 (not (eq? c #\newline))
10366 (eq? (##readtable-char-handler
10367 (macro-readenv-readtable re)
10368 c)
10369 ##read-whitespace))
10370 (loop3)
10371 (loop2 c))))
10372 (let* ((c (read-escape next))
10373 (s (loop1 (+ i 1))))
10374 (string-set! s i c)
10375 s))))
10376 (else
10377 (let ((s (loop1 (+ i 1))))
10378 (string-set! s i c)
10379 s))))
10380 (make-string i))))
10382 (let ((chunk1 (read-chunk)))
10383 (if (< (string-length chunk1) max-chunk-length)
10384 chunk1
10385 (let loop ((chunks (list chunk1)))
10386 (let* ((new-chunk (read-chunk))
10387 (new-chunks (cons new-chunk chunks)))
10388 (if (< (string-length new-chunk) max-chunk-length)
10389 (##append-strings (reverse new-chunks))
10390 (loop new-chunks)))))))
10392 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
10394 (define (##build-decimal-integer re c i)
10395 (let loop ((i i))
10396 (let ((next (macro-peek-next-char-or-eof re)))
10397 (if (or (not (char? next))
10398 (let ((n (character->UCS-4 next)))
10399 (not (and (< 47 n) (< n 58)))))
10400 (make-string i c)
10401 (begin
10402 (macro-read-next-char-or-eof re) ;; skip "next"
10403 (let ((s (loop (+ i 1))))
10404 (string-set! s i next)
10405 s))))))
10407 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
10409 (define (##build-read-macro re start-pos old-pos kind)
10410 (if kind
10411 (let ((obj (##read-datum-or-label re)))
10412 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10413 (let* ((cell2 (cons obj '()))
10414 (cell1 (cons (macro-readenv-wrap re kind) cell2)))
10415 (if (##label-marker? obj)
10416 (##label-marker-fixup-handler-add!
10417 re
10418 obj
10419 (lambda (resolved-obj)
10420 (set-car! cell2 resolved-obj))))
10421 (macro-readenv-wrap re cell1)))
10422 (begin
10423 (##raise-datum-parsing-exception 'invalid-token re)
10424 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10425 (##read-datum-or-label-or-none-or-dot re)))) ;; skip error
10427 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
10429 ;;; Procedures to handle comments.
10431 (define (##skip-extended-comment re open1 open2 close1 close2)
10432 (let loop1 ((level 0))
10433 (let ((c (macro-read-next-char-or-eof re)))
10434 (if (not (char? c))
10435 (##raise-datum-parsing-exception 'incomplete-form-eof-reached re)
10436 (let loop2 ((level level) (c c))
10437 (if (or (char=? c open1) (char=? c close1))
10438 (let ((x (macro-read-next-char-or-eof re)))
10439 (if (not (char? x))
10440 (##raise-datum-parsing-exception 'incomplete-form-eof-reached re)
10441 (if (char=? c open1)
10442 (if (char=? x open2)
10443 (loop1 (+ level 1))
10444 (loop2 level x))
10445 (if (char=? x close2)
10446 (if (< 0 level)
10447 (loop1 (- level 1))
10448 #f) ;; comment has ended
10449 (loop2 level x)))))
10450 (loop1 level)))))))
10452 (define (##skip-single-line-comment re)
10453 (let loop ()
10454 (let ((next (macro-peek-next-char-or-eof re)))
10455 (if (char? next)
10456 (begin
10457 (macro-read-next-char-or-eof re) ;; skip "next"
10458 (if (not (char=? next #\newline))
10459 (loop)))))))
10461 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
10463 ;;; Procedure to read datums starting with '#'.
10465 (define (##read-sharp re c)
10466 (let ((start-pos (##readenv-current-filepos re)))
10467 (macro-read-next-char-or-eof re) ;; skip #\#
10468 (##read-sharp-aux re start-pos)))
10470 (define (##read-sharp-aux re start-pos)
10471 (let ((next (macro-peek-next-char-or-eof re)))
10472 (if (char? next)
10473 ((##readtable-char-sharp-handler (macro-readenv-readtable re) next)
10474 re
10475 next
10476 start-pos)
10477 (##read-sharp-other
10478 re
10479 next
10480 start-pos))))
10482 (define (##read-sharp-vector re next start-pos)
10483 (macro-read-next-char-or-eof re) ;; skip char after #\#
10484 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10485 (let ((vect (##build-vector re 'vector start-pos #\))))
10486 (macro-readenv-wrap re vect)))
10488 (define (##read-sharp-char re next start-pos)
10489 (let ((old-pos (macro-readenv-filepos re)))
10490 (macro-read-next-char-or-eof re) ;; skip char after #\#
10491 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10492 (let ((c (macro-read-next-char-or-eof re)))
10493 (cond ((not (char? c))
10494 (##raise-datum-parsing-exception 'incomplete-form-eof-reached re)
10495 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10496 (##read-datum-or-label-or-none-or-dot re)) ;; skip error
10497 ((eq? (##readtable-char-handler (macro-readenv-readtable re) c)
10498 ##read-whitespace)
10499 (macro-readenv-wrap re c))
10500 (else
10501 (let ((next (macro-peek-next-char-or-eof re)))
10502 (if (or (not (char? next))
10503 (##readtable-char-delimiter?
10504 (macro-readenv-readtable re)
10505 next))
10506 (macro-readenv-wrap re c)
10507 (let ((name (##build-delimited-string re c 1)))
10509 (define (read-hex nb-digits)
10510 (and (or (not nb-digits)
10511 (= (- (string-length name) 1) nb-digits))
10512 (let loop ((i 1)
10513 (n 0))
10514 (cond ((= i (string-length name))
10515 (UCS-4 n))
10516 ((##char-hexadecimal? (string-ref name i))
10517 =>
10518 (lambda (next-digit)
10519 (loop (+ i 1)
10520 (if (< n ##max-char)
10521 (+ (* n 16) next-digit)
10522 n))))
10523 (else
10524 #f)))))
10526 (define (UCS-4 n)
10527 (if (not (in-char-range? n))
10528 (begin
10529 (##raise-datum-parsing-exception
10530 'character-out-of-range
10531 re)
10532 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10533 (##read-datum-or-label-or-none-or-dot re)) ;; skip error
10534 (macro-readenv-wrap re (UCS-4->character n))))
10536 (define (invalid-character-name-error)
10537 (##raise-datum-parsing-exception
10538 'invalid-character-name
10539 re
10540 name)
10541 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10542 (##read-datum-or-label-or-none-or-dot re)) ;; skip error
10544 (or (cond ((char=? c #\x)
10545 (read-hex #f))
10546 ((char=? c #\u)
10547 (read-hex 4))
10548 ((char=? c #\U)
10549 (read-hex 8))
10550 #; ;; disable old #\#x1234 character syntax
10551 ((char=? c #\#)
10552 (let ((n (string->number name 10)))
10553 (and n
10554 (integer? n)
10555 (exact? n)
10556 (UCS-4 n))))
10557 (else
10558 #f))
10559 (let ((x
10560 (##read-assoc-string=?
10561 re
10562 name
10563 (macro-readtable-named-char-table
10564 (macro-readenv-readtable re)))))
10565 (if x
10566 (macro-readenv-wrap re (cdr x))
10567 (invalid-character-name-error))))))))))))
10569 (define (##read-sharp-comment re next start-pos)
10570 (let ((old-pos (macro-readenv-filepos re)))
10571 (macro-readenv-filepos-set! re start-pos) ;; in case error in comment
10572 (macro-read-next-char-or-eof re) ;; skip char after #\#
10573 (##skip-extended-comment re #\# next next #\#)
10574 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10575 (##read-datum-or-label-or-none-or-dot re))) ;; read what follows comment
10577 (define (##read-sharp-bang re next start-pos)
10578 (let ((old-pos (macro-readenv-filepos re)))
10579 (macro-read-next-char-or-eof re) ;; skip char after #\#
10580 (if (macro-readenv-allow-script? re)
10581 (##script-marker)
10582 (begin
10583 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10584 (let ((name (##build-delimited-string re #\space 0)))
10585 (let ((x
10586 (##read-assoc-string=?
10587 re
10588 name
10589 (macro-readtable-sharp-bang-table
10590 (macro-readenv-readtable re)))))
10591 (if x
10592 (macro-readenv-wrap re (cdr x))
10593 (begin
10594 (##raise-datum-parsing-exception 'invalid-sharp-bang-name re name)
10595 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10596 (##read-datum-or-label-or-none-or-dot re))))))))) ;; skip error
10598 (define (##read-sharp-keyword/symbol re next start-pos)
10599 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10600 (let ((str (##build-delimited-string re #\# 1)))
10601 (let ((n (string-length str)))
10602 (let loop ((i (- n 1)))
10603 (cond ((< i 0)
10604 (##wrap-op1* re
10605 start-pos
10606 (macro-readtable-sharp-seq-keyword
10607 (macro-readenv-readtable re))
10608 (- n 1)))
10609 ((char=? #\# (string-ref str i))
10610 (loop (- i 1)))
10611 (else
10612 (let ((obj (##string->number/keyword/symbol re str #t)))
10613 (macro-readenv-wrap re obj))))))))
10615 (define (##read-sharp-colon re next start-pos)
10616 (let ((old-pos (macro-readenv-filepos re)))
10617 (macro-read-next-char-or-eof re) ;; skip char after #\#
10618 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10619 (let ((c (macro-read-next-char-or-eof re)))
10620 (if (char? c)
10621 (let ((obj (##build-delimited-number/keyword/symbol re c #f)))
10622 (macro-readenv-wrap re obj))
10623 (begin
10624 (##raise-datum-parsing-exception 'incomplete-form-eof-reached re)
10625 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10626 (##read-datum-or-label-or-none-or-dot re)))))) ;; skip error
10628 (define (##read-sharp-semicolon re next start-pos)
10629 (let ((old-pos (macro-readenv-filepos re)))
10630 (macro-read-next-char-or-eof re) ;; skip char after #\#
10631 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10632 (let ((obj (##read-datum-or-label re)))
10633 (if (##label-marker? obj)
10634 (##label-marker-fixup-handler-add!
10635 re
10636 obj
10637 (lambda (resolved-obj)
10638 #f)))
10639 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10640 (##read-datum-or-label-or-none-or-dot re)))) ;; read what follows comment
10642 (define (##read-sharp-quotation re next start-pos)
10643 (let ((old-pos (macro-readenv-filepos re)))
10644 (macro-read-next-char-or-eof re) ;; skip #\' or #\` or #\,
10645 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10646 (let ((keyword
10647 (cond ((eq? next #\,)
10648 (let ((after-comma (macro-peek-next-char-or-eof re)))
10649 (if (eq? after-comma #\@)
10650 (begin
10651 (macro-read-next-char-or-eof re) ;; skip #\@
10652 (macro-readtable-sharp-unquote-splicing-keyword
10653 (macro-readenv-readtable re)))
10654 (macro-readtable-sharp-unquote-keyword
10655 (macro-readenv-readtable re)))))
10656 ((eq? next #\`)
10657 (macro-readtable-sharp-quasiquote-keyword
10658 (macro-readenv-readtable re)))
10659 (else
10660 (macro-readtable-sharp-quote-keyword
10661 (macro-readenv-readtable re))))))
10662 (##build-read-macro re start-pos old-pos keyword))))
10664 (define (##read-sharp-ampersand re next start-pos)
10665 (macro-read-next-char-or-eof re) ;; skip char after #\#
10666 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10667 (let ((obj (##read-datum-or-label re)))
10668 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10669 (let ((b (box obj)))
10670 (if (##label-marker? obj)
10671 (##label-marker-fixup-handler-add!
10672 re
10673 obj
10674 (lambda (resolved-obj)
10675 (set-box! b resolved-obj))))
10676 (macro-readenv-wrap re b))))
10678 (define (##read-sharp-dot re next start-pos)
10679 (if (not (macro-readtable-eval-allowed? (macro-readenv-readtable re)))
10680 (begin
10681 (##raise-datum-parsing-exception 'invalid-token re)
10682 (##read-datum-or-label-or-none-or-dot re)) ;; skip error
10683 (begin
10684 (macro-read-next-char-or-eof re) ;; skip char after #\#
10685 (let* ((expr
10686 (##read-expr-from-port
10687 (macro-readenv-port re)))
10688 (val
10689 (##eval expr)))
10690 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10691 (macro-readenv-wrap re val)))))
10693 (define-prim (##read-sharp-less re next start-pos)
10695 (define (eof)
10696 (##raise-datum-parsing-exception 'incomplete-form-eof-reached re))
10698 (define (invalid-token)
10699 (##raise-datum-parsing-exception 'invalid-token re))
10701 (macro-read-next-char-or-eof re) ;; skip char after #\#
10702 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10703 (if (macro-readtable-here-strings-allowed?
10704 (macro-readenv-readtable re))
10705 (let ((separator (macro-read-next-char-or-eof re)))
10706 (cond ((not (char? separator))
10707 (eof))
10708 ((eq? separator #\<)
10709 ;; Multiline SCSH here string of the form
10710 ;; #<<END
10711 ;; hello world
10712 ;; END
10713 (let ((tag
10714 (##read-line (macro-readenv-port re) #\newline #t ##max-fixnum)))
10715 (let loop ((lines-rev '()))
10716 (let ((line
10717 (##read-line (macro-readenv-port re) #\newline #t ##max-fixnum)))
10718 (if (string? line)
10719 (if (string=? line tag)
10720 (let* ((str
10721 (##append-strings (##reverse lines-rev)))
10722 (len
10723 (string-length str)))
10724 (if (< 0 len)
10725 (##string-shrink! str (- len 1)))
10726 (macro-readenv-wrap re str))
10727 (loop (cons line lines-rev)))
10728 (eof))))))
10729 ((eq? (macro-readtable-here-strings-allowed?
10730 (macro-readenv-readtable re))
10731 #t)
10732 ;; Delimited here string of the form #<|foo|
10733 (let ((str
10734 (##read-line (macro-readenv-port re) separator #t ##max-fixnum)))
10735 (if (string? str)
10736 (let ((len (string-length str)))
10737 (if (and (< 0 len)
10738 (eq? (string-ref str (- len 1)) separator))
10739 (begin
10740 (##string-shrink! str (- len 1))
10741 (macro-readenv-wrap re str))
10742 (eof)))
10743 (eof))))
10744 ((invalid-token))))
10745 (invalid-token)))
10747 (define (##read-sharp-digit re next start-pos)
10748 (let ((old-pos (macro-readenv-filepos re)))
10749 (macro-read-next-char-or-eof re) ;; skip char after #\#
10750 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10751 (let ((s (##build-decimal-integer re next 2)))
10752 (string-set! s 0 #\0)
10753 (let* ((n (string->number s 10))
10754 (c (macro-peek-next-char-or-eof re)))
10755 (cond ((or (and (not (eq? c #\#))
10756 (not (eq? c #\=)))
10757 (not (macro-readtable-sharing-allowed?
10758 (macro-readenv-readtable re))))
10759 (##wrap-op1* re
10760 start-pos
10761 (macro-readtable-sharp-num-keyword
10762 (macro-readenv-readtable re))
10763 n))
10764 ((eq? c #\#)
10765 (macro-read-next-char-or-eof re) ;; skip #\#
10766 (##label-marker-reference re n))
10767 (else
10768 (macro-read-next-char-or-eof re) ;; skip #\=
10769 (let ((obj (##read-datum-or-label re)))
10770 (if (##label-marker? obj)
10771 (begin
10772 (##raise-datum-parsing-exception
10773 'illegal-label-definition
10774 re
10775 n)
10776 (##void))
10777 (let ((uobj (macro-readenv-unwrap re obj)))
10778 (##label-marker-define re n uobj)
10779 obj)))))))))
10781 (define (##wrap re pos datum)
10782 (let ((old-pos (macro-readenv-filepos re)))
10783 (macro-readenv-filepos-set! re pos)
10784 (let ((x (macro-readenv-wrap re datum)))
10785 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10786 x)))
10788 (define (##wrap-op re pos op args)
10789 (##wrap re pos (cons (##wrap re pos op) args)))
10791 (define (##wrap-op0 re pos op)
10792 (##wrap-op re pos op '()))
10794 (define (##wrap-op1 re pos op arg1)
10795 (##wrap-op re pos op (list arg1)))
10797 (define (##wrap-op1* re pos op arg1)
10798 (##wrap-op re pos op (list (##wrap re pos arg1))))
10800 (define (##wrap-op2 re pos op arg1 arg2)
10801 (##wrap-op re pos op (list arg1 arg2)))
10803 (define (##wrap-op3 re pos op arg1 arg2 arg3)
10804 (##wrap-op re pos op (list arg1 arg2 arg3)))
10806 (define (##wrap-op4 re pos op arg1 arg2 arg3 arg4)
10807 (##wrap-op re pos op (list arg1 arg2 arg3 arg4)))
10809 (define (##read-sharp-other re next start-pos)
10810 (let ((old-pos (macro-readenv-filepos re)))
10811 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10812 (let* ((s
10813 (##build-delimited-string re #\# 1))
10814 (num
10815 (string->number s 10)))
10816 (if num
10818 (macro-readenv-wrap re num)
10820 (let ()
10822 (define (build-vect re kind)
10823 (let ((c (macro-read-next-char-or-eof re)))
10824 (if (eq? c #\()
10825 (macro-readenv-wrap re (##build-vector re kind start-pos #\)))
10826 (begin
10827 (##raise-datum-parsing-exception 'open-paren-expected re)
10828 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10829 (##read-datum-or-label-or-none-or-dot re))))) ;; skip error
10831 (define (deserialize re implode);;;;;;;;;;;;;;;;;;;;;;;;;;;;
10832 (let ((c (macro-read-next-char-or-eof re)))
10833 (if (eq? c #\()
10834 (let* ((old-wrapper (macro-readenv-wrapper re))
10835 (old-unwrapper (macro-readenv-unwrapper re)))
10836 (macro-readenv-wrapper-set! re (lambda (re x) x))
10837 (macro-readenv-unwrapper-set! re (lambda (re x) x))
10838 (let* ((fields
10839 (##build-vector re 'deserialize start-pos #\)))
10840 (obj
10841 (implode re fields)))
10842 (macro-readenv-wrapper-set! re old-wrapper)
10843 (macro-readenv-unwrapper-set! re old-unwrapper)
10844 (if obj
10845 (macro-readenv-wrap re obj)
10846 (begin
10847 ;;;;;;;;;;;;error
10848 (##raise-datum-parsing-exception 'open-paren-expected re)
10849 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10850 (##read-datum-or-label-or-none-or-dot re))))) ;; skip error
10851 (begin
10852 (##raise-datum-parsing-exception 'open-paren-expected re)
10853 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10854 (##read-datum-or-label-or-none-or-dot re))))) ;; skip error
10856 (cond ((##read-string=? re s "#f")
10857 (macro-readenv-wrap re (false-obj)))
10858 ((##read-string=? re s "#t")
10859 (macro-readenv-wrap re #t))
10860 ((##read-string=? re s "#s8")
10861 (build-vect re 's8vector))
10862 ((##read-string=? re s "#u8")
10863 (build-vect re 'u8vector))
10864 ((##read-string=? re s "#s16")
10865 (build-vect re 's16vector))
10866 ((##read-string=? re s "#u16")
10867 (build-vect re 'u16vector))
10868 ((##read-string=? re s "#s32")
10869 (build-vect re 's32vector))
10870 ((##read-string=? re s "#u32")
10871 (build-vect re 'u32vector))
10872 ((##read-string=? re s "#s64")
10873 (build-vect re 's64vector))
10874 ((##read-string=? re s "#u64")
10875 (build-vect re 'u64vector))
10876 ((##read-string=? re s "#f32")
10877 (build-vect re 'f32vector))
10878 ((##read-string=? re s "#f64")
10879 (build-vect re 'f64vector))
10880 ((##read-string=? re s "#structure")
10881 (deserialize re ##implode-structure))
10882 ((##read-string=? re s "#gc-hash-table")
10883 (deserialize re ##implode-gc-hash-table))
10884 ((##read-string=? re s "#frame")
10885 (deserialize re ##implode-frame))
10886 ((##read-string=? re s "#continuation")
10887 (deserialize re ##implode-continuation))
10888 ((##read-string=? re s "#procedure")
10889 (deserialize re ##implode-procedure))
10890 ((##read-string=? re s "#return")
10891 (deserialize re ##implode-return))
10892 ((##read-string=? re s "#promise")
10893 (deserialize re ##implode-promise))
10894 ((##read-string=? re s "#absent")
10895 (##wrap re
10896 start-pos
10897 (macro-absent-obj)))
10898 ((##read-string=? re s "#")
10899 (##wrap-op1* re
10900 start-pos
10901 (macro-readtable-sharp-seq-keyword
10902 (macro-readenv-readtable re))
10903 0))
10904 (else
10905 (##raise-datum-parsing-exception 'invalid-token re)
10906 (macro-readenv-filepos-set! re old-pos) ;; restore pos
10907 (##read-datum-or-label-or-none-or-dot re)))))))) ;; skip error
10909 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
10911 (define (##read-whitespace re c)
10912 (macro-read-next-char-or-eof re) ;; skip whitespace character
10913 (##read-datum-or-label-or-none-or-dot re)) ;; read what follows whitespace
10915 (define (##read-single-line-comment re c)
10916 (##skip-single-line-comment re) ;; skip comment
10917 (##read-datum-or-label-or-none-or-dot re)) ;; read what follows comment
10919 (define (##read-escaped-string re c)
10920 (let ((start-pos (##readenv-current-filepos re)))
10921 (macro-read-next-char-or-eof re) ;; skip #\"
10922 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10923 (let ((str (##build-escaped-string-up-to re c)))
10924 (macro-readenv-wrap re str))))
10926 (define (##read-quotation re c)
10927 (let* ((old-pos (macro-readenv-filepos re))
10928 (start-pos (##readenv-current-filepos re)))
10929 (macro-read-next-char-or-eof re) ;; skip #\' or #\` or #\,
10930 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10931 (let ((keyword
10932 (cond ((eq? c #\,)
10933 (let ((after-comma (macro-peek-next-char-or-eof re)))
10934 (if (eq? after-comma #\@)
10935 (begin
10936 (macro-read-next-char-or-eof re) ;; skip #\@
10937 (macro-readtable-unquote-splicing-keyword
10938 (macro-readenv-readtable re)))
10939 (macro-readtable-unquote-keyword
10940 (macro-readenv-readtable re)))))
10941 ((eq? c #\`)
10942 (macro-readtable-quasiquote-keyword
10943 (macro-readenv-readtable re)))
10944 (else
10945 (macro-readtable-quote-keyword
10946 (macro-readenv-readtable re))))))
10947 (##build-read-macro re start-pos old-pos keyword))))
10949 (define (##closing-parenthesis-for c)
10950 (cond ((char=? c #\[) #\])
10951 ((char=? c #\{) #\})
10952 ((char=? c #\<) #\>)
10953 (else #\))))
10955 (define (##read-vector-or-list re c)
10956 (if (macro-readtable-r6rs-compatible-read?
10957 (macro-readenv-readtable re))
10958 (##read-list re c)
10959 (##read-vector re c)))
10961 (define (##read-list re c)
10962 (let ((start-pos (##readenv-current-filepos re)))
10963 (macro-read-next-char-or-eof re) ;; skip #\( or #\[ or #\{ or #\<
10964 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10965 (let* ((close (##closing-parenthesis-for c))
10966 (lst (##build-list re #t start-pos close)))
10968 (define (prefix keyword)
10969 (macro-readenv-wrap
10970 re
10971 (cons (macro-readenv-wrap re keyword) lst)))
10973 (cond ((and (char=? c #\[)
10974 (macro-readtable-bracket-keyword
10975 (macro-readenv-readtable re)))
10976 =>
10977 prefix)
10978 ((and (char=? c #\{)
10979 (macro-readtable-brace-keyword
10980 (macro-readenv-readtable re)))
10981 =>
10982 prefix)
10983 ((and (char=? c #\<)
10984 (macro-readtable-angle-keyword
10985 (macro-readenv-readtable re)))
10986 =>
10987 prefix)
10988 ((macro-readtable-paren-keyword
10989 (macro-readenv-readtable re))
10990 =>
10991 prefix)
10992 (else
10993 (macro-readenv-wrap re lst))))))
10995 (define (##read-vector re c)
10996 (let ((start-pos (##readenv-current-filepos re)))
10997 (macro-read-next-char-or-eof re) ;; skip #\( or #\[ or #\{ or #\<
10998 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
10999 (let* ((close (##closing-parenthesis-for c))
11000 (v (##build-vector re 'vector start-pos close)))
11001 (macro-readenv-wrap re v))))
11003 (define (##read-other re c)
11004 (##read-list re c))
11006 (define (##read-none re c)
11007 (##none-marker))
11009 (define (##read-illegal re c)
11010 (let* ((old-pos (macro-readenv-filepos re))
11011 (start-pos (##readenv-current-filepos re)))
11012 (macro-read-next-char-or-eof re) ;; skip illegal character
11013 (macro-readenv-filepos-set! re start-pos) ;; set pos to illegal char
11014 (##raise-datum-parsing-exception 'illegal-character re c)
11015 (macro-readenv-filepos-set! re old-pos) ;; restore pos
11016 (##read-datum-or-label-or-none-or-dot re))) ;; skip error
11018 (define (##read-dot re c)
11019 (let ((start-pos (##readenv-current-filepos re)))
11020 (macro-read-next-char-or-eof re) ;; skip #\.
11021 (let ((next (macro-peek-next-char-or-eof re)))
11022 (if (or (not (char? next))
11023 (##readtable-char-delimiter? (macro-readenv-readtable re) next))
11024 (##dot-marker)
11025 (begin
11026 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
11027 (let ((obj (##build-delimited-number/keyword/symbol re c #t)))
11028 (macro-readenv-wrap re obj)))))))
11030 (define (##read-number/keyword/symbol re c)
11031 (let ((start-pos (##readenv-current-filepos re)))
11032 (macro-read-next-char-or-eof re) ;; skip "c"
11033 (if (and (char=? c #\@)
11034 (macro-readenv-allow-script? re)
11035 (eq? (macro-peek-next-char-or-eof re) #\;))
11036 (begin
11037 (macro-read-next-char-or-eof re) ;; skip #\;
11038 (##script-marker))
11039 (begin
11040 (macro-readenv-filepos-set! re start-pos) ;; set pos to start of datum
11041 (let ((obj (##build-delimited-number/keyword/symbol re c #t)))
11042 (macro-readenv-wrap re obj))))))
11044 (define (##read-assoc-string=? re x lst)
11045 (let loop ((lst lst))
11046 (if (pair? lst)
11047 (let ((couple (car lst)))
11048 (let ((y (car couple)))
11049 (if (##read-string=? re x y)
11050 couple
11051 (loop (cdr lst)))))
11052 #f)))
11054 (define (##read-string=? re str1 str2)
11055 (let ((case-conversion?
11056 (macro-readtable-case-conversion?
11057 (macro-readenv-readtable re))))
11058 (if case-conversion?
11059 (string-ci=? str1 str2)
11060 (string=? str1 str2))))
11062 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
11064 ;;; Scheme infix extension (SIX) parser.
11066 (define (##read-six re c)
11067 (macro-read-next-char-or-eof re) ;; skip backslash
11068 (##read-six-datum-or-eof re #f))
11070 (define (##read-six-datum-or-eof re allow-eof?)
11072 (##define-macro (define-six-token name . params)
11073 `(define ,name
11074 '#(,@params)))
11076 (##define-macro (define-six-op
11077 name
11078 precedence
11079 associativity
11080 . scheme-names)
11081 `(define-six-token ,name
11082 ,(+ (* precedence 2) (if (eq? associativity 'lr) 0 1))
11083 ,@scheme-names))
11085 (define (op? x)
11086 (and (vector? x)
11087 (< 1 (vector-length x))))
11089 (define (precedence op)
11090 (quotient (vector-ref op 0) 2))
11092 (define (left-to-right? op)
11093 (= (modulo (vector-ref op 0) 2) 0))
11095 (define (binary-or-ternary? op)
11096 (vector-ref op 1))
11098 (define (ternary? tok)
11099 (cond ((eq? tok op.?)
11100 |op.:|)
11101 (else
11102 #f)))
11104 (define (unary-prefix? op)
11105 (and (< 2 (vector-length op))
11106 (vector-ref op 2)))
11108 (define (unary-postfix? op)
11109 (and (< 3 (vector-length op))
11110 (vector-ref op 3)))
11112 (define-six-token |token.(| -1)
11113 (define-six-token |token.)| -2)
11114 (define-six-token |token.->| -3)
11115 (define-six-token |token..| -4)
11116 (define-six-token |token...| -5)
11117 (define-six-token |token.;| -6)
11118 (define-six-token |token.[| -7)
11119 (define-six-token |token.\\| -8)
11120 (define-six-token |token.]| -9)
11121 (define-six-token |token.{| -10)
11122 (define-six-token |token.}| -11)
11123 (define-six-token |token.`| -12)
11124 (define-six-token |token.#| -13)
11125 (define-six-token token.script -14)
11127 (define-six-op op.! 2 rl six.x!y six.!x )
11128 (define-six-op op.++ 2 rl #f six.++x six.x++ )
11129 (define-six-op op.-- 2 rl #f six.--x six.x-- )
11130 (define-six-op op.~ 2 rl #f six.~x )
11131 (define-six-op op.% 3 lr six.x%y )
11132 (define-six-op op.* 3 lr six.x*y six.*x )
11133 (define-six-op op./ 3 lr six.x/y )
11134 (define-six-op op.+ 4 lr six.x+y six.+x )
11135 (define-six-op op.- 4 lr six.x-y six.-x )
11136 (define-six-op op.<< 5 lr six.x<<y )
11137 (define-six-op op.>> 5 lr six.x>>y )
11138 (define-six-op op.< 6 lr six.x<y )
11139 (define-six-op op.<= 6 lr six.x<=y )
11140 (define-six-op op.> 6 lr six.x>y )
11141 (define-six-op op.>= 6 lr six.x>=y )
11142 (define-six-op op.!= 7 lr six.x!=y )
11143 (define-six-op op.== 7 lr six.x==y )
11144 (define-six-op op.& 8 lr six.x&y six.&x )
11145 (define-six-op op.^ 9 lr six.x^y )
11146 (define-six-op |op.\|| 10 lr |six.x\|y| )
11147 (define-six-op op.&& 11 lr six.x&&y )
11148 (define-six-op |op.\|\|| 12 lr |six.x\|\|y| )
11149 (define-six-op op.? 13 rl six.x?y:z )
11150 (define-six-op |op.:| 14 rl six.x:y )
11151 (define-six-op op.%= 15 rl six.x%=y )
11152 (define-six-op op.&= 15 rl six.x&=y )
11153 (define-six-op op.*= 15 rl six.x*=y )
11154 (define-six-op op.+= 15 rl six.x+=y )
11155 (define-six-op op.-= 15 rl six.x-=y )
11156 (define-six-op op./= 15 rl six.x/=y )
11157 (define-six-op op.<<= 15 rl six.x<<=y )
11158 (define-six-op op.= 15 rl six.x=y )
11159 (define-six-op op.>>= 15 rl six.x>>=y )
11160 (define-six-op op.^= 15 rl six.x^=y )
11161 (define-six-op |op.\|=| 15 rl |six.x\|=y| )
11162 (define-six-op op.:= 16 rl six.x:=y )
11163 (define-six-op |op.,| 17 lr |six.x,y| );;;;;;;;;;;;;;;; |six.,x| )
11164 (define-six-op op.:- 18 rl six.x:-y )
11166 (define max-precedence 18)
11168 (define (decimal-digit? c)
11169 (and (not (char<? c #\0)) (not (char<? #\9 c))))
11171 (define (alphabetic? c)
11172 (or (and (not (char<? c #\a)) (not (char<? #\z c)))
11173 (and (not (char<? c #\A)) (not (char<? #\Z c)))))
11175 (define (identifier-starter? c)
11176 (or (char=? c #\_)
11177 (char=? c #\$)
11178 (alphabetic? c)))
11180 (define (parse-number re c1 c2)
11181 (let ((str
11182 (let loop ((i 2) (state (if (char=? c1 #\.) 1 0)))
11183 (let ((next (macro-peek-next-char-or-eof re)))
11184 (if (or (not (char? next))
11185 (not (or (decimal-digit? next)
11186 (and (= state 0)
11187 (char=? next #\.))
11188 (and (= state 1)
11189 (or (char=? next #\e)
11190 (char=? next #\E)))
11191 (and (= state 2)
11192 (or (char=? next #\+)
11193 (char=? next #\-))))))
11194 (make-string i c2)
11195 (begin
11196 (macro-read-next-char-or-eof re) ;; skip "next"
11197 (let ((s
11198 (loop (+ i 1)
11199 (if (or (= state 2)
11200 (not (decimal-digit? next)))
11201 (+ state 1)
11202 state))))
11203 (string-set! s i next)
11204 s)))))))
11205 (string-set! str 0 c1)
11206 (let ((last (string-ref str (- (string-length str) 1))))
11207 (if (or (char=? last #\.) (decimal-digit? last))
11208 (string->number str)
11209 (begin
11210 (invalid-infix-syntax-number re)
11211 (macro-inexact-+0))))))
11213 (define (parse-character re c)
11214 (let ((str
11215 (##build-escaped-string-up-to re c)))
11216 (if (= (string-length str) 1)
11217 (string-ref str 0)
11218 (begin
11219 (invalid-infix-syntax-character re)
11220 #\nul))))
11222 (define (parse-identifier re c)
11223 (let ((str
11224 (let loop ((i 1))
11225 (let ((next (macro-peek-next-char-or-eof re)))
11226 (if (or (not (char? next))
11227 (and (not (alphabetic? next))
11228 (not (decimal-digit? next))
11229 (not (char=? next #\_))))
11230 (make-string i c)
11231 (begin
11232 (macro-read-next-char-or-eof re) ;; skip "next"
11233 (let ((s (loop (+ i 1))))
11234 (string-set! s i next)
11235 s)))))))
11236 (string->symbol-object str)))
11238 (define (parse-token re)
11239 (parse-token-starting-with re (macro-peek-next-char-or-eof re)))
11241 (define (parse-token-starting-with re c)
11242 (macro-readenv-allow-script?-set!
11243 re
11244 (eq? (macro-readenv-allow-script? re) 'script))
11245 (cond ((not (char? c))
11246 (##none-marker))
11247 ((eq? (##readtable-char-handler (macro-readenv-readtable re) c)
11248 ##read-whitespace)
11249 (macro-read-next-char-or-eof re) ;; skip whitespace character
11250 (parse-token re))
11251 (else
11252 (let ((start-pos (##readenv-current-filepos re)))
11254 (macro-readenv-filepos-set! re start-pos) ;; restore pos
11255 (macro-read-next-char-or-eof re) ;; skip c
11257 (cond ((or (char=? c #\+)
11258 (char=? c #\-)
11259 (char=? c #\*)
11260 (char=? c #\/)
11261 (char=? c #\%)
11262 (char=? c #\!)
11263 (char=? c #\~)
11264 (char=? c #\&)
11265 (char=? c #\|)
11266 (char=? c #\^)
11267 (char=? c #\<)
11268 (char=? c #\>)
11269 (char=? c #\=)
11270 (char=? c #\{)
11271 (char=? c #\})
11272 (char=? c #\()
11273 (char=? c #\))
11274 (char=? c #\[)
11275 (char=? c #\])
11276 (char=? c #\;)
11277 (char=? c #\,)
11278 (char=? c #\:)
11279 (char=? c #\.)
11280 (char=? c #\?)
11281 (char=? c #\\)
11282 (char=? c #\")
11283 (char=? c #\')
11284 (char=? c #\`)
11285 (char=? c #\#)
11286 (decimal-digit? c)
11287 (identifier-starter? c))
11289 (let ((next (macro-peek-next-char-or-eof re)))
11290 (let ((x (if (char? next) next #\space)))
11292 (define (token tok)
11293 tok)
11295 (define (one-char-token tok)
11296 (token tok))
11298 (define (two-char-token tok)
11299 (macro-read-next-char-or-eof re) ;; skip last
11300 (token tok))
11302 (cond ((char=? c #\+)
11303 (cond ((char=? x #\+)
11304 (two-char-token op.++))
11305 ((char=? x #\=)
11306 (two-char-token op.+=))
11307 (else
11308 (one-char-token op.+))))
11309 ((char=? c #\-)
11310 (cond ((char=? x #\-)
11311 (two-char-token op.--))
11312 ((char=? x #\=)
11313 (two-char-token op.-=))
11314 ((char=? x #\>)
11315 (two-char-token |token.->|))
11316 (else
11317 (one-char-token op.-))))
11318 ((char=? c #\*)
11319 (cond ((char=? x #\=)
11320 (two-char-token op.*=))
11321 (else
11322 (one-char-token op.*))))
11323 ((char=? c #\/)
11324 (cond ((char=? x #\/)
11325 (macro-read-next-char-or-eof re);;skip #\/
11326 (##skip-single-line-comment re)
11327 (parse-token re))
11328 ((char=? x #\*)
11329 (macro-read-next-char-or-eof re);;skip #\*
11330 (##skip-extended-comment re #\/ x x #\/)
11331 (parse-token re))
11332 ((char=? x #\=)
11333 (two-char-token op./=))
11334 (else
11335 (one-char-token op./))))
11336 ((char=? c #\%)
11337 (cond ((char=? x #\=)
11338 (two-char-token op.%=))
11339 (else
11340 (one-char-token op.%))))
11341 ((char=? c #\!)
11342 (cond ((char=? x #\=)
11343 (two-char-token op.!=))
11344 (else
11345 (one-char-token op.!))))
11346 ((char=? c #\~)
11347 (one-char-token op.~))
11348 ((char=? c #\&)
11349 (cond ((char=? x #\&)
11350 (two-char-token op.&&))
11351 ((char=? x #\=)
11352 (two-char-token op.&=))
11353 (else
11354 (one-char-token op.&))))
11355 ((char=? c #\|)
11356 (cond ((char=? x #\|)
11357 (two-char-token |op.\|\||))
11358 ((char=? x #\=)
11359 (two-char-token |op.\|=|))
11360 (else
11361 (one-char-token |op.\||))))
11362 ((char=? c #\^)
11363 (cond ((char=? x #\=)
11364 (two-char-token op.^=))
11365 (else
11366 (one-char-token op.^))))
11367 ((char=? c #\<)
11368 (cond ((char=? x #\<)
11369 (macro-read-next-char-or-eof re);;skip #\<
11370 (let ((next2
11371 (macro-peek-next-char-or-eof re)))
11372 (let ((x2 (if (char? next2)
11373 next2
11374 #\space)))
11375 (cond ((char=? x2 #\=)
11376 (two-char-token op.<<=))
11377 (else
11378 (one-char-token op.<<))))))
11379 ((char=? x #\=)
11380 (two-char-token op.<=))
11381 (else
11382 (one-char-token op.<))))
11383 ((char=? c #\>)
11384 (cond ((char=? x #\>)
11385 (macro-read-next-char-or-eof re);;skip #\>
11386 (let ((next2
11387 (macro-peek-next-char-or-eof re)))
11388 (let ((x2 (if (char? next2)
11389 next2
11390 #\space)))
11391 (cond ((char=? x2 #\=)
11392 (two-char-token op.>>=))
11393 (else
11394 (one-char-token op.>>))))))
11395 ((char=? x #\=)
11396 (two-char-token op.>=))
11397 (else
11398 (one-char-token op.>))))
11399 ((char=? c #\=)
11400 (cond ((char=? x #\=)
11401 (two-char-token op.==))
11402 (else
11403 (one-char-token op.=))))
11404 ((char=? c #\{)
11405 (one-char-token |token.{|))
11406 ((char=? c #\})
11407 (one-char-token |token.}|))
11408 ((char=? c #\()
11409 (one-char-token |token.(|))
11410 ((char=? c #\))
11411 (one-char-token |token.)|))
11412 ((char=? c #\[)
11413 (one-char-token |token.[|))
11414 ((char=? c #\])
11415 (one-char-token |token.]|))
11416 ((char=? c #\;)
11417 (one-char-token |token.;|))
11418 ((char=? c #\,)
11419 (one-char-token |op.,|))
11420 ((char=? c #\:)
11421 (cond ((char=? x #\=)
11422 (two-char-token op.:=))
11423 ((char=? x #\-)
11424 ;; In the C syntax "1?2:-3" is
11425 ;; parsed as "1 ? 2 : -3". In
11426 ;; order to support the ":-"
11427 ;; operator cleanly, the source
11428 ;; code must have whitespace
11429 ;; between the ":" and "-",
11430 ;; otherwise it will be parsed as
11431 ;; "1 ? 2 :- 3" (which is a
11432 ;; syntax error).
11433 (two-char-token op.:-))
11434 (else
11435 (one-char-token |op.:|))))
11436 ((char=? c #\.)
11437 (cond ((decimal-digit? x)
11438 (macro-read-next-char-or-eof re) ;; skip x
11439 (token (parse-number re c x)))
11440 ((char=? x #\.)
11441 (two-char-token |token...|))
11442 (else
11443 (one-char-token |token..|))))
11444 ((char=? c #\?)
11445 (one-char-token op.?))
11446 ((char=? c #\\)
11447 (one-char-token |token.\\|))
11448 ((char=? c #\")
11449 (token (##build-escaped-string-up-to re c)))
11450 ((char=? c #\')
11451 (token (parse-character re c)))
11452 ((char=? c #\`)
11453 (one-char-token |token.`|))
11454 ((char=? c #\#)
11455 (if (and (macro-readenv-allow-script? re)
11456 (char=? x #\!))
11457 (two-char-token (##script-marker))
11458 (one-char-token |token.#|)))
11459 ((decimal-digit? c)
11460 (token (parse-number re #\0 c)))
11461 (else
11462 (token (parse-identifier re c)))))))
11464 ((char=? c #\@)
11465 (if (and (macro-readenv-allow-script? re)
11466 (eq? (macro-peek-next-char-or-eof re) #\;))
11467 (begin
11468 (macro-read-next-char-or-eof re) ;; skip #\;
11469 (##script-marker))
11470 (##none-marker)))
11472 (else
11473 (##none-marker)))))))
11475 (define (get-token re maybe-tok)
11476 (or maybe-tok (parse-token re)))
11478 (define (expect re maybe-tok expected)
11479 (let ((tok (get-token re maybe-tok)))
11480 (if (eq? tok expected)
11481 #f
11482 (begin
11483 (invalid-infix-syntax re)
11484 tok))))
11486 (define (read-arguments-tail re maybe-tok cont)
11487 (let ((tok (get-token re maybe-tok)))
11488 (if (eq? tok |token.)|)
11489 (cont re
11490 #f
11491 '())
11492 (let loop ((re re) (tok tok) (args '()))
11493 (cond ((expression-starter? re tok)
11494 (read-expression
11495 re
11496 tok
11497 max-precedence
11498 'no-comma
11499 (lambda (re maybe-tok expr)
11500 (let ((new-args (cons expr args)))
11501 (let ((tok (get-token re maybe-tok)))
11502 (cond ((eq? tok |op.,|)
11503 (loop re
11504 (get-token re #f)
11505 new-args))
11506 (else
11507 (cont re
11508 (expect re tok |token.)|)
11509 (reverse new-args)))))))))
11510 (else
11511 (invalid-infix-syntax re)
11512 (cont re
11513 tok
11514 (reverse args))))))))
11516 (define (read-list re maybe-tok start-pos cont)
11517 (let loop ((re re) (maybe-tok maybe-tok) (first? #t) (cont cont))
11518 (let ((tok (get-token re maybe-tok)))
11519 (cond ((expression-starter? re tok)
11520 (read-expression
11521 re
11522 tok
11523 max-precedence
11524 'no-comma-and-no-bar
11525 (lambda (re maybe-tok expr1)
11526 (let ((tok (get-token re maybe-tok)))
11527 (cond ((eq? tok |op.,|)
11528 (loop re
11529 #f
11530 #f
11531 (lambda (re maybe-tok expr2)
11532 (cont re
11533 maybe-tok
11534 (##wrap-op2 re
11535 start-pos
11536 'six.list
11537 expr1
11538 expr2)))))
11539 ((eq? tok |op.\||)
11540 (read-expression
11541 re
11542 #f
11543 max-precedence
11544 #f
11545 (lambda (re maybe-tok expr2)
11546 (cont re
11547 (expect re maybe-tok |token.]|)
11548 (##wrap-op2 re
11549 start-pos
11550 'six.cons
11551 expr1
11552 expr2)))))
11553 (else
11554 (cont re
11555 (expect re tok |token.]|)
11556 (##wrap-op2 re
11557 start-pos
11558 'six.list
11559 expr1
11560 (##wrap-op0 re
11561 start-pos
11562 'six.null)))))))))
11563 (else
11564 (cont re
11565 (expect re tok |token.]|)
11566 (##wrap-op0 re
11567 start-pos
11568 'six.null)))))))
11570 (define (expression-starter? re tok)
11571 ;; this function must be kept in sync with "read-expression"
11572 (or (eq? tok op.*)
11573 (eq? tok op.+)
11574 (eq? tok op.-)
11575 (eq? tok op.&)
11576 (level2-starter? re tok)))
11578 (define (level2-starter? re tok)
11579 (or (eq? tok op.!)
11580 (eq? tok op.++)
11581 (eq? tok op.--)
11582 (eq? tok op.~)
11583 (primary-starter? re tok)))
11585 (define (primary-starter? re tok)
11586 (or (eq? tok |token.(|)
11587 (eq? tok |token.[|)
11588 (eq? tok |token.\\|)
11589 (eq? tok |token.`|)
11590 (eq? tok |token.#|)
11591 (symbol? tok)
11592 (string? tok)
11593 (char? tok)
11594 (complex? tok)
11595 (pair? tok)
11596 (six-type? re tok)))
11598 (define (read-expression re maybe-tok level restriction cont)
11599 (let* ((tok
11600 (get-token re maybe-tok))
11601 (start-pos
11602 (macro-readenv-filepos re)))
11603 (cond ((and (= level 2)
11604 (op? tok)
11605 (unary-prefix? tok))
11606 =>
11607 (lambda (scheme-name)
11608 (let ((tok2 (get-token re #f)))
11609 (if (and (eq? tok |op.!|)
11610 (not (level2-starter? re tok2)))
11611 (cont re
11612 tok2
11613 (##wrap-op0 re
11614 start-pos
11615 'six.!))
11616 (read-expression
11617 re
11618 tok2
11619 2
11620 restriction
11621 (lambda (re maybe-tok expr)
11622 (cont re
11623 maybe-tok
11624 (##wrap-op1 re
11625 start-pos
11626 scheme-name
11627 expr))))))))
11628 ((and (= level 2)
11629 (eq? tok 'new))
11630 (read-identifier-or-prefix
11631 re
11632 #f
11633 #t
11634 (lambda (re maybe-tok identifier)
11635 (read-arguments-tail
11636 re
11637 (expect re #f |token.(|)
11638 (lambda (re maybe-tok args)
11639 (cont re
11640 maybe-tok
11641 (##wrap-op re
11642 start-pos
11643 'six.new
11644 (cons identifier
11645 args))))))))
11646 ((< 0 level)
11647 (read-expression
11648 re
11649 tok
11650 (- level 1)
11651 restriction
11652 (lambda (re maybe-tok expr1)
11653 (let ((tok (get-token re maybe-tok)))
11654 (cond ((= level 1)
11655 (let loop ((re re)
11656 (last-tok tok)
11657 (last-expr1 expr1))
11658 (cond ((and (op? last-tok)
11659 (unary-postfix? last-tok))
11660 =>
11661 (lambda (scheme-name)
11662 (loop re
11663 (get-token re #f)
11664 (##wrap-op1 re
11665 start-pos
11666 scheme-name
11667 last-expr1))))
11668 ((eq? last-tok |token.(|)
11669 (read-arguments-tail
11670 re
11671 #f
11672 (lambda (re maybe-tok args)
11673 (loop re
11674 (get-token re maybe-tok)
11675 (##wrap-op re
11676 start-pos
11677 'six.call
11678 (cons last-expr1
11679 args))))))
11680 ((eq? last-tok |token.[|)
11681 (read-expression
11682 re
11683 #f
11684 max-precedence
11685 #f
11686 (lambda (re maybe-tok expr2)
11687 (loop re
11688 (get-token
11689 re
11690 (expect re maybe-tok |token.]|))
11691 (##wrap-op2 re
11692 start-pos
11693 'six.index
11694 last-expr1
11695 expr2)))))
11696 ((or (eq? last-tok |token.->|)
11697 (eq? last-tok |token..|))
11698 (let ((next
11699 (macro-peek-next-char-or-eof re)))
11700 (if (or (not (eq? last-tok |token..|))
11701 (and (char? next)
11702 (or (identifier-starter? next)
11703 (char=? next #\\))))
11704 (read-expression
11705 re
11706 (parse-token-starting-with re next)
11707 (- level 1)
11708 restriction
11709 (lambda (re maybe-tok expr2)
11710 (loop re
11711 (get-token re maybe-tok)
11712 (##wrap-op2 re
11713 start-pos
11714 (if (eq? last-tok
11715 |token.->|)
11716 'six.arrow;;;;;;;;;;;;;;;
11717 'six.dot)
11718 last-expr1
11719 expr2))))
11720 (cont re
11721 last-tok
11722 last-expr1))))
11723 (else
11724 (cont re
11725 last-tok
11726 last-expr1)))))
11727 ((and (op? tok)
11728 (= level (precedence tok))
11729 (not
11730 (cond ((eq? restriction 'no-comma)
11731 (eq? tok |op.,|))
11732 ((eq? restriction 'no-comma-and-no-bar)
11733 (or (eq? tok |op.,|) (eq? tok |op.\||)))
11734 ((eq? restriction 'no-colon)
11735 (eq? tok |op.:|))
11736 (else
11737 #f)))
11738 (binary-or-ternary? tok))
11739 =>
11740 (lambda (scheme-name)
11741 (cond ((ternary? tok)
11742 =>
11743 (lambda (end-tok)
11744 (read-expression
11745 re
11746 #f
11747 max-precedence
11748 'no-colon ;; assumes that end-tok = |op.:|
11749 (lambda (re maybe-tok expr2)
11750 (read-expression
11751 re
11752 (expect re maybe-tok end-tok)
11753 level
11754 restriction
11755 (lambda (re maybe-tok expr3)
11756 (cont re
11757 maybe-tok
11758 (##wrap-op3 re
11759 start-pos
11760 scheme-name
11761 expr1
11762 expr2
11763 expr3))))))))
11764 ((left-to-right? tok)
11765 (let loop ((re re)
11766 (last-scheme-name scheme-name)
11767 (last-expr1 expr1))
11768 (read-expression
11769 re
11770 #f
11771 (- level 1)
11772 restriction
11773 (lambda (re maybe-tok expr2)
11774 (let ((expr1
11775 (##wrap-op2 re
11776 start-pos
11777 last-scheme-name
11778 last-expr1
11779 expr2)))
11780 (let ((tok (get-token re maybe-tok)))
11781 (cond ((and (op? tok)
11782 (= level
11783 (precedence tok))
11784 (binary-or-ternary?
11785 tok))
11786 =>
11787 (lambda (scheme-name)
11788 (loop re
11789 scheme-name
11790 expr1)))
11791 (else
11792 (cont re
11793 tok
11794 expr1)))))))))
11795 (else
11796 (read-expression
11797 re
11798 #f
11799 level
11800 restriction
11801 (lambda (re maybe-tok expr2)
11802 (cont re
11803 maybe-tok
11804 (##wrap-op2 re
11805 start-pos
11806 scheme-name
11807 expr1
11808 expr2))))))))
11809 (else
11810 (cont re
11811 tok
11812 expr1)))))))
11813 ((six-type? re tok)
11814 (let ((type (macro-readenv-wrap re tok)))
11815 (read-procedure
11816 re
11817 (expect re #f |token.(|)
11818 start-pos
11819 type
11820 cont)))
11821 ((pair? tok) ;; This special token represents two
11822 ;; consecutive tokens. This trick is used
11823 ;; because the parser needs a lookahead of 2
11824 ;; tokens to distinguish definitions from
11825 ;; anonymous procedures, and to distinguish
11826 ;; label definitions from expressions.
11827 (if (cdr tok)
11828 (let ((expr (car tok)))
11829 (cont re
11830 (cdr tok)
11831 expr))
11832 (let ((type (car tok)))
11833 (read-procedure
11834 re
11835 #f
11836 start-pos
11837 type
11838 cont))))
11839 ((or (string? tok)
11840 (char? tok)
11841 (complex? tok))
11842 (let ((literal (macro-readenv-wrap re tok)))
11843 (cont re
11844 #f
11845 (##wrap-op1 re
11846 start-pos
11847 'six.literal
11848 literal))))
11849 ((eq? tok |token.(|)
11850 (let ((tok (get-token re #f)))
11852 (define (check-closing re maybe-tok x)
11853 (cont re
11854 (expect re maybe-tok |token.)|)
11855 x))
11857 (if (eq? tok |token.{|)
11858 (let ((start-pos (macro-readenv-filepos re)))
11859 (read-compound-statement
11860 re
11861 #f
11862 start-pos
11863 'six.compound
11864 check-closing))
11865 (read-expression
11866 re
11867 tok
11868 max-precedence
11869 #f
11870 check-closing))))
11871 ((eq? tok |token.[|)
11872 (read-list
11873 re
11874 #f
11875 start-pos
11876 cont))
11877 ((eq? tok |token.`|)
11878 (read-quasiquotation
11879 re
11880 start-pos
11881 cont))
11882 ((eq? tok |token.#|);;;;;;;;;;;;;;;;;;;;;
11883 (read-sharp
11884 re
11885 start-pos
11886 cont))
11887 (else
11888 (read-identifier-or-prefix
11889 re
11890 tok
11891 #f
11892 cont)))))
11894 (define (read-paren-expression re maybe-tok cont)
11895 (let ((tok
11896 (get-token re (expect re maybe-tok |token.(|))))
11898 (define (check-closing re maybe-tok x)
11899 (cont re
11900 (expect re maybe-tok |token.)|)
11901 x))
11903 (let ((start-pos (macro-readenv-filepos re)))
11904 (if (six-type? re tok)
11905 (read-definition-or-expression-or-clause
11906 re
11907 tok
11908 start-pos
11909 #f
11910 #f
11911 check-closing)
11912 (read-expression-or-clause
11913 re
11914 tok
11915 start-pos
11916 #f
11917 #f
11918 check-closing)))))
11920 (define (read-expression-or-clause
11921 re
11922 maybe-tok
11923 start-pos
11924 restriction
11925 terminated?
11926 cont)
11927 (read-expression
11928 re
11929 maybe-tok
11930 max-precedence
11931 restriction
11932 (if terminated?
11933 (lambda (re maybe-tok expr)
11934 (let ((tok
11935 (get-token re maybe-tok)))
11936 (if (eq? tok |token..|)
11937 (cont re
11938 #f
11939 (##wrap-op1 re
11940 start-pos
11941 'six.clause
11942 expr))
11943 (cont re
11944 (expect re tok |token.;|)
11945 expr))))
11946 cont)))
11948 (define (read-definition-or-expression-or-clause
11949 re
11950 tok
11951 start-pos
11952 restriction
11953 terminated?
11954 cont)
11955 (let* ((type
11956 (macro-readenv-wrap re tok))
11957 (tok
11958 (get-token re #f)))
11959 (if (eq? tok |token.(|)
11960 (read-expression-or-clause
11961 re
11962 (cons type #f) ;; special combined token
11963 start-pos
11964 restriction
11965 terminated?
11966 cont)
11967 (read-identifier-or-prefix
11968 re
11969 tok
11970 #f
11971 (lambda (re maybe-tok identifier)
11972 (read-definition
11973 re
11974 #f
11975 terminated?
11976 start-pos
11977 type
11978 identifier
11979 cont))))))
11981 (define (read-identifier-or-prefix re maybe-tok accept-type? cont)
11982 (let* ((tok (get-token re maybe-tok))
11983 (start-pos (macro-readenv-filepos re)))
11984 (cond ((eq? tok |token.\\|)
11985 (read-prefix
11986 re
11987 start-pos
11988 cont))
11989 ((or (not (symbol? tok))
11990 (and (not accept-type?)
11991 (six-type? re tok)))
11992 (invalid-infix-syntax re)
11993 (cont re
11994 tok
11995 (##wrap-op1* re
11996 start-pos
11997 'six.prefix
11998 'error)))
11999 (else
12000 (let ((identifier (macro-readenv-wrap re tok)))
12001 (cont re
12002 #f
12003 (##wrap-op1 re
12004 start-pos
12005 'six.identifier
12006 identifier)))))))
12008 (define (read-prefix re start-pos cont)
12009 (let ((expr (##read-datum-or-label re)))
12010 (let* ((obj2
12011 (cons expr
12012 '()))
12013 (obj1
12014 (##wrap-op re
12015 start-pos
12016 'six.prefix
12017 obj2)))
12018 (if (##label-marker? expr)
12019 (##label-marker-fixup-handler-add!
12020 re
12021 expr
12022 (lambda (resolved-obj)
12023 (set-car! obj2 resolved-obj))))
12024 (cont re
12025 #f
12026 obj1))))
12028 (define (read-quasiquotation re start-pos cont)
12029 (cont re
12030 #f
12031 (##wrap-op1 re
12032 start-pos
12033 'six.prefix
12034 (##build-read-macro
12035 re
12036 start-pos
12037 start-pos
12038 (macro-readtable-quasiquote-keyword
12039 (macro-readenv-readtable re))))))
12041 (define (read-sharp re start-pos cont)
12042 (let ((x (##read-sharp-aux re start-pos)))
12043 (cont re
12044 #f
12045 (##wrap-op1 re
12046 start-pos
12047 'six.prefix
12048 x))));;;;;;;;;;;;;;;;;;;;
12050 (define (statement-starter? re tok)
12051 ;; this function must be kept in sync with "read-statement"
12052 (or (eq? tok |token.{|)
12053 (eq? tok |token.;|)
12054 (six-type? re tok)
12055 (expression-starter? re tok)))
12057 (define (read-statement re maybe-tok cont)
12058 (let* ((tok
12059 (get-token re maybe-tok))
12060 (start-pos
12061 (macro-readenv-filepos re)))
12062 (cond ((eq? tok |token.{|)
12063 (read-compound-statement
12064 re
12065 #f
12066 start-pos
12067 'six.compound
12068 cont))
12069 ((eq? tok 'if)
12070 (read-paren-expression
12071 re
12072 #f
12073 (lambda (re maybe-tok expr)
12074 (read-statement
12075 re
12076 maybe-tok
12077 (lambda (re maybe-tok stat1)
12078 (let ((tok
12079 (get-token re maybe-tok)))
12080 (if (eq? tok 'else)
12081 (read-statement
12082 re
12083 #f
12084 (lambda (re maybe-tok stat2)
12085 (cont re
12086 maybe-tok
12087 (##wrap-op3 re
12088 start-pos
12089 'six.if
12090 expr
12091 stat1
12092 stat2))))
12093 (cont re
12094 tok
12095 (##wrap-op2 re
12096 start-pos
12097 'six.if
12098 expr
12099 stat1)))))))))
12100 ((eq? tok 'while)
12101 (read-paren-expression
12102 re
12103 #f
12104 (lambda (re maybe-tok expr)
12105 (read-statement
12106 re
12107 maybe-tok
12108 (lambda (re maybe-tok stat)
12109 (cont re
12110 maybe-tok
12111 (##wrap-op2 re
12112 start-pos
12113 'six.while
12114 expr
12115 stat)))))))
12116 ((eq? tok 'do)
12117 (read-statement
12118 re
12119 #f
12120 (lambda (re maybe-tok stat)
12121 (read-paren-expression
12122 re
12123 (expect re maybe-tok 'while)
12124 (lambda (re maybe-tok expr)
12125 (cont re
12126 (expect re maybe-tok |token.;|)
12127 (##wrap-op2 re
12128 start-pos
12129 'six.do-while
12130 stat
12131 expr)))))))
12132 ((eq? tok 'for)
12133 (let ()
12135 (define (get-stat1 re maybe-tok)
12136 (read-statement
12137 re
12138 (expect re maybe-tok |token.(|)
12139 (lambda (re maybe-tok stat1)
12140 (get-expr2 re
12141 maybe-tok
12142 stat1))))
12144 (define (get-expr2 re maybe-tok stat1)
12145 (let ((tok
12146 (get-token re maybe-tok)))
12147 (if (expression-starter? re tok)
12148 (read-expression
12149 re
12150 tok
12151 max-precedence
12152 #f
12153 (lambda (re maybe-tok expr2)
12154 (get-expr3 re
12155 maybe-tok
12156 stat1
12157 expr2)))
12158 (get-expr3 re
12159 tok
12160 stat1
12161 (##wrap re start-pos #f)))))
12163 (define (get-expr3 re maybe-tok stat1 expr2)
12164 (let ((tok
12165 (get-token re (expect re maybe-tok |token.;|))))
12166 (if (expression-starter? re tok)
12167 (read-expression
12168 re
12169 tok
12170 max-precedence
12171 #f
12172 (lambda (re maybe-tok expr3)
12173 (get-body re
12174 maybe-tok
12175 stat1
12176 expr2
12177 expr3)))
12178 (get-body re
12179 tok
12180 stat1
12181 expr2
12182 (##wrap re start-pos #f)))))
12184 (define (get-body re maybe-tok stat1 expr2 expr3)
12185 (read-statement
12186 re
12187 (expect re maybe-tok |token.)|)
12188 (lambda (re maybe-tok stat)
12189 (cont re
12190 maybe-tok
12191 (##wrap-op4 re
12192 start-pos
12193 'six.for
12194 stat1
12195 expr2
12196 expr3
12197 stat)))))
12199 (get-stat1 re
12200 #f)))
12201 ((eq? tok 'switch)
12202 (read-paren-expression
12203 re
12204 #f
12205 (lambda (re maybe-tok expr)
12206 (read-statement
12207 re
12208 maybe-tok
12209 (lambda (re maybe-tok stat)
12210 (cont re
12211 maybe-tok
12212 (##wrap-op2 re
12213 start-pos
12214 'six.switch
12215 expr
12216 stat)))))))
12217 ((eq? tok 'break)
12218 (cont re
12219 (expect re #f |token.;|)
12220 (##wrap-op0 re
12221 start-pos
12222 'six.break)))
12223 ((eq? tok 'continue)
12224 (cont re
12225 (expect re #f |token.;|)
12226 (##wrap-op0 re
12227 start-pos
12228 'six.continue)))
12229 ((eq? tok 'return)
12230 (let ((tok
12231 (get-token re #f)))
12232 (if (expression-starter? re tok)
12233 (read-expression
12234 re
12235 tok
12236 max-precedence
12237 #f
12238 (lambda (re maybe-tok expr)
12239 (cont re
12240 (expect re maybe-tok |token.;|)
12241 (##wrap-op1 re
12242 start-pos
12243 'six.return
12244 expr))))
12245 (cont re
12246 (expect re tok |token.;|)
12247 (##wrap-op0 re
12248 start-pos
12249 'six.return)))))
12250 ((eq? tok 'goto)
12251 (read-expression
12252 re
12253 #f
12254 max-precedence
12255 #f
12256 (lambda (re maybe-tok expr)
12257 (cont re
12258 (expect re maybe-tok |token.;|)
12259 (##wrap-op1 re
12260 start-pos
12261 'six.goto
12262 expr)))))
12263 ((eq? tok 'case)
12264 (read-expression
12265 re
12266 #f
12267 max-precedence
12268 'no-colon
12269 (lambda (re maybe-tok expr)
12270 (read-statement
12271 re
12272 (expect re maybe-tok |op.:|)
12273 (lambda (re maybe-tok stat)
12274 (cont re
12275 maybe-tok
12276 (##wrap-op2 re
12277 start-pos
12278 'six.case
12279 expr
12280 stat)))))))
12281 ((eq? tok |token.;|)
12282 (cont re
12283 #f
12284 (##wrap-op0 re
12285 start-pos
12286 'six.compound)))
12287 ((six-type? re tok)
12288 (read-definition-or-expression-or-clause
12289 re
12290 tok
12291 start-pos
12292 'no-colon
12293 #t
12294 cont))
12295 ((and (symbol? tok)
12296 (not (eq? tok 'new)))
12297 (let* ((identifier
12298 (macro-readenv-wrap re tok))
12299 (tok
12300 (get-token re #f)))
12301 (if (eq? tok |op.:|)
12302 (read-statement
12303 re
12304 #f
12305 (lambda (re maybe-tok stat)
12306 (cont re
12307 maybe-tok
12308 (##wrap-op2 re
12309 start-pos
12310 'six.label
12311 identifier
12312 stat))))
12313 (read-expression-or-clause
12314 re
12315 (cons ;; special combined token
12316 (##wrap-op1 re
12317 start-pos
12318 'six.identifier
12319 identifier)
12320 tok)
12321 start-pos
12322 'no-colon
12323 #t
12324 cont))))
12325 (else
12326 (read-expression-or-clause
12327 re
12328 tok
12329 start-pos
12330 'no-colon
12331 #t
12332 cont)))))
12334 (define (read-definition re maybe-tok terminated? start-pos type identifier cont)
12336 (define (get-dimensions re maybe-tok rev-dims)
12337 (let ((tok (get-token re maybe-tok)))
12338 (cond ((eq? tok |token.[|)
12339 (read-expression
12340 re
12341 #f
12342 max-precedence
12343 #f
12344 (lambda (re maybe-tok dim)
12345 (get-dimensions re
12346 (expect re maybe-tok |token.]|)
12347 (cons dim rev-dims)))))
12348 ((eq? tok op.=)
12349 (read-expression
12350 re
12351 #f
12352 max-precedence
12353 #f
12354 (lambda (re maybe-tok init)
12355 (get-tail re
12356 maybe-tok
12357 rev-dims
12358 init))))
12359 (else
12360 (get-tail re
12361 tok
12362 rev-dims
12363 (##wrap re start-pos #f))))))
12365 (define (get-tail re maybe-tok rev-dims init)
12366 (cont re
12367 (if terminated?
12368 (expect re maybe-tok |token.;|)
12369 maybe-tok)
12370 (##wrap-op4 re
12371 start-pos
12372 'six.define-variable
12373 identifier
12374 type
12375 (##wrap re start-pos (reverse rev-dims))
12376 init)))
12378 (let ((tok (get-token re maybe-tok)))
12379 (if (eq? tok |token.(|)
12380 (read-procedure
12381 re
12382 #f
12383 start-pos
12384 type
12385 (lambda (re maybe-tok proc)
12386 (cont re
12387 maybe-tok
12388 (##wrap-op2 re
12389 start-pos
12390 'six.define-procedure
12391 identifier
12392 proc))))
12393 (get-dimensions re
12394 tok
12395 '()))))
12397 (define (read-procedure re maybe-tok start-pos type cont)
12398 (let* ((tok
12399 (get-token re maybe-tok))
12400 (params-start-pos
12401 (macro-readenv-filepos re)))
12403 (define (get-body re maybe-tok rev-params)
12404 (read-compound-statement
12405 re
12406 (expect re maybe-tok |token.{|)
12407 start-pos
12408 'six.procedure-body
12409 (lambda (re maybe-tok stat)
12410 (cont re
12411 maybe-tok
12412 (##wrap-op3 re
12413 start-pos
12414 'six.procedure
12415 type
12416 (##wrap re params-start-pos (reverse rev-params))
12417 stat)))))
12419 (define (err re tok rev-params)
12420 (invalid-infix-syntax re)
12421 (get-body re
12422 (if (eq? tok |token.)|)
12423 #f
12424 tok)
12425 rev-params))
12427 (if (not (six-type? re tok))
12428 (get-body re
12429 (expect re tok |token.)|)
12430 '())
12431 (let loop ((tok tok) (rev-params '()))
12432 (if (not (six-type? re tok))
12433 (err re tok rev-params)
12434 (let* ((type
12435 (macro-readenv-wrap re tok))
12436 (tok
12437 (get-token re #f)))
12438 (read-identifier-or-prefix
12439 re
12440 tok
12441 #f
12442 (lambda (re maybe-tok identifier)
12443 (let* ((new-rev-params
12444 (cons (macro-readenv-wrap re (list identifier type))
12445 rev-params))
12446 (tok
12447 (get-token re maybe-tok)))
12448 (if (eq? tok |op.,|)
12449 (loop (get-token re #f)
12450 new-rev-params)
12451 (get-body re
12452 (expect re tok |token.)|)
12453 new-rev-params)))))))))))
12455 (define (read-compound-statement re maybe-tok start-pos kind cont)
12456 (read-statements-tail
12457 re
12458 maybe-tok
12459 start-pos
12460 '()
12461 (lambda (re maybe-tok stats)
12462 (cont re
12463 maybe-tok
12464 (##wrap-op re
12465 start-pos
12466 kind
12467 stats)))))
12469 (define (read-statements-tail re maybe-tok start-pos rev-stats cont)
12470 (let ((tok (get-token re maybe-tok)))
12471 (if (statement-starter? re tok)
12472 (read-statement
12473 re
12474 tok
12475 (lambda (re maybe-tok stat)
12476 (read-statements-tail
12477 re
12478 maybe-tok
12479 start-pos
12480 (cons stat rev-stats)
12481 cont)))
12482 (cont re
12483 (expect re tok |token.}|)
12484 (reverse rev-stats)))))
12486 (define (invalid-infix-syntax re)
12487 (##raise-datum-parsing-exception
12488 'invalid-infix-syntax
12489 re))
12491 (define (invalid-infix-syntax-character re)
12492 (##raise-datum-parsing-exception
12493 'invalid-infix-syntax-character
12494 re))
12496 (define (invalid-infix-syntax-number re)
12497 (##raise-datum-parsing-exception
12498 'invalid-infix-syntax-number
12499 re))
12501 (define (six-type? re tok)
12502 ((macro-readtable-six-type? (macro-readenv-readtable re)) tok))
12504 (let ((tok
12505 (get-token re #f)))
12506 (cond ((and allow-eof?
12507 (eq? tok (##none-marker))
12508 (not (char? (macro-peek-next-char-or-eof re))))
12509 (macro-read-next-char-or-eof re) ;; make sure reader progresses
12510 #!eof) ;; end-of-file was reached so return end-of-file object
12511 ((eq? tok (##script-marker))
12512 tok)
12513 (else
12514 (read-statement
12515 re
12516 tok
12517 (lambda (re maybe-tok expr)
12518 expr))))))
12520 (define (##six-type? x)
12521 (assq x ##six-types))
12523 (define ##six-types '())
12524 (set! ##six-types
12525 '((int . #f)
12526 (char . #f)
12527 (bool . #f)
12528 (void . #f)
12529 (float . #f)
12530 (double . #f)
12531 (obj . #f)))
12533 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
12535 ;;; Setup the standard readtable.
12537 (define (##make-standard-readtable)
12538 (let ((rt
12539 (macro-make-readtable
12540 #f ;; preserve case in symbols, character names, etc
12541 #t ;; keywords ending with ":" are allowed
12542 ##standard-escaped-char-table
12543 ##standard-named-char-table
12544 ##standard-sharp-bang-table
12545 (##make-chartable #f) ;; all chars are non-delimiters
12546 (##make-chartable ##read-number/keyword/symbol)
12547 (##make-chartable ##read-sharp-other)
12548 (##fixnum.->char 127) ;; max-unescaped-char
12549 #t ;; escape-ctrl-chars?
12550 #f ;; sharing-allowed?
12551 #f ;; eval-allowed?
12552 #f ;; write-extended-read-macros?
12553 #f ;; write-cdr-read-macros?
12554 ##max-fixnum ;; max-write-level
12555 ##max-fixnum ;; max-write-length
12556 ##standard-pretty-print-formats
12557 'quote ;; quote-keyword
12558 'quasiquote ;; quasiquote-keyword
12559 'unquote ;; unquote-keyword
12560 'unquote-splicing ;; unquote-splicing-keyword
12561 'syntax ;; sharp-quote-keyword
12562 'quasisyntax ;; sharp-quasiquote-keyword
12563 'unsyntax ;; sharp-unquote-keyword
12564 'unsyntax-splicing ;; sharp-unquote-splicing-keyword
12565 'serial-number->object ;; sharp-num-keyword
12566 'repl-result-history-ref ;; sharp-seq-keyword
12567 #f ;; paren-keyword
12568 #f ;; bracket-keyword
12569 #f ;; brace-keyword
12570 #f ;; angle-keyword
12571 #f ;; start-syntax
12572 ##six-type? ;; six-type?
12573 #t ;; r6rs-compatible-read?
12574 #t ;; r6rs-compatible-write?
12575 'multiline ;; here-strings-allowed?
12576 )))
12578 (##readtable-setup-for-standard-level! rt)
12580 ;; setup control characters
12582 (let loop ((i 31))
12583 (if (not (< i 0))
12584 (begin
12585 (##readtable-char-class-set!
12586 rt
12587 (UCS-4->character i)
12588 #t
12589 ##read-illegal)
12590 (loop (- i 1)))))
12592 ;; setup whitespace characters
12594 (##readtable-char-class-set! rt #\space #t ##read-whitespace)
12595 (##readtable-char-class-set! rt #\linefeed #t ##read-whitespace)
12596 (##readtable-char-class-set! rt #\return #t ##read-whitespace)
12597 (##readtable-char-class-set! rt #\tab #t ##read-whitespace)
12598 (##readtable-char-class-set! rt #\page #t ##read-whitespace)
12600 ;; setup handlers for non-whitespace delimiters
12602 (##readtable-char-class-set! rt #\; #t ##read-single-line-comment)
12604 (##readtable-char-class-set! rt #\" #t ##read-escaped-string)
12605 (##readtable-char-class-set! rt #\| #t ##read-number/keyword/symbol)
12607 (##readtable-char-class-set! rt #\' #t ##read-quotation)
12608 (##readtable-char-class-set! rt #\` #t ##read-quotation)
12609 (##readtable-char-class-set! rt #\, #t ##read-quotation)
12611 (##readtable-char-class-set! rt #\( #t ##read-list)
12612 (##readtable-char-class-set! rt #\) #t ##read-none)
12614 (##readtable-char-class-set! rt #\[ #t ##read-vector-or-list)
12615 (##readtable-char-class-set! rt #\] #t ##read-none)
12617 (##readtable-char-class-set! rt #\{ #t ##read-other)
12618 (##readtable-char-class-set! rt #\} #t ##read-none)
12620 (##readtable-char-class-set! rt #\\ #t ##read-six)
12622 ;; setup handlers for "#" and "." (these are NOT delimiters)
12624 (##readtable-char-class-set! rt #\# #f ##read-sharp)
12625 (##readtable-char-class-set! rt #\. #f ##read-dot)
12627 ;; setup handlers for sharp read-macros
12629 (let loop ((i 57))
12630 (if (not (< i 48))
12631 (begin
12632 (##readtable-char-sharp-handler-set!
12633 rt
12634 (UCS-4->character i)
12635 ##read-sharp-digit)
12636 (loop (- i 1)))))
12638 (##readtable-char-sharp-handler-set! rt #\( ##read-sharp-vector)
12639 (##readtable-char-sharp-handler-set! rt #\\ ##read-sharp-char)
12640 (##readtable-char-sharp-handler-set! rt #\| ##read-sharp-comment)
12641 (##readtable-char-sharp-handler-set! rt #\! ##read-sharp-bang)
12642 (##readtable-char-sharp-handler-set! rt #\# ##read-sharp-keyword/symbol)
12643 (##readtable-char-sharp-handler-set! rt #\% ##read-sharp-keyword/symbol)
12644 (##readtable-char-sharp-handler-set! rt #\: ##read-sharp-colon)
12645 (##readtable-char-sharp-handler-set! rt #\; ##read-sharp-semicolon)
12646 (##readtable-char-sharp-handler-set! rt #\' ##read-sharp-quotation)
12647 (##readtable-char-sharp-handler-set! rt #\` ##read-sharp-quotation)
12648 (##readtable-char-sharp-handler-set! rt #\, ##read-sharp-quotation)
12649 (##readtable-char-sharp-handler-set! rt #\& ##read-sharp-ampersand)
12650 (##readtable-char-sharp-handler-set! rt #\. ##read-sharp-dot)
12651 (##readtable-char-sharp-handler-set! rt #\< ##read-sharp-less)
12653 rt))
12655 (if (not ##main-readtable)
12656 (set! ##main-readtable
12657 (##make-standard-readtable)))
12659 ;;;----------------------------------------------------------------------------
12661 ;;; Setup readtable according to program's script line.
12663 (let* ((program-script-line
12664 (##vector-ref ##program-descr 2))
12665 (language-and-tail
12666 (##extract-language-and-tail program-script-line)))
12667 (if language-and-tail
12668 (let ((language (##car language-and-tail)))
12669 (##readtable-setup-for-language! ##main-readtable language)
12670 (##main-set! (##start-main language)))))
12672 ;;;============================================================================