~ chicken-core (chicken-5) 7401674892d10adb0259c3ea494af3b8e03b88a1
commit 7401674892d10adb0259c3ea494af3b8e03b88a1
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Fri Jun 23 15:28:30 2023 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Fri Jun 23 15:47:58 2023 +0200
Don't override ##sys#default-read-info-hook to read with source info
Overriding this hook with fluid-let to add line number tracking has a
few problems:
- Calling (read) in csi or on other repls would cause all forms to get
added to the line number database, even if just reading a data file.
Even though it's not a huge problem memory-wise due to the forms
being weakly held in the database, it could still be rather slow if
a lot of data is read due to the scanning of broken weak pointers.
- If you use (chicken repl) in a threaded program, all (read) calls
of the program would (unintentionally) use the line number db.
To fix this, change the code in csi as well as (load), (repl)
and (##sys#include-forms-from-file) to use ##sys#read/source-info
instead of scheme#read and fluid-letting ##sys#default-read-info-hook
to the line number tracking version.
NOTE: We could drop ##sys#default-read-info-hook entirely, but that
would break user code that uses it, like the r7rs egg, so keep it for
now.
diff --git a/core.scm b/core.scm
index 0d1a5c88..bf8ada8e 100644
--- a/core.scm
+++ b/core.scm
@@ -990,18 +990,17 @@
bs) ) ) ) )
((##core#include)
- (fluid-let ((##sys#default-read-info-hook ##sys#read/source-info-hook))
- (##sys#include-forms-from-file
- (cadr x)
- (caddr x)
- (lambda (forms)
- (walk (if (pair? (cdddr x)) ; body?
- (canonicalize-body/ln
- ln
- (append forms (cadddr x))
- compiler-syntax-enabled)
- `(##core#begin ,@forms))
- e dest ldest h ln tl?)))))
+ (##sys#include-forms-from-file
+ (cadr x)
+ (caddr x)
+ (lambda (forms)
+ (walk (if (pair? (cdddr x)) ; body?
+ (canonicalize-body/ln
+ ln
+ (append forms (cadddr x))
+ compiler-syntax-enabled)
+ `(##core#begin ,@forms))
+ e dest ldest h ln tl?))))
((##core#let-module-alias)
(##sys#with-module-aliases
diff --git a/csi.scm b/csi.scm
index e4a865d2..fca1da4e 100644
--- a/csi.scm
+++ b/csi.scm
@@ -280,7 +280,7 @@ EOF
(define default-evaluator
(let ((eval eval)
(load-noisily load-noisily)
- (read read)
+ (read (lambda () (##sys#read/source-info (current-input-port))))
(read-line read-line)
(display display)
(string-split string-split)
@@ -1047,7 +1047,7 @@ EOF
(load home-fn) ) ) ) )
(define (evalstring str #!optional (rec (lambda _ (void))))
(let ((in (open-input-string str)))
- (do ([x (read in) (read in)])
+ (do ([x (##sys#read/source-info in) (##sys#read/source-info in)])
((eof-object? x))
(rec (receive (eval x))) ) ) )
(when (member* '("-h" "-help" "--help") args)
@@ -1157,5 +1157,4 @@ EOF
(let ((r (optional rs)))
(exit (if (fixnum? r) r 0)))))))))))))
-(fluid-let ((##sys#default-read-info-hook ##sys#read/source-info-hook))
- (run)))
+(run))
diff --git a/eval.scm b/eval.scm
index 18f496ed..9a69e051 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1024,8 +1024,7 @@
(##sys#make-c-string (##sys#string-append "C_" (toplevel name)) loc))
(define load/internal
- (let ((read read)
- (write write)
+ (let ((write write)
(display display)
(newline newline)
(eval eval)
@@ -1089,8 +1088,8 @@
"unable to load compiled module - "
(or _dlerror "unknown reason"))
fname)))
- (let ((x1 (read in)))
- (do ((x x1 (read in)))
+ (let ((x1 (##sys#read/source-info in)))
+ (do ((x x1 (##sys#read/source-info in)))
((eof-object? x))
(when printer (printer x))
(##sys#call-with-values
@@ -1163,8 +1162,7 @@
(load-unit unit-name lib 'load-library))
(define ##sys#include-forms-from-file
- (let ((with-input-from-file with-input-from-file)
- (read read)
+ (let ((call-with-input-file call-with-input-file)
(reverse reverse))
(lambda (filename source k)
(let ((path (##sys#resolve-include-filename filename #t #f source)))
@@ -1172,10 +1170,10 @@
(##sys#signal-hook #:file-error 'include "cannot open file" filename))
(when (load-verbose)
(print "; including " path " ..."))
- (with-input-from-file path
- (lambda ()
+ (call-with-input-file path
+ (lambda (in)
(fluid-let ((##sys#current-source-filename path))
- (do ((x (read) (read))
+ (do ((x (##sys#read/source-info in) (##sys#read/source-info in))
(xs '() (cons x xs)))
((eof-object? x)
(k (reverse xs)))))))))))
diff --git a/expand.scm b/expand.scm
index adcb737d..b1c82113 100644
--- a/expand.scm
+++ b/expand.scm
@@ -732,7 +732,7 @@
(lp (cdr lst) prev))
(else (lp (cdr lst) lst)))))
-(define (##sys#read/source-info-hook class data val) ; Used here, in core.scm and in csi.scm
+(define (read/source-info-hook class data val)
(when (and (eq? 'list-info class) (symbol? (car data)))
(let ((old-value (or (hash-table-ref ##sys#line-number-database (car data)) '())))
(assq/drop-bwp! (car data) old-value) ;; Hack to clean out garbage values
@@ -744,9 +744,14 @@
old-value ) )) )
data)
+(define-constant line-number-database-size 997) ; Copied from core.scm
+
;; TODO: Should we export this, or something like it?
-(define (##sys#read/source-info in) ; Used only in batch-driver
- (##sys#read in ##sys#read/source-info-hook) )
+(define (##sys#read/source-info in)
+ ;; Initialize line number db on first use
+ (unless ##sys#line-number-database
+ (set! ##sys#line-number-database (make-vector line-number-database-size '())))
+ (##sys#read in read/source-info-hook) )
(define (get-line-number sexp)
diff --git a/repl.scm b/repl.scm
index 87f26cf0..523ddd34 100644
--- a/repl.scm
+++ b/repl.scm
@@ -40,8 +40,6 @@
(include "common-declarations.scm")
-(define-constant line-number-database-size 997) ; Copied from core.scm
-
(define ##sys#repl-print-length-limit #f)
(define ##sys#repl-read-hook #f)
(define ##sys#repl-recent-call-chain #f) ; used in csi for ,c command
@@ -71,7 +69,6 @@
(define repl
(let ((eval eval)
- (read read)
(call-with-current-continuation call-with-current-continuation)
(string-append string-append))
(lambda (#!optional (evaluator eval))
@@ -117,9 +114,6 @@
(set! quit-hook (lambda (result) (k result)))
(load-verbose #t)
(set! ##sys#notices-enabled #t)
- ;; Make sure line number db is initialized but don't clear it if (repl) is called again
- (unless ##sys#line-number-database
- (set! ##sys#line-number-database (make-vector line-number-database-size '())))
(##sys#error-handler
(lambda (msg . args)
(resetports)
@@ -156,40 +150,40 @@
(resetports)
(c #f)))))
(##sys#read-prompt-hook)
- (fluid-let ((##sys#default-read-info-hook ##sys#read/source-info-hook))
- (let ((exp ((or ##sys#repl-read-hook read))))
- (unless (eof-object? exp)
- (when (eq? #\newline (##sys#peek-char-0 ##sys#standard-input))
- (##sys#read-char-0 ##sys#standard-input))
- (foreign-code "C_clear_trace_buffer();")
- (set! ##sys#unbound-in-eval '())
- (receive result (evaluator exp)
- (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval))
- (let loop ((vars ##sys#unbound-in-eval)
- (u '()))
- (cond ((null? vars)
- (when (pair? u)
- (when ##sys#notices-enabled
- (##sys#notice
- "the following toplevel variables are referenced but unbound:\n")
- (for-each
- (lambda (v)
- (##sys#print " " #f ##sys#standard-error)
- (##sys#print (car v) #t ##sys#standard-error)
- (when (cdr v)
- (##sys#print " (in " #f ##sys#standard-error)
- (##sys#print (cdr v) #t ##sys#standard-error)
- (##sys#write-char-0 #\) ##sys#standard-error))
- (##sys#write-char-0 #\newline ##sys#standard-error))
- u)
- (##sys#flush-output ##sys#standard-error))))
- ((or (memq (caar vars) u)
- (##core#inline "C_u_i_namespaced_symbolp" (caar vars))
- (##sys#symbol-has-toplevel-binding? (caar vars)))
- (loop (cdr vars) u))
- (else (loop (cdr vars) (cons (car vars) u)))) 9))
- (write-results result)
- (loop)))))))
+ (let* ((read (lambda () (##sys#read/source-info ##sys#standard-input)))
+ (exp ((or ##sys#repl-read-hook read))))
+ (unless (eof-object? exp)
+ (when (eq? #\newline (##sys#peek-char-0 ##sys#standard-input))
+ (##sys#read-char-0 ##sys#standard-input))
+ (foreign-code "C_clear_trace_buffer();")
+ (set! ##sys#unbound-in-eval '())
+ (receive result (evaluator exp)
+ (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval))
+ (let loop ((vars ##sys#unbound-in-eval)
+ (u '()))
+ (cond ((null? vars)
+ (when (pair? u)
+ (when ##sys#notices-enabled
+ (##sys#notice
+ "the following toplevel variables are referenced but unbound:\n")
+ (for-each
+ (lambda (v)
+ (##sys#print " " #f ##sys#standard-error)
+ (##sys#print (car v) #t ##sys#standard-error)
+ (when (cdr v)
+ (##sys#print " (in " #f ##sys#standard-error)
+ (##sys#print (cdr v) #t ##sys#standard-error)
+ (##sys#write-char-0 #\) ##sys#standard-error))
+ (##sys#write-char-0 #\newline ##sys#standard-error))
+ u)
+ (##sys#flush-output ##sys#standard-error))))
+ ((or (memq (caar vars) u)
+ (##core#inline "C_u_i_namespaced_symbolp" (caar vars))
+ (##sys#symbol-has-toplevel-binding? (caar vars)))
+ (loop (cdr vars) u))
+ (else (loop (cdr vars) (cons (car vars) u)))) 9))
+ (write-results result)
+ (loop))))))
(lambda ()
(load-verbose lv)
(set! quit-hook qh)
Trap