~ chicken-core (chicken-5) 1330e7d252eac583d6c0bbabc4917a99a1437135
commit 1330e7d252eac583d6c0bbabc4917a99a1437135
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Tue Jun 20 15:14:53 2023 +0200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Tue Jun 20 15:14:53 2023 +0200
Move line number database accessors from support.scm to expand.scm
Because support.scm is only available inside the compiler, we can't
call its procedures in the interpreter. Since the line number
database variable itself is defined in expand.scm, it makes sense to
put the accessors there as well.
While moving, it became apparent that get-line from support.scm is
essentially the same as get-line-number from expand.scm, so use that
everywhere instead.
The other procedures are now prefixed with ##sys# because we don't
want to export them (yet?) from the user-visible chicken.syntax
module.
Rewrite display-line-number-database from printf to ##sys#print to
avoid adding a dependency on extras.scm / (chicken format) in
expand.scm.
It's still not 100% isolated - it would be better if the line number
database itself would purely be accessed through accessors, but it is
currently mutated directly in various places.
diff --git a/batch-driver.scm b/batch-driver.scm
index 0b3d7e02..ee7ae28a 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -27,7 +27,7 @@
(declare
(unit batch-driver)
- (uses extras data-structures pathname
+ (uses extras data-structures pathname expand
support compiler-syntax compiler optimizer internal
;; TODO: Backend should be configurable
scrutinizer lfa2 c-platform c-backend user-pass))
@@ -608,7 +608,7 @@
(in (check-and-open-input-file f)) )
(fluid-let ((##sys#current-source-filename f))
(let loop ()
- (let ((x (read/source-info in)))
+ (let ((x (##sys#read/source-info in)))
(cond ((eof-object? x)
(close-checked-input-file in f) )
(else
@@ -670,7 +670,7 @@
(when (debugging '|N| "real name table:")
(display-real-name-table) )
(when (debugging 'n "line number database:")
- (display-line-number-database) )
+ (##sys#display-line-number-database) )
(set! ##sys#line-number-database line-number-database-2)
(set! line-number-database-2 #f)
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index 81f9d2ca..b8afaff6 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -26,7 +26,7 @@
(declare
(unit compiler-syntax)
- (uses extras support compiler))
+ (uses expand extras support compiler))
(module chicken.compiler.compiler-syntax
(compiler-syntax-statistics)
@@ -36,7 +36,8 @@
chicken.compiler.support
chicken.compiler.core
chicken.fixnum
- chicken.format)
+ chicken.format
+ chicken.syntax)
(include "tweaks.scm")
(include "mini-srfi-1.scm")
@@ -197,7 +198,7 @@
(let ((fstr (if (string? (car args)) (car args) (cadar args)))
(args (cdr args)))
(define (fail ret? msg . args)
- (let ((ln (get-line x)))
+ (let ((ln (get-line-number x)))
(warning
(sprintf "~a`~a', in format string ~s, ~?"
(if ln (sprintf "(~a) " ln) "")
diff --git a/core.scm b/core.scm
index c63ef181..c5b48370 100644
--- a/core.scm
+++ b/core.scm
@@ -287,7 +287,7 @@
(declare
(unit compiler)
- (uses eval extras data-structures scrutinizer support))
+ (uses eval extras expand data-structures scrutinizer support))
(module chicken.compiler.core
(analyze-expression canonicalize-expression compute-database-statistics
@@ -543,7 +543,7 @@
(define (handle-expansion-result outer-ln)
(lambda (input output)
(and-let* (((not (eq? input output)))
- (ln (or (get-line input) outer-ln)))
+ (ln (or (get-line-number input) outer-ln)))
(update-line-number-database! output ln))
output))
@@ -640,7 +640,7 @@
`(quote ,x)
(##sys#syntax-error/context "illegal atomic form" x)))
((symbol? (car x))
- (let ((ln (or (get-line x) outer-ln)))
+ (let ((ln (or (get-line-number x) outer-ln)))
(emit-syntax-trace-info x #f)
(unless (list? x)
(if ln
@@ -752,7 +752,7 @@
(vars (unzip1 bindings))
(aliases (map gensym vars))
(se2 (##sys#extend-se (##sys#current-environment) vars aliases))
- (ln (or (get-line x) outer-ln)))
+ (ln (or (get-line-number x) outer-ln)))
(set-real-names! aliases vars)
`(let
,(map (lambda (alias b)
@@ -821,7 +821,7 @@
llist
(lambda (vars argc rest)
(let* ((aliases (map gensym vars))
- (ln (or (get-line x) outer-ln))
+ (ln (or (get-line-number x) outer-ln))
(se2 (##sys#extend-se (##sys#current-environment) vars aliases))
(body (parameterize ((##sys#current-environment se2))
(let ((body0 (canonicalize-body/ln
@@ -870,7 +870,7 @@
(car b))))
(cadr x) )
(##sys#current-environment)) ))
- (let ((ln (or (get-line x) outer-ln)))
+ (let ((ln (or (get-line-number x) outer-ln)))
(walk
(canonicalize-body/ln
ln (cddr x) compiler-syntax-enabled)
@@ -886,7 +886,7 @@
(car b))))
(cadr x) ) )
(se2 (append ms (##sys#current-environment)))
- (ln (or (get-line x) outer-ln)) )
+ (ln (or (get-line-number x) outer-ln)) )
(for-each
(lambda (sb)
(set-car! (cdr sb) se2) )
@@ -969,7 +969,7 @@
(##sys#current-environment)))
(##sys#get name '##compiler#compiler-syntax) ) ) )
(cadr x)))
- (ln (or (get-line x) outer-ln)))
+ (ln (or (get-line-number x) outer-ln)))
(dynamic-wind
(lambda ()
(for-each
@@ -990,7 +990,7 @@
bs) ) ) ) )
((##core#include)
- (fluid-let ((##sys#default-read-info-hook read-info-hook))
+ (fluid-let ((##sys#default-read-info-hook ##sys#read/source-info-hook))
(##sys#include-forms-from-file
(cadr x)
(caddr x)
@@ -1101,7 +1101,7 @@
(obody (cddr x))
(aliases (map gensym vars))
(se2 (##sys#extend-se (##sys#current-environment) vars aliases))
- (ln (or (get-line x) outer-ln))
+ (ln (or (get-line-number x) outer-ln))
(body
(parameterize ((##sys#current-environment se2))
(walk
@@ -1115,7 +1115,7 @@
(unless tl?
(let* ((var0 (cadr x))
(var (lookup var0))
- (ln (get-line x)))
+ (ln (get-line-number x)))
(quit-compiling
"~atoplevel definition of `~s' in non-toplevel context"
(if ln (sprintf "(~a) - " ln) "")
@@ -1125,7 +1125,7 @@
((##core#set!)
(let* ((var0 (cadr x))
(var (lookup var0))
- (ln (get-line x))
+ (ln (get-line-number x))
(val (caddr x)))
(when (memq var unlikely-variables)
(warning
@@ -1286,7 +1286,7 @@
((##core#define-external-variable)
(let* ((sym (second x))
- (ln (get-line x))
+ (ln (get-line-number x))
(name (symbol->string sym))
(type (third x))
(exported (fourth x))
@@ -1335,7 +1335,7 @@
((##core#define-inline)
(let* ((name (second x))
(val `(##core#lambda ,@(cdaddr x)))
- (ln (get-line x)))
+ (ln (get-line-number x)))
(unless tl?
(quit-compiling
"~ainline definition of `~s' in non-toplevel context"
@@ -1346,7 +1346,7 @@
((##core#define-constant)
(let* ((name (second x))
- (ln (get-line x))
+ (ln (get-line-number x))
(valexp (third x))
(val (handle-exceptions ex
;; could show line number here
@@ -1400,7 +1400,7 @@
(if (valid-c-identifier? raw-c-name)
(set! callback-names
(cons (cons raw-c-name name) callback-names))
- (let ((ln (get-line x)))
+ (let ((ln (get-line-number x)))
(quit-compiling
"~aname `~S' of external definition is not a valid C identifier"
(if ln (sprintf "(~a) - " ln) "")
diff --git a/expand.scm b/expand.scm
index 6af6e5d6..0710a3a1 100644
--- a/expand.scm
+++ b/expand.scm
@@ -48,7 +48,8 @@
chicken.fixnum
chicken.internal
chicken.keyword
- chicken.platform)
+ chicken.platform
+ chicken.string)
(include "common-declarations.scm")
(include "mini-srfi-1.scm")
@@ -651,9 +652,12 @@
(list 'define name exp) ) ) )
-;;; General syntax checking routine:
+;;; Line-number database management:
(define ##sys#line-number-database #f)
+
+;;; General syntax checking routine:
+
(define ##sys#syntax-error-culprit #f)
(define ##sys#syntax-context '())
@@ -712,6 +716,24 @@
(else (loop (cdr cx))))))))
(##sys#syntax-error-hook (get-output-string out))))))
+;;; Hook for source information
+
+(define (##sys#read/source-info-hook class data val) ; Used here and in core.scm
+ (when (and (eq? 'list-info class) (symbol? (car data)))
+ (hash-table-set!
+ ##sys#line-number-database
+ (car data)
+ (alist-cons
+ data (conc ##sys#current-source-filename ":" val)
+ (or (hash-table-ref ##sys#line-number-database (car data))
+ '() ) ) ) )
+ data)
+
+;; 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 (get-line-number sexp)
(and ##sys#line-number-database
(pair? sexp)
@@ -723,6 +745,26 @@
(and a (cdr a)))))
(else #f))))))
+;; TODO: Needs a better name - it extracts the name(?) and the source expression
+(define (##sys#get-line-2 exp)
+ (let* ((name (car exp))
+ (lst (hash-table-ref ##sys#line-number-database name)))
+ (cond ((and lst (assq exp (cdr lst)))
+ => (lambda (a) (values (car lst) (cdr a))) )
+ (else (values name #f)) ) ) )
+
+(define (##sys#display-line-number-database)
+ (hash-table-for-each
+ (lambda (key val)
+ (when val
+ (let ((port (current-output-port)))
+ (##sys#print key #t port)
+ (##sys#print " " #f port)
+ (##sys#print (map cdr val) #t port)
+ (##sys#print "\n" #f port))) )
+ ##sys#line-number-database) )
+
+
(define-constant +default-argument-count-limit+ 99999)
(define ##sys#check-syntax
diff --git a/rules.make b/rules.make
index 222035fe..f801bf9d 100644
--- a/rules.make
+++ b/rules.make
@@ -536,6 +536,7 @@ batch-driver.c: batch-driver.scm mini-srfi-1.scm \
chicken.condition.import.scm \
chicken.port.import.scm \
chicken.string.import.scm \
+ chicken.syntax.import.scm \
chicken.time.import.scm
c-platform.c: c-platform.scm mini-srfi-1.scm \
chicken.compiler.optimizer.import.scm \
@@ -565,7 +566,8 @@ core.c: core.scm mini-srfi-1.scm \
chicken.keyword.import.scm \
chicken.load.import.scm \
chicken.pretty-print.import.scm \
- chicken.string.import.scm
+ chicken.string.import.scm \
+ chicken.syntax.import.scm
optimizer.c: optimizer.scm mini-srfi-1.scm \
chicken.compiler.support.import.scm \
chicken.fixnum.import.scm \
@@ -595,7 +597,8 @@ compiler-syntax.c: compiler-syntax.scm mini-srfi-1.scm \
chicken.compiler.support.import.scm \
chicken.compiler.core.import.scm \
chicken.fixnum.import.scm \
- chicken.format.import.scm
+ chicken.format.import.scm \
+ chicken.syntax.import.scm
chicken-ffi-syntax.c: chicken-ffi-syntax.scm \
chicken.format.import.scm \
chicken.internal.import.scm \
@@ -745,6 +748,7 @@ expand.c: expand.scm \
chicken.fixnum.import.scm \
chicken.keyword.import.scm \
chicken.platform.import.scm \
+ chicken.string.import.scm \
chicken.internal.import.scm
extras.c: extras.scm \
chicken.fixnum.import.scm \
diff --git a/support.scm b/support.scm
index 6bda371e..42e275ee 100644
--- a/support.scm
+++ b/support.scm
@@ -40,9 +40,7 @@
canonicalize-begin-body string->expr llist-length llist-match?
expand-profile-lambda reset-profile-info-vector-name!
profiling-prelude-exps db-get db-get-all db-put! collect! db-get-list
- get-line get-line-2 display-line-number-database
- make-node node? node-class node-class-set!
- node-parameters node-parameters-set!
+ make-node node? node-class node-class-set! node-parameters node-parameters-set!
node-subexpressions node-subexpressions-set! varnode qnode
build-node-graph build-expression-tree fold-boolean inline-lambda-bindings
tree-copy copy-node! copy-node emit-global-inline-file load-inline-file
@@ -65,7 +63,7 @@
real-name real-name2 display-real-name-table
source-info->string source-info->line source-info->name
call-info constant-form-eval maybe-constant-fold-call
- dump-nodes read-info-hook read/source-info big-fixnum? small-bignum?
+ dump-nodes big-fixnum? small-bignum?
hide-variable export-variable variable-hidden? variable-visible?
mark-variable variable-mark intrinsic? predicate? foldable?
load-identifier-database
@@ -448,25 +446,6 @@
(or x '())))
-;;; Line-number database management:
-
-(define (get-line exp)
- (db-get ##sys#line-number-database (car exp) exp) )
-
-(define (get-line-2 exp)
- (let* ((name (car exp))
- (lst (hash-table-ref ##sys#line-number-database name)))
- (cond ((and lst (assq exp (cdr lst)))
- => (lambda (a) (values (car lst) (cdr a))) )
- (else (values name #f)) ) ) )
-
-(define (display-line-number-database)
- (hash-table-for-each
- (lambda (key val)
- (when val (printf "~S ~S~%" key (map cdr val))) )
- ##sys#line-number-database) )
-
-
;;; Node creation and -manipulation:
;; Note: much of this stuff will be overridden by the inline-definitions in "tweaks.scm".
@@ -567,7 +546,7 @@
((##core#app)
(make-node '##core#call (list #t) (map walk (cdr x))) )
(else
- (receive (name ln) (get-line-2 x)
+ (receive (name ln) (##sys#get-line-2 x)
(make-node
'##core#call
(list (cond [(variable-mark name '##compiler#always-bound-to-procedure)
@@ -1676,23 +1655,6 @@
(newline) )
-;;; Hook for source information
-
-(define (read-info-hook class data val) ; Used here and in compiler.scm
- (when (and (eq? 'list-info class) (symbol? (car data)))
- (hash-table-set!
- ##sys#line-number-database
- (car data)
- (alist-cons
- data (conc ##sys#current-source-filename ":" val)
- (or (hash-table-ref ##sys#line-number-database (car data))
- '() ) ) ) )
- data)
-
-(define (read/source-info in) ; Used only in batch-driver
- (##sys#read in read-info-hook) )
-
-
;;; "#> ... <#" syntax:
(set! ##sys#user-read-hook
Trap