diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 38da49eb7..0bfda4f35 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -94,6 +94,7 @@ enum scm_port_buffer_field { SCM_PORT_BUFFER_FIELD_CUR, SCM_PORT_BUFFER_FIELD_END, SCM_PORT_BUFFER_FIELD_HAS_EOF_P, + SCM_PORT_BUFFER_FIELD_POSITION, SCM_PORT_BUFFER_FIELD_COUNT }; @@ -152,6 +153,39 @@ scm_port_buffer_set_has_eof_p (SCM buf, SCM has_eof_p) has_eof_p); } +/* The port position object is a pair that is referenced by the port. + To make things easier for Scheme port code, it is also referenced by + port buffers. */ +static inline SCM +scm_port_buffer_position (SCM buf) +{ + return SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_POSITION); +} + +static inline SCM +scm_port_position_line (SCM position) +{ + return scm_car (position); +} + +static inline void +scm_port_position_set_line (SCM position, SCM line) +{ + scm_set_car_x (position, line); +} + +static inline SCM +scm_port_position_column (SCM position) +{ + return scm_cdr (position); +} + +static inline void +scm_port_position_set_column (SCM position, SCM column) +{ + scm_set_cdr_x (position, column); +} + static inline size_t scm_port_buffer_size (SCM buf) { @@ -290,8 +324,7 @@ struct scm_t_port { /* Source location information. */ SCM file_name; - long line_number; - int column_number; + SCM position; /* Port buffers. */ SCM read_buf; @@ -325,14 +358,6 @@ struct scm_t_port #define SCM_FILENAME(x) (SCM_PORT (x)->file_name) #define SCM_SET_FILENAME(x, n) (SCM_PORT (x)->file_name = (n)) -#define SCM_LINUM(x) (SCM_PORT (x)->line_number) -#define SCM_COL(x) (SCM_PORT (x)->column_number) - -#define SCM_INCLINE(port) do {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} while (0) -#define SCM_ZEROCOL(port) do {SCM_COL (port) = 0;} while (0) -#define SCM_INCCOL(port) do {SCM_COL (port) += 1;} while (0) -#define SCM_DECCOL(port) do {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;} while (0) -#define SCM_TABCOL(port) do {SCM_COL (port) += 8 - SCM_COL (port) % 8;} while (0) SCM_INTERNAL scm_t_iconv_descriptors * scm_i_port_iconv_descriptors (SCM port); diff --git a/libguile/ports.c b/libguile/ports.c index ba3755507..445ccc076 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -494,13 +494,15 @@ scm_i_dynwind_current_load_port (SCM port) /* Port buffers. */ -SCM -scm_c_make_port_buffer (size_t size) +static SCM +make_port_buffer (SCM port, size_t size) { SCM ret = scm_c_make_vector (SCM_PORT_BUFFER_FIELD_COUNT, SCM_INUM0); SCM_SIMPLE_VECTOR_SET (ret, SCM_PORT_BUFFER_FIELD_BYTEVECTOR, scm_c_make_bytevector (size)); + SCM_SIMPLE_VECTOR_SET (ret, SCM_PORT_BUFFER_FIELD_POSITION, + SCM_PORT (port)->position); scm_port_buffer_set_has_eof_p (ret, SCM_BOOL_F); return ret; @@ -649,8 +651,8 @@ initialize_port_buffers (SCM port) write_buf_size = 1; pt->read_buffering = read_buf_size; - pt->read_buf = scm_c_make_port_buffer (read_buf_size); - pt->write_buf = scm_c_make_port_buffer (write_buf_size); + pt->read_buf = make_port_buffer (port, read_buf_size); + pt->write_buf = make_port_buffer (port, write_buf_size); } SCM @@ -672,6 +674,7 @@ scm_c_make_port_with_encoding (scm_t_port_type *ptob, unsigned long mode_bits, pt->conversion_strategy = conversion_strategy; pt->file_name = SCM_BOOL_F; pt->iconv_descriptors = NULL; + pt->position = scm_cons (SCM_INUM0, SCM_INUM0); pt->at_stream_start_for_bom_read = 1; pt->at_stream_start_for_bom_write = 1; @@ -1598,27 +1601,34 @@ scm_c_read (SCM port, void *buffer, size_t size) /* Update the line and column number of PORT after consumption of C. */ static inline void -update_port_lf (scm_t_wchar c, SCM port) +update_port_position (SCM port, scm_t_wchar c) { + SCM position = SCM_PORT (port)->position; + long line = scm_to_long (scm_port_position_line (position)); + int column = scm_to_int (scm_port_position_column (position)); + switch (c) { case '\a': case EOF: break; case '\b': - SCM_DECCOL (port); + if (column > 0) + scm_port_position_set_column (position, scm_from_int (column - 1)); break; case '\n': - SCM_INCLINE (port); + scm_port_position_set_line (position, scm_from_long (line + 1)); + scm_port_position_set_column (position, SCM_INUM0); break; case '\r': - SCM_ZEROCOL (port); + scm_port_position_set_column (position, SCM_INUM0); break; case '\t': - SCM_TABCOL (port); + scm_port_position_set_column (position, + scm_from_int (column + 8 - column % 8)); break; default: - SCM_INCCOL (port); + scm_port_position_set_column (position, scm_from_int (column + 1)); break; } } @@ -1898,7 +1908,7 @@ scm_getc (SCM port) scm_port_buffer_did_take (SCM_PORT (port)->read_buf, len); if (codepoint == EOF) scm_i_clear_pending_eof (port); - update_port_lf (codepoint, port); + update_port_position (port, codepoint); return codepoint; } @@ -2031,9 +2041,18 @@ scm_ungetc (scm_t_wchar c, SCM port) if (SCM_UNLIKELY (result != result_buf)) free (result); - if (c == '\n') - SCM_LINUM (port) -= 1; - SCM_DECCOL (port); + { + long line; + int column; + + line = scm_to_long (scm_port_position_line (pt->position)); + column = scm_to_int (scm_port_position_column (pt->position)); + + if (c == '\n') + scm_port_position_set_line (pt->position, scm_from_long (line - 1)); + if (column > 0) + scm_port_position_set_column (pt->position, scm_from_int (column - 1)); + } } #undef FUNC_NAME @@ -2216,8 +2235,8 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, SCM_SET_CELL_WORD_0 (port, tag_word); pt->read_buffering = read_buf_size; - pt->read_buf = scm_c_make_port_buffer (read_buf_size); - pt->write_buf = scm_c_make_port_buffer (write_buf_size); + pt->read_buf = make_port_buffer (port, read_buf_size); + pt->write_buf = make_port_buffer (port, write_buf_size); if (saved_read_buf) scm_unget_bytes (scm_port_buffer_take_pointer (saved_read_buf), @@ -2563,7 +2582,7 @@ SCM_DEFINE (scm_expand_port_read_buffer_x, "expand-port-read-buffer!", 2, 1, 0, if (SCM_UNBNDP (putback_p)) putback_p = SCM_BOOL_F; - new_buf = scm_c_make_port_buffer (c_size); + new_buf = make_port_buffer (port, c_size); scm_port_buffer_set_has_eof_p (new_buf, scm_port_buffer_has_eof_p (pt->read_buf)); if (scm_is_true (putback_p)) @@ -2780,7 +2799,7 @@ scm_c_write (SCM port, const void *ptr, size_t size) void scm_lfwrite (const char *ptr, size_t size, SCM port) { - int saved_line; + SCM position, saved_line; if (size == 0) return; @@ -2789,12 +2808,14 @@ scm_lfwrite (const char *ptr, size_t size, SCM port) scm_c_write (port, ptr, size); - saved_line = SCM_LINUM (port); + position = SCM_PORT (port)->position; + saved_line = scm_port_position_line (position); for (; size; ptr++, size--) - update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port); + update_port_position (port, (scm_t_wchar) (unsigned char) *ptr); /* Handle line buffering. */ - if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && saved_line != SCM_LINUM (port)) + if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && + !scm_is_eq (saved_line, scm_port_position_line (position))) scm_flush (port); } @@ -3046,7 +3067,7 @@ SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - return scm_from_long (SCM_LINUM (port)); + return scm_port_position_line (SCM_PORT (port)->position); } #undef FUNC_NAME @@ -3058,7 +3079,8 @@ SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - SCM_PORT (port)->line_number = scm_to_long (line); + scm_to_long (line); + scm_port_position_set_line (SCM_PORT (port)->position, line); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -3077,7 +3099,7 @@ SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - return scm_from_int (SCM_COL (port)); + return scm_port_position_column (SCM_PORT (port)->position); } #undef FUNC_NAME @@ -3089,7 +3111,8 @@ SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - SCM_PORT (port)->column_number = scm_to_int (column); + scm_to_int (column); + scm_port_position_set_column (SCM_PORT (port)->position, column); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/ports.h b/libguile/ports.h index 2905f68db..2ebcf0632 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -131,9 +131,6 @@ SCM_API void scm_dynwind_current_output_port (SCM port); SCM_API void scm_dynwind_current_error_port (SCM port); SCM_INTERNAL void scm_i_dynwind_current_load_port (SCM port); -/* Port buffers. */ -SCM_INTERNAL SCM scm_c_make_port_buffer (size_t size); - /* Mode bits. */ SCM_INTERNAL long scm_i_mode_bits (SCM modes); SCM_API long scm_mode_bits (char *modes); diff --git a/libguile/read.c b/libguile/read.c index 3d2a7fde9..afad5975a 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -149,8 +149,8 @@ scm_i_input_error (char const *function, scm_simple_format (string_port, scm_from_locale_string ("~A:~S:~S: ~A"), scm_list_4 (fn, - scm_from_long (SCM_LINUM (port) + 1), - scm_from_int (SCM_COL (port) + 1), + scm_sum (scm_port_line (port), SCM_INUM1), + scm_sum (scm_port_column (port), SCM_INUM1), scm_from_locale_string (message))); string = scm_get_output_string (string_port); @@ -434,8 +434,8 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) : ')')); /* Need to capture line and column numbers here. */ - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; c = flush_ws (port, opts, FUNC_NAME); if (terminating_char == c) @@ -612,8 +612,8 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) scm_t_wchar c, c_str[READER_STRING_BUFFER_SIZE]; /* Need to capture line and column numbers here. */ - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; while (chr != (c = scm_getc (port))) { @@ -739,8 +739,8 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) size_t bytes_read; /* Need to capture line and column numbers here. */ - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; scm_ungetc (chr, port); buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, @@ -759,7 +759,9 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) else if (SCM_NIMP (result)) result = maybe_annotate_source (result, port, opts, line, column); - SCM_COL (port) += scm_i_string_length (str); + scm_set_port_column_x (port, + scm_sum (scm_port_column (port), + scm_string_length (str))); return result; } @@ -796,7 +798,9 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) result = scm_string_to_symbol (str); } - SCM_COL (port) += scm_i_string_length (str); + scm_set_port_column_x (port, + scm_sum (scm_port_column (port), + scm_string_length (str))); return result; } @@ -845,7 +849,9 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) result = scm_string_to_number (str, scm_from_uint (radix)); - SCM_COL (port) += scm_i_string_length (str); + scm_set_port_column_x (port, + scm_sum (scm_port_column (port), + scm_string_length (str))); if (scm_is_true (result)) return result; @@ -860,8 +866,8 @@ static SCM scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) { SCM p; - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; switch (chr) { @@ -907,8 +913,8 @@ static SCM scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) { SCM p; - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; switch (chr) { @@ -1068,7 +1074,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) ((unsigned char) buffer[0] <= 127 || scm_is_eq (pt->encoding, sym_ISO_8859_1))) { - SCM_COL (port) += 1; + scm_set_port_column_x (port, scm_sum (scm_port_column (port), SCM_INUM1)); return SCM_MAKE_CHAR (buffer[0]); } @@ -1076,7 +1082,9 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) processing. */ charname = scm_from_port_stringn (buffer, bytes_read, port); charname_len = scm_i_string_length (charname); - SCM_COL (port) += charname_len; + scm_set_port_column_x (port, + scm_sum (scm_port_column (port), + scm_from_size_t (charname_len))); cp = scm_i_string_ref (charname, 0); if (charname_len == 1) return SCM_MAKE_CHAR (cp); @@ -1629,8 +1637,8 @@ scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts) proc = scm_get_hash_procedure (chr); if (scm_is_true (scm_procedure_p (proc))) { - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 2; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 2; SCM got; got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port); @@ -1782,8 +1790,8 @@ read_inner_expression (SCM port, scm_t_read_opts *opts) be part of an unescaped symbol. We might as well do something useful with it, so we adopt Kawa's convention: [...] => ($bracket-list$ ...) */ - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; return maybe_annotate_source (scm_cons (sym_bracket_list, scm_read_sexp (chr, port, opts)), port, opts, line, column); @@ -1805,8 +1813,8 @@ read_inner_expression (SCM port, scm_t_read_opts *opts) return (scm_read_quote (chr, port, opts)); case '#': { - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; SCM result = scm_read_sharp (chr, port, opts, line, column); if (scm_is_eq (result, SCM_UNSPECIFIED)) /* We read a comment or some such. */ @@ -1870,8 +1878,8 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) if (c == EOF) return SCM_EOF_VAL; scm_ungetc (c, port); - line = SCM_LINUM (port); - column = SCM_COL (port); + line = scm_to_long (scm_port_line (port)); + column = scm_to_int (scm_port_column (port)); } expr = read_inner_expression (port, opts); diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 4330ebedf..4b7462585 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -169,9 +169,14 @@ interpret its input and output." port-buffer-cur port-buffer-end port-buffer-has-eof? + port-buffer-position set-port-buffer-cur! set-port-buffer-end! set-port-buffer-has-eof?! + port-position-line + port-position-column + set-port-position-line! + set-port-position-column! port-read port-write port-clear-stream-start-for-bom-read @@ -188,6 +193,7 @@ interpret its input and output." (define-syntax-rule (port-buffer-cur buf) (vector-ref buf 1)) (define-syntax-rule (port-buffer-end buf) (vector-ref buf 2)) (define-syntax-rule (port-buffer-has-eof? buf) (vector-ref buf 3)) +(define-syntax-rule (port-buffer-position buf) (vector-ref buf 4)) (define-syntax-rule (set-port-buffer-cur! buf cur) (vector-set! buf 1 cur)) @@ -196,6 +202,15 @@ interpret its input and output." (define-syntax-rule (set-port-buffer-has-eof?! buf has-eof?) (vector-set! buf 3 has-eof?)) +(define-syntax-rule (port-position-line position) + (car position)) +(define-syntax-rule (port-position-column position) + (cdr position)) +(define-syntax-rule (set-port-position-line! position line) + (set-car! position line)) +(define-syntax-rule (set-port-position-column! position column) + (set-cdr! position column)) + (eval-when (expand) (define-syntax-rule (private-port-bindings binding ...) (begin diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index 265b70557..2ee97340b 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -384,34 +384,34 @@ (peek-bytes port 1 fast-path (lambda (buf bv cur buffered) (slow-path)))) -(define-inlinable (port-advance-position! port char) +(define-inlinable (advance-port-position! pos char) ;; FIXME: this cond is a speed hack; really we should just compile ;; `case' better. (cond ;; FIXME: char>? et al should compile well. ((<= (char->integer #\space) (char->integer char)) - (set-port-column! port (1+ (port-column port)))) + (set-port-position-column! pos (1+ (port-position-column pos)))) (else (case char ((#\alarm) #t) ; No change. ((#\backspace) - (let ((col (port-column port))) + (let ((col (port-position-column pos))) (when (> col 0) - (set-port-column! port (1- col))))) + (set-port-position-column! pos (1- col))))) ((#\newline) - (set-port-line! port (1+ (port-line port))) - (set-port-column! port 0)) + (set-port-position-line! pos (1+ (port-position-line pos))) + (set-port-position-column! pos 0)) ((#\return) - (set-port-column! port 0)) + (set-port-position-column! pos 0)) ((#\tab) - (let ((col (port-column port))) - (set-port-column! port (- (+ col 8) (remainder col 8))))) + (let ((col (port-position-column pos))) + (set-port-position-column! pos (- (+ col 8) (remainder col 8))))) (else - (set-port-column! port (1+ (port-column port)))))))) + (set-port-position-column! pos (1+ (port-position-column pos)))))))) (define* (read-char #:optional (port (current-input-port))) - (define (finish char) - (port-advance-position! port char) + (define (finish buf char) + (advance-port-position! (port-buffer-position buf) char) char) (define (slow-path) (call-with-values (lambda () (peek-char-and-len port)) @@ -422,7 +422,7 @@ (begin (set-port-buffer-has-eof?! buf #f) char) - (finish char)))))) + (finish buf char)))))) (define (fast-path buf bv cur buffered) (let ((u8 (bytevector-u8-ref bv cur)) (enc (%port-encoding port))) @@ -431,11 +431,11 @@ (decode-utf8 bv cur buffered u8 (lambda (char len) (set-port-buffer-cur! buf (+ cur len)) - (finish char)) + (finish buf char)) slow-path)) ((ISO-8859-1) (set-port-buffer-cur! buf (+ cur 1)) - (finish (integer->char u8))) + (finish buf (integer->char u8))) (else (slow-path))))) (peek-bytes port 1 fast-path (lambda (buf bv cur buffered) (slow-path)))) @@ -460,7 +460,7 @@ (let ((ch (integer->char (bytevector-u8-ref bv cur))) (cur (1+ cur))) (set-port-buffer-cur! buf cur) - (port-advance-position! port ch) + (advance-port-position! (port-buffer-position buf) ch) (call-with-values (lambda () (proc ch seed)) (lambda (seed done?) (if done? seed (fold-chars cur seed)))))))))))