~ chicken-core (chicken-5) 55d6fe4b3891ebd345f1431cadd45a2336aee16c
commit 55d6fe4b3891ebd345f1431cadd45a2336aee16c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Apr 13 14:55:19 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Apr 13 14:55:19 2010 +0200
- moved chicken-ffi-syntax into own unit
- note about redefinitions of `define' in manual (thanks to Jeronimo)
- mini-salmonella: sorts directory before building extensions
- canonicalization creates a more helpful error message when an invalid
data object occurs in source expressions and the object is part of
another expression that might be a reference to a macro in
modules.db
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index 25474b98..60566537 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -25,6 +25,20 @@
; POSSIBILITY OF SUCH DAMAGE.
+(declare
+ (unit chicken-ffi-syntax)
+ (disable-interrupts)
+ (fixnum) )
+
+#+(not debugbuild)
+(declare
+ (no-bound-checks)
+ (no-procedure-checks))
+
+(##sys#provide
+ 'chicken-ffi-syntax)
+
+
(define ##sys#chicken-ffi-macro-environment
(let ((me0 (##sys#macro-environment)))
diff --git a/chicken-install.scm b/chicken-install.scm
index ecfd1c8b..d5ec2d6e 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -27,7 +27,7 @@
(require-library setup-download setup-api)
(require-library srfi-1 posix data-structures utils regex ports extras srfi-13 files)
(require-library chicken-syntax) ; in case an import library reexports chicken syntax
-
+(require-library chicken-ffi-syntax) ; same reason, also for filling modules.db
(module main ()
@@ -115,8 +115,8 @@
(cons from (cdr to)))))
(cdr x)))))
(else (broken x))))
- (read-file deff)))
- (pair? *default-sources*) ) ) )
+ (read-file deff))))
+ (pair? *default-sources*) ))
(define (known-default-sources)
(if (and *default-location* *default-transport*)
diff --git a/chicken.scm b/chicken.scm
index 55eadbd8..217256d3 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -26,18 +26,15 @@
(declare
- (uses chicken-syntax srfi-1 srfi-4 utils files extras data-structures support
+ (uses chicken-syntax chicken-ffi-syntax
+ srfi-1 srfi-4 utils files extras data-structures support
compiler optimizer unboxing compiler-syntax scrutinizer driver platform backend
- srfi-69)
- (compile-syntax) )
+ srfi-69))
(include "compiler-namespace")
(include "tweaks")
-(eval-when (load)
- (include "chicken-ffi-syntax") )
-
;;; Prefix argument list with default options:
diff --git a/compiler.scm b/compiler.scm
index aa31df8a..8d165c00 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -515,14 +515,14 @@
((not-pair? x)
(if (constant? x)
`(quote ,x)
- (syntax-error "illegal atomic form" x)))
+ (##sys#syntax-error/context "illegal atomic form" x)))
((symbol? (car x))
(let ([ln (get-line x)])
(emit-syntax-trace-info x #f)
(unless (proper-list? x)
(if ln
- (syntax-error (sprintf "(~a) - malformed expression" ln) x)
- (syntax-error "malformed expression" x)))
+ (##sys#syntax-error/context (sprintf "(~a) - malformed expression" ln) x)
+ (##sys#syntax-error/context "malformed expression" x)))
(set! ##sys#syntax-error-culprit x)
(let* ((name0 (lookup (car x) se))
(name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
@@ -1191,9 +1191,13 @@
(walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ) ) )
(else
- (let* ([x2 (mapwalk x e se)]
- [head2 (car x2)]
- [old (##sys#hash-table-ref line-number-database-2 head2)] )
+ (let* ((msyntax (unimported-syntax name))
+ (x2 (if msyntax
+ (fluid-let ((##sys#unimported-syntax-context name))
+ (mapwalk x e se))
+ (mapwalk x e se)))
+ (head2 (car x2))
+ (old (##sys#hash-table-ref line-number-database-2 head2)) )
(when ln
(##sys#hash-table-set!
line-number-database-2
@@ -1202,7 +1206,7 @@
x2) ) ) ] ) ) ) )
((not (proper-list? x))
- (syntax-error "malformed expression" x) )
+ (##sys#syntax-error/context "malformed expression" x) )
((constant? (car x))
(emit-syntax-trace-info x #f)
@@ -1218,6 +1222,14 @@
(,tmp ,@(cdr x)))
e se dest)))))
+ (define (unimported-syntax sym)
+ (let ((defs (##sys#get (##sys#strip-syntax sym) '##core#db)))
+ (and defs
+ (let loop ((defs defs))
+ (and (pair? defs)
+ (or (eq? 'syntax (caar defs))
+ (loop (cdr defs))))))))
+
(define (mapwalk xs e se)
(map (lambda (x) (walk x e se #f)) xs) )
diff --git a/defaults.make b/defaults.make
index 4f5ebe62..4669a853 100644
--- a/defaults.make
+++ b/defaults.make
@@ -324,7 +324,7 @@ IMPORT_LIBRARIES = chicken lolevel srfi-1 srfi-4 data-structures ports files pos
IMPORT_LIBRARIES += setup-api setup-download
SCRUTINIZED_LIBRARIES = library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
srfi-14 srfi-18 srfi-69 $(POSIXFILE) regex scheduler \
- profiler stub expand chicken-syntax
+ profiler stub expand chicken-syntax chicken-ffi-syntax
ifdef STATICBUILD
CHICKEN_STATIC_EXECUTABLE = $(CHICKEN_PROGRAM)$(EXE)
diff --git a/distribution/manifest b/distribution/manifest
index f58300de..bb470550 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -49,6 +49,7 @@ buildversion
c-backend.scm
c-platform.scm
chicken-ffi-syntax.scm
+chicken-ffi-syntax.c
chicken-profile.1
chicken-profile.scm
chicken.1
diff --git a/eval.scm b/eval.scm
index 94bd62b2..54eb945c 100644
--- a/eval.scm
+++ b/eval.scm
@@ -106,7 +106,8 @@
(define ##sys#core-library-modules
'(extras lolevel utils files tcp regex posix srfi-1 srfi-4 srfi-13
- srfi-14 srfi-18 srfi-69 data-structures ports chicken-syntax))
+ srfi-14 srfi-18 srfi-69 data-structures ports chicken-syntax
+ chicken-ffi-syntax))
(define ##sys#explicit-library-modules '())
@@ -300,7 +301,8 @@
(or (##sys#get j '##core#primitive) j))))
(if ##sys#eval-environment
(let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
- (unless loc (##sys#syntax-error-hook "reference to undefined identifier" var))
+ (unless loc
+ (##sys#syntax-error-hook "reference to undefined identifier" var))
(if ##sys#unsafe-eval
(lambda v (##sys#slot loc 1))
(lambda v
@@ -333,7 +335,8 @@
(eof-object? x)
(string? x) )
(lambda v x) ]
- [(not (pair? x)) (##sys#syntax-error-hook "illegal non-atomic object" x)]
+ [(not (pair? x))
+ (##sys#syntax-error/context "illegal non-atomic object" x)]
[(symbol? (##sys#slot x 0))
(emit-syntax-trace-info tf x cntr)
(let ((x2 (##sys#expand x se #f)))
@@ -744,12 +747,25 @@
[(##core#app)
(compile-call (cdr x) e tf cntr se) ]
- [else (compile-call x e tf cntr se)] ) ) ) ) ]
+ (else
+ (let ((msyntax (unimported-syntax head)))
+ (if msyntax
+ (fluid-let ((##sys#unimported-syntax-context head))
+ (compile-call x e tf cntr se))
+ (compile-call x e tf cntr se)) ) ) ) ) ) ) ]
[else
(emit-syntax-trace-info tf x cntr)
(compile-call x e tf cntr se)] ) )
+ (define (unimported-syntax sym)
+ (let ((defs (##sys#get (##sys#strip-syntax sym) '##core#db)))
+ (and defs
+ (let loop ((defs defs))
+ (and (pair? defs)
+ (or (eq? 'syntax (caar defs))
+ (loop (cdr defs))))))))
+
(define (fudge-argument-list n alst)
(if (null? alst)
(list alst)
@@ -776,7 +792,7 @@
[argc (checked-length args)]
[info x] )
(case argc
- [(#f) (##sys#syntax-error-hook "malformed expression" x)]
+ [(#f) (##sys#syntax-error/context "malformed expression" x)]
[(0) (lambda (v)
(emit-trace-info tf info cntr)
((fn v)))]
diff --git a/expand.scm b/expand.scm
index 6affc568..2a567ac3 100644
--- a/expand.scm
+++ b/expand.scm
@@ -594,11 +594,48 @@
(define ##sys#line-number-database #f)
(define ##sys#syntax-error-culprit #f)
+(define ##sys#unimported-syntax-context #f)
(define (##sys#syntax-error-hook . args)
(apply ##sys#signal-hook #:syntax-error
(##sys#strip-syntax args)))
+(define ##sys#syntax-error/context
+ (let ((open-output-string open-output-string)
+ (get-output-string get-output-string))
+ (lambda (msg arg)
+ (cond (##sys#unimported-syntax-context
+ =>
+ (lambda (cx)
+ (let* ((cx (##sys#strip-syntax cx))
+ (a (##sys#get cx '##core#db))
+ (out (open-output-string)))
+ (##sys#print msg #f out)
+ (##sys#print ": " #f out)
+ (##sys#print arg #t out)
+ (##sys#print "\n\nPerhaps you intended to use the syntax `" #f out)
+ (##sys#print cx #f out)
+ (##sys#print "' without importing it first.\n" #f out)
+ (if (= 1 (length a))
+ (##sys#print
+ (string-append
+ "Suggesting: `(import "
+ (symbol->string (cadar a))
+ ")'")
+ #f out)
+ (##sys#print
+ (string-append
+ "Suggesting one of:\n"
+ (let loop ((lst a))
+ (if (null? lst)
+ ""
+ (string-append
+ "\n (import " (symbol->string (cadar lst)) ")"
+ (loop (cdr lst))))))
+ #f out))
+ (##sys#syntax-error-hook (get-output-string out)))))
+ (else (##sys#syntax-error-hook msg arg))))))
+
(define syntax-error ##sys#syntax-error-hook)
(define (##sys#syntax-rules-mismatch input)
@@ -1824,7 +1861,7 @@
(if (null? lst)
""
(string-append
- "Warning: `(import " (symbol->string (cadar lst)) ")'\n"
+ "Warning: (import " (symbol->string (cadar lst)) ")\n"
(loop (cdr lst)))))))))))
(module-undefined-list mod))
(when missing
diff --git a/library.scm b/library.scm
index 50dffbd2..438f9363 100644
--- a/library.scm
+++ b/library.scm
@@ -4282,6 +4282,7 @@ EOF
(let-optionals args ([port ##sys#standard-output]
[header "Error"] )
(##sys#check-port port 'print-error-message)
+ (newline port)
(display header port)
(cond [(and (not (##sys#immediate? ex)) (eq? 'condition (##sys#slot ex 0)))
(cond ((errmsg ex) =>
diff --git a/manual/Deviations from the standard b/manual/Deviations from the standard
index a36dd3e9..e6a60f06 100644
--- a/manual/Deviations from the standard
+++ b/manual/Deviations from the standard
@@ -13,9 +13,13 @@ to continuations captured using {{call-with-current-continuation}}
is 120. This is an implementation restriction that is unlikely
to be lifted.
+[5.3] Redefining {{define}} with a value will silently create a
+variable binding and keep the syntax definition. R5RS states that
+such a redefinition is an error.
+
[6.2.5] The {{numerator}} and {{denominator}} procedures cannot be
applied to inexact numbers, and the procedure {{rationalize}} is not
-implemented at all. This will be fixed in a later release.
+implemented at all.
[6.2.4] The runtime system uses the numerical string-conversion
routines of the underlying C library and so does only understand
@@ -27,8 +31,6 @@ read/write invariance to inexact numbers.
[6.5] Code evaluated in {{scheme-report-environment}} or
{{null-environment}} still sees non-standard syntax.
-== Unconfirmed deviations
-
[6.6.2] The procedure {{char-ready?}} always returns {{#t}} for
terminal ports.
@@ -72,7 +74,7 @@ numbers or extended-precision integers (bignums). The routines
{{complex?}}, {{real?}} and {{rational?}} are identical to
the standard procedure {{number?}}. The procedures {{make-rectangular}}
and {{make-polar}} are not implemented. Fixnums are limited to
-±2<nowiki><sup>30</sup></nowiki> (or ±2<nowiki><sup>62</sup></nowiki>
+2^<nowiki><sup>30</sup></nowiki> (or 2^<nowiki><sup>62</sup></nowiki>
on 64-bit hardware). Support for the full numeric tower is available
as a separate package, provided the GNU multiprecision library is installed.
diff --git a/rules.make b/rules.make
index 08563244..7ff53846 100644
--- a/rules.make
+++ b/rules.make
@@ -31,7 +31,7 @@ VPATH=$(SRCDIR)
LIBCHICKEN_OBJECTS_1 = \
library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
srfi-14 srfi-18 srfi-69 $(POSIXFILE) regex scheduler \
- profiler stub expand chicken-syntax runtime
+ profiler stub expand chicken-syntax chicken-ffi-syntax runtime
LIBCHICKEN_SHARED_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=$(O))
LIBCHICKEN_STATIC_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=-static$(O))
@@ -60,6 +60,10 @@ chicken-syntax$(O): chicken-syntax.c chicken.h $(CHICKEN_CONFIG_H)
$(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
$(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
$(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+chicken-ffi-syntax$(O): chicken-ffi-syntax.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
data-structures$(O): data-structures.c chicken.h $(CHICKEN_CONFIG_H)
$(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
$(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
@@ -161,6 +165,11 @@ chicken-syntax-static$(O): chicken-syntax.c chicken.h $(CHICKEN_CONFIG_H)
$(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
$(C_COMPILER_STATIC_OPTIONS) \
$(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+chicken-ffi-syntax-static$(O): chicken-ffi-syntax.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
data-structures-static$(O): data-structures.c chicken.h $(CHICKEN_CONFIG_H)
$(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
$(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
@@ -828,6 +837,8 @@ expand.c: $(SRCDIR)expand.scm $(SRCDIR)synrules.scm
$(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
chicken-syntax.c: $(SRCDIR)chicken-syntax.scm
$(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+chicken-ffi-syntax.c: $(SRCDIR)chicken-ffi-syntax.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
data-structures.c: $(SRCDIR)data-structures.scm $(SRCDIR)private-namespace.scm
$(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend $(SRCDIR)private-namespace.scm
ports.c: $(SRCDIR)ports.scm $(SRCDIR)private-namespace.scm
@@ -914,7 +925,7 @@ setup-download.import.c: $(SRCDIR)setup-download.scm
$(CHICKEN) $(SRCDIR)setup-download.import.scm $(CHICKEN_IMPORT_LIBRARY_OPTIONS) \
-ignore-repository -output-file $@
-chicken.c: $(SRCDIR)chicken.scm $(SRCDIR)chicken-ffi-syntax.scm $(SRCDIR)compiler-namespace.scm \
+chicken.c: $(SRCDIR)chicken.scm $(SRCDIR)compiler-namespace.scm \
$(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
$(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
support.c: $(SRCDIR)support.scm $(SRCDIR)banner.scm $(SRCDIR)compiler-namespace.scm \
@@ -971,7 +982,7 @@ setup-download.c: $(SRCDIR)setup-download.scm setup-api.c
.PHONY: distfiles dist html
-distfiles: library.c eval.c expand.c chicken-syntax.c \
+distfiles: library.c eval.c expand.c chicken-syntax.c chicken-ffi-syntax.c \
data-structures.c ports.c files.c extras.c lolevel.c utils.c \
tcp.c srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c \
posixunix.c posixwin.c regex.c scheduler.c profiler.c stub.c \
@@ -1015,14 +1026,14 @@ confclean:
spotless: distclean testclean
-$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) library.c eval.c data-structures.c \
- ports.c files.c extras.c lolevel.c utils.c chicken-syntax.c \
+ ports.c files.c extras.c lolevel.c utils.c chicken-syntax.c chicken-ffi-syntax.c \
tcp.c srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c expand.c \
posixunix.c posixwin.c regex.c scheduler.c profiler.c stub.c \
chicken-profile.c chicken-bug.c \
csc.c csi.c chicken-install.c chicken-uninstall.c chicken-status.c \
chicken.c batch-driver.c compiler.c optimizer.c compiler-syntax.c \
scrutinizer.c support.c unboxing.c \
- c-platform.c c-backend.c chicken-boot$(EXE) setup-api.c setup-download.c \
+ c-platform.c c-backend.c setup-api.c setup-download.c \
$(IMPORT_LIBRARIES:=.import.c)
distclean: clean confclean
diff --git a/scripts/mini-salmonella.scm b/scripts/mini-salmonella.scm
index 5af7d267..9b150b82 100644
--- a/scripts/mini-salmonella.scm
+++ b/scripts/mini-salmonella.scm
@@ -124,7 +124,7 @@
(install-egg egg dir)
(report egg "<no .setup script>")) )
(report egg "<no .meta file>")))))
- (directory *eggdir*))
+ (sort (directory *eggdir*) string<?))
(print "\nSucceeded: " *succeeded* ", failed: " *failed* ", total: "
(+ *succeeded* *failed*))
diff --git a/support.scm b/support.scm
index 3e397084..54a8dc2e 100644
--- a/support.scm
+++ b/support.scm
@@ -82,8 +82,8 @@
(set! args (cdr args))
loc))))
(if loc
- (fprintf out "Syntax error (~a): ~a~%~%" loc msg)
- (fprintf out "Syntax error: ~a~%~%" msg) )
+ (fprintf out "\nSyntax error (~a): ~a~%~%" loc msg)
+ (fprintf out "\nSyntax error: ~a~%~%" msg) )
(for-each (cut fprintf out "\t~s~%" <>) args)
(print-call-chain out 0 ##sys#current-thread "\n\tExpansion history:\n")
(exit 70) ) ) )
@@ -1503,7 +1503,8 @@ EOF
(printf "loading identifier database ~a ...~%" dbfile))
(for-each
(lambda (e)
- (##sys#put!
- (car e) '##core#db
- (append (or (##sys#get (car e) '##core#db) '()) (list (cdr e))) ))
+ (let ((id (car e)))
+ (##sys#put!
+ id '##core#db
+ (append (or (##sys#get id '##core#db) '()) (list (cdr e))) )))
(read-file dbfile))))
Trap