~ chicken-core (chicken-5) c4cd22f8d9ac373c8b7e95541852c650228722d0
commit c4cd22f8d9ac373c8b7e95541852c650228722d0
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Tue Jan 12 22:38:06 2016 +1300
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Tue Mar 8 22:52:33 2016 +1300
Simplify toplevel name generation
Move the `string->c-identifier` procedure, which is used by both the
compiler and the eval unit but doesn't really belong in eval.scm, to the
internal unit, and use it for toplevel name generation in c-backend.scm.
diff --git a/c-backend.scm b/c-backend.scm
index 1061043a..8ccfc08e 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -30,7 +30,7 @@
;; Same goes for "platform" and "driver".
(declare
(unit c-backend)
- (uses data-structures extras c-platform compiler support))
+ (uses data-structures extras c-platform compiler internal support))
(module chicken.compiler.c-backend
(generate-code
@@ -43,7 +43,8 @@
chicken.compiler.c-platform
chicken.compiler.support
chicken.extras
- chicken.foreign)
+ chicken.foreign
+ chicken.internal)
(include "mini-srfi-1.scm")
@@ -392,7 +393,7 @@
(nf (+ n 1)) )
(gen #\{)
(push-args subs i "C_SCHEME_UNDEFINED")
- (gen #t "C_" (c-identifier (first params)) "_toplevel(" nf ",av2);}")))
+ (gen #t "C_" (toplevel (first params)) "(" nf ",av2);}")))
((##core#return)
(gen #t "return(")
@@ -559,11 +560,11 @@
(define (declarations)
(let ((n (length literals)))
(gen #t #t "static C_PTABLE_ENTRY *create_ptable(void);")
- (for-each
+ (for-each
(lambda (uu)
- (gen #t "C_noret_decl(C_" uu "_toplevel)"
- #t "C_externimport void C_ccall C_" uu "_toplevel(C_word c,C_word *av) C_noret;"))
- (map c-identifier used-units))
+ (gen #t "C_noret_decl(C_" uu ")"
+ #t "C_externimport void C_ccall C_" uu "(C_word c,C_word *av) C_noret;"))
+ (map toplevel used-units))
(unless (zero? n)
(gen #t #t "static C_TLS C_word lf[" n "];") )
(gen #t "static double C_possibly_force_alignment;")
@@ -607,7 +608,7 @@
(gen "C_ccall ") )
(gen id) )
(else
- (let ((uname (if unit-name (string-append (c-identifier unit-name) "_toplevel") "toplevel")))
+ (let ((uname (toplevel unit-name)))
(gen "C_noret_decl(C_" uname ")" #t) ;XXX what's this for?
(gen "C_externexport void C_ccall ")
(gen "C_" uname) ) ) )
@@ -762,9 +763,7 @@
(rest-mode (lambda-literal-rest-argument-mode ll))
(temps (lambda-literal-temporaries ll))
(ubtemps (lambda-literal-unboxed-temporaries ll))
- (topname (if unit-name
- (string-append (c-identifier unit-name) "_toplevel")
- "toplevel") ) )
+ (topname (toplevel unit-name)))
(when empty-closure (debugging 'o "dropping unused closure argument" id))
(gen #t #t)
(gen "/* " (cleanup rname) " */" #t)
@@ -932,9 +931,7 @@
(lambda (id ll)
(gen #t "{\"" id #\: (string->c-identifier sf) "\",(void*)")
(if (eq? 'toplevel id)
- (if unit-name
- (gen "C_" (c-identifier unit-name) "_toplevel},")
- (gen "C_toplevel},") )
+ (gen "C_" (toplevel unit-name) "},")
(gen id "},") ) )
lambda-table)
(gen #t "{NULL,NULL}};")
@@ -948,6 +945,14 @@
#t "}") )
+;;; Generate top-level procedure name:
+
+(define (toplevel name)
+ (if (not name)
+ "toplevel"
+ (string-append (c-identifier name) "_toplevel")))
+
+
;;; Create name that is safe for C comments:
(define (cleanup s)
diff --git a/eval.scm b/eval.scm
index 2914afe9..c5a4f979 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1320,23 +1320,6 @@
(values `(##sys#require (##core#quote ,id)) #f 'dynamic)))))
-;;; Convert string into valid C-identifier:
-
-(define (##sys#string->c-identifier str)
- (let ((out (open-output-string))
- (n (string-length str)))
- (do ((i 0 (fx+ i 1)))
- ((fx>= i n) (get-output-string out))
- (let ((c (string-ref str i)))
- (if (and (not (char-alphabetic? c))
- (or (not (char-numeric? c)) (fx= i 0)))
- (let ((i (char->integer c)))
- (write-char #\_ out)
- (when (fx< i 16) (write-char #\0 out))
- (display (number->string i 16) out))
- (write-char c out))))))
-
-
;;; Environments:
(define interaction-environment
diff --git a/support.scm b/support.scm
index 81944765..4a992cb5 100644
--- a/support.scm
+++ b/support.scm
@@ -27,13 +27,13 @@
(declare (unit support)
(not inline ##sys#user-read-hook) ; XXX: Is this needed?
- (uses data-structures eval extras files ports))
+ (uses data-structures extras files internal ports))
(module chicken.compiler.support
(compiler-cleanup-hook bomb collected-debugging-output debugging
debugging-chicken with-debugging-output quit-compiling
emit-syntax-trace-info check-signature stringify symbolify
- build-lambda-list string->c-identifier c-ify-string valid-c-identifier?
+ build-lambda-list c-ify-string valid-c-identifier?
bytes->words words->bytes
check-and-open-input-file close-checked-input-file fold-inner
constant? collapsable-literal? immediate? basic-literal?
@@ -218,9 +218,6 @@
(cond ((or (zero? n) (null? vars)) (or rest '()))
(else (cons (car vars) (loop (cdr vars) (sub1 n)))) ) ) )
-;; XXX: This seems to belong to c-platform, but why is it defined in eval.scm?
-(define string->c-identifier ##sys#string->c-identifier)
-
;; XXX: Put this too in c-platform or c-backend?
(define (c-ify-string str)
(list->string
Trap