mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +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

131
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) (let ((ch (peek)))
(put first) (if (or (eof-object? ch) (pred ch))
(let lp () (reverse-list->string out)
(let ((ch (peek))) (begin
(unless (or (eof-object? ch) (pred ch)) (next)
(put ch) (lp (cons ch out)))))))
(next)
(lp)))))))
(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 ((ch (next)))
(let lp () (cond
(let ((ch (next))) ((eof-object? ch)
(unless (eqv? ch rdelim) (error "unexpected end of input while reading string"))
(cond ((eqv? ch rdelim)
((eof-object? ch) (reverse-list->string out))
(error "unexpected end of input while reading string")) ((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")) (cond
(case ch ((eqv? ch #\newline)
((#\newline) (when (hungry-eol-escapes?)
(when (hungry-eol-escapes?) ;; Skip intraline whitespace before continuing.
;; Skip intraline whitespace before continuing. (let skip ()
(let lp () (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) (skip)))))
(lp)))))) (lp out))
;; Accept "\(" for use at the beginning of ((eqv? ch rdelim)
;; lines in multiline strings to avoid (lp (cons rdelim out)))
;; confusing emacs lisp modes. (else
((#\| #\\ #\() (put ch)) (lp
((#\0) (put #\nul)) (cons
((#\f) (put #\ff)) (case ch
((#\n) (put #\newline)) ;; Accept "\(" for use at the beginning of
((#\r) (put #\return)) ;; lines in multiline strings to avoid
((#\t) (put #\tab)) ;; confusing emacs lisp modes.
((#\a) (put #\alarm)) ((#\| #\\ #\() ch)
((#\v) (put #\vtab)) ((#\0) #\nul)
((#\b) (put #\backspace)) ((#\f) #\ff)
((#\x) ((#\n) #\newline)
(let ((ch (if (or (r6rs-escapes?) (eqv? rdelim #\|)) ((#\r) #\return)
(read-r6rs-hex-escape) ((#\t) #\tab)
(read-fixed-hex-escape 2)))) ((#\a) #\alarm)
(put ch))) ((#\v) #\vtab)
((#\u) ((#\b) #\backspace)
(put (read-fixed-hex-escape 4))) ((#\x)
((#\U) (if (or (r6rs-escapes?) (eqv? rdelim #\|))
(put (read-fixed-hex-escape 8))) (read-r6rs-hex-escape)
(else (read-fixed-hex-escape 2)))
(unless (eqv? ch rdelim) ((#\u)
(error "invalid character in escape sequence: ~S" ch)) (read-fixed-hex-escape 4))
(put ch))) ((#\U)
(lp))) (read-fixed-hex-escape 8))
(else (else
(put ch) (error "invalid character in escape sequence: ~S" ch)))
(lp))))))))) out))))))
(else
(lp (cons ch out)))))))
(define (read-character) (define (read-character)
(let ((ch (next))) (let ((ch (next)))