mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 12:20:26 +02:00
Code Activity

Use lists instead of string ports to accumulate results

Browse source 
* module/ice-9/read.scm (read): Use lists, like read-delimited does.
  About 30% faster.
This commit is contained in:
Andy Wingo 2021-02-17 15:50:10 +01:00
parent 7244461a11
commit 064b394d5a
1 changed files with 61 additions and 70 deletions
Download patch file Download diff file Expand all files Collapse all files

79
module/ice-9/read.scm
View file

@ -134,15 +134,6 @@
(define (get-pos) (cons (port-line port) (port-column port))) (define (get-pos) (cons (port-line port) (port-column port)))
;; We are only ever interested in whether an object is a char or not. ;; We are only ever interested in whether an object is a char or not.
(define (eof-object? x) (not (char? x))) (define (eof-object? x) (not (char? x)))
(define accumulator (open-output-string))
(define-syntax-rule (accumulate proc)
(begin
(proc (lambda (ch) (write-char ch accumulator)))
(let ((str (get-output-string accumulator)))
(seek accumulator 0 SEEK_SET)
(truncate-file accumulator 0)
str)))
(define (annotate line column datum) (define (annotate line column datum)
;; FIXME: Return a syntax object instead, so we can avoid the ;; FIXME: Return a syntax object instead, so we can avoid the
;; srcprops side table. ;; srcprops side table.
@ -179,15 +170,13 @@
(else (read-semicolon-comment))))) (else (read-semicolon-comment)))))
(define-syntax-rule (take-until first pred) (define-syntax-rule (take-until first pred)
(accumulate (let lp ((out (list first)))
(lambda (put)
(put first)
(let lp ()
(let ((ch (peek))) (let ((ch (peek)))
(unless (or (eof-object? ch) (pred ch)) (if (or (eof-object? ch) (pred ch))
(put ch) (reverse-list->string out)
(begin
(next) (next)
(lp))))))) (lp (cons ch out)))))))
(define-syntax-rule (take-while first pred) (define-syntax-rule (take-while first pred)
(take-until first (lambda (ch) (not (pred ch))))) (take-until first (lambda (ch) (not (pred ch)))))
@ -305,58 +294,60 @@
(error "invalid character in escape sequence: ~S" ch))))))) (error "invalid character in escape sequence: ~S" ch)))))))
(define (read-string rdelim) (define (read-string rdelim)
(accumulate (let lp ((out '()))
(lambda (put)
(let lp ()
(let ((ch (next))) (let ((ch (next)))
(unless (eqv? ch rdelim)
(cond (cond
((eof-object? ch) ((eof-object? ch)
(error "unexpected end of input while reading string")) (error "unexpected end of input while reading string"))
((eqv? ch rdelim)
(reverse-list->string out))
((eqv? ch #\\) ((eqv? ch #\\)
(let ((ch (next))) (let ((ch (next)))
(when (eof-object? ch) (when (eof-object? ch)
(error "unexpected end of input while reading string")) (error "unexpected end of input while reading string"))
(case ch (cond
((#\newline) ((eqv? ch #\newline)
(when (hungry-eol-escapes?) (when (hungry-eol-escapes?)
;; Skip intraline whitespace before continuing. ;; Skip intraline whitespace before continuing.
(let lp () (let skip ()
(let ((ch (peek))) (let ((ch (peek)))
(when (and (not (eof-object? ch)) (when (and (not (eof-object? ch))
(or (eqv? ch #\tab) (or (eqv? ch #\tab)
(eq? (char-general-category ch) 'Zs))) (eq? (char-general-category ch) 'Zs)))
(next) (next)
(lp)))))) (skip)))))
(lp out))
((eqv? ch rdelim)
(lp (cons rdelim out)))
(else
(lp
(cons
(case ch
;; Accept "\(" for use at the beginning of ;; Accept "\(" for use at the beginning of
;; lines in multiline strings to avoid ;; lines in multiline strings to avoid
;; confusing emacs lisp modes. ;; confusing emacs lisp modes.
((#\| #\\ #\() (put ch)) ((#\| #\\ #\() ch)
((#\0) (put #\nul)) ((#\0) #\nul)
((#\f) (put #\ff)) ((#\f) #\ff)
((#\n) (put #\newline)) ((#\n) #\newline)
((#\r) (put #\return)) ((#\r) #\return)
((#\t) (put #\tab)) ((#\t) #\tab)
((#\a) (put #\alarm)) ((#\a) #\alarm)
((#\v) (put #\vtab)) ((#\v) #\vtab)
((#\b) (put #\backspace)) ((#\b) #\backspace)
((#\x) ((#\x)
(let ((ch (if (or (r6rs-escapes?) (eqv? rdelim #\|)) (if (or (r6rs-escapes?) (eqv? rdelim #\|))
(read-r6rs-hex-escape) (read-r6rs-hex-escape)
(read-fixed-hex-escape 2)))) (read-fixed-hex-escape 2)))
(put ch)))
((#\u) ((#\u)
(put (read-fixed-hex-escape 4))) (read-fixed-hex-escape 4))
((#\U) ((#\U)
(put (read-fixed-hex-escape 8))) (read-fixed-hex-escape 8))
(else (else
(unless (eqv? ch rdelim) (error "invalid character in escape sequence: ~S" ch)))
(error "invalid character in escape sequence: ~S" ch)) out))))))
(put ch)))
(lp)))
(else (else
(put ch) (lp (cons ch out)))))))
(lp)))))))))
(define (read-character) (define (read-character)
(let ((ch (next))) (let ((ch (next)))