~ chicken-core (chicken-5) aa0be1fce1804c06b673720244fef4ec2af9fedf
commit aa0be1fce1804c06b673720244fef4ec2af9fedf
Author: felix <felix@y.(none)>
AuthorDate: Mon Mar 1 21:20:25 2010 +0100
Commit: felix <felix@y.(none)>
CommitDate: Mon Mar 1 21:20:25 2010 +0100
somewhat better line-info handling, included files retain source filename, made include syntax expanding into core-form (handled differently by compiler and interpreter), added unboxing for pointer-ops, removed unsafe warning for compiled code in dynamic mode, rewrite rules for lolevel some pointer ops and what the heck else
diff --git a/batch-driver.scm b/batch-driver.scm
index 4812bbd4..9094eb1c 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -123,18 +123,6 @@
(newline))
xs) ) )
- (define (infohook class data val)
- (let ([data2 ((or ##sys#default-read-info-hook (lambda (a b c) b)) class data val)])
- (when (and (eq? 'list-info class) (symbol? (car data2)))
- (##sys#hash-table-set!
- ##sys#line-number-database
- (car data2)
- (alist-cons
- data2 val
- (or (##sys#hash-table-ref ##sys#line-number-database (car data2))
- '() ) ) ) )
- data2) )
-
(define (arg-val str)
(let* ((len (string-length str))
(len1 (- len 1)) )
@@ -158,9 +146,6 @@
(when time-breakdown
(printf "milliseconds needed for ~a: \t~s~%" pass (- (cputime) time0)) ) )
- (define (read-form in)
- (##sys#read in infohook) )
-
(define (analyze pass node . args)
(let-optionals args ((no 0) (contf #t))
(let ((db (analyze-expression node)))
@@ -413,11 +398,13 @@
(let* ((f (car files))
(in (check-and-open-input-file f)) )
(fluid-let ((##sys#current-source-filename f))
- (let ((x1 (read-form in)) )
- (do ((x x1 (read-form in)))
- ((eof-object? x)
- (close-checked-input-file in f) )
- (set! forms (cons x forms)) ) ) ) ) ) ] ) ) )
+ (let loop ()
+ (let ((x (read/source-info in)))
+ (cond ((eof-object? x)
+ (close-checked-input-file in f) )
+ (else
+ (set! forms (cons x forms))
+ (loop)))))))) ] ) ) )
;; Start compilation passes:
(let ([proc (user-preprocessor-pass)])
@@ -428,7 +415,8 @@
(print-expr "source" '|1| forms)
(begin-time)
(unless (null? uses-units)
- (set! ##sys#explicit-library-modules (append ##sys#explicit-library-modules uses-units))
+ (set! ##sys#explicit-library-modules
+ (append ##sys#explicit-library-modules uses-units))
(set! forms (cons `(declare (uses ,@uses-units)) forms)) )
(let* ([exps0 (map canonicalize-expression (append initforms forms))]
[pvec (gensym)]
@@ -467,11 +455,6 @@
(when (and unit-name dynamic)
(compiler-warning 'usage "library unit `~a' compiled in dynamic mode" unit-name) )
- (when (and unsafe (feature? 'compiling-extension))
- (compiler-warning
- 'style
- "compiling extensions in unsafe mode is bad practice and should be avoided") )
-
(set! ##sys#line-number-database line-number-database-2)
(set! line-number-database-2 #f)
diff --git a/c-platform.scm b/c-platform.scm
index cfa2b904..05688567 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -822,7 +822,7 @@
(rewrite 'string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care
(rewrite 'address->pointer 16 1 "C_a_i_address_to_pointer" #f 2)
(rewrite 'pointer->address 16 1 "C_a_i_pointer_to_address" #f words-per-flonum)
-(rewrite 'pointer+ 16 2 "C_a_i_pointer_inc" #f 2)
+(rewrite 'pointer+ 16 2 "C_a_u_i_pointer_inc" #f 2)
(rewrite 'pointer-u8-ref 2 1 "C_u_i_pointer_u8_ref" #f)
(rewrite 'pointer-s8-ref 2 1 "C_u_i_pointer_s8_ref" #f)
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 14154fee..8e15d715 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -157,19 +157,9 @@
(##sys#extend-macro-environment
'include '()
(##sys#er-transformer
- (lambda (form r c)
- (##sys#check-syntax 'include form '(_ string))
- (let ((path (##sys#resolve-include-filename (cadr form) #t))
- (%begin (r 'begin)))
- (when (load-verbose) (print "; including " path " ..."))
- `(,%begin
- ,@(with-input-from-file path
- (lambda ()
- (fluid-let ((##sys#current-source-filename path))
- (do ([x (read) (read)]
- [xs '() (cons x xs)] )
- ((eof-object? x)
- (reverse xs))) ) ) ) ) ) ) ) )
+ (lambda (form r c)
+ (##sys#check-syntax 'include form '(_ string))
+ `(##core#include ,(cadr form)))))
(##sys#extend-macro-environment
'assert '()
diff --git a/chicken.h b/chicken.h
index 85ee46b0..bc45b15e 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1294,10 +1294,10 @@ extern double trunc(double);
#define C_u_i_bit_setp(x, i) C_mk_bool((C_unfix(x) & (1 << C_unfix(i))) != 0)
-#define C_u_i_pointer_u8_ref(ptr) C_fix(((unsigned char *)C_block_item(ptr, 0)))
-#define C_u_i_pointer_s8_ref(ptr) C_fix(((char *)C_block_item(ptr, 0)))
-#define C_u_i_pointer_u16_ref(ptr) C_fix(((unsigned short *)C_block_item(ptr, 0)))
-#define C_u_i_pointer_s16_ref(ptr) C_fix(((short *)C_block_item(ptr, 0)))
+#define C_u_i_pointer_u8_ref(ptr) C_fix(*((unsigned char *)C_block_item(ptr, 0)))
+#define C_u_i_pointer_s8_ref(ptr) C_fix(*((char *)C_block_item(ptr, 0)))
+#define C_u_i_pointer_u16_ref(ptr) C_fix(*((unsigned short *)C_block_item(ptr, 0)))
+#define C_u_i_pointer_s16_ref(ptr) C_fix(*((short *)C_block_item(ptr, 0)))
#define C_a_u_i_pointer_u32_ref(ap, n, ptr) \
C_unsigned_int_to_num(ap, *((C_u32 *)C_block_item(ptr, 0)))
#define C_a_u_i_pointer_s32_ref(ap, n, ptr) \
diff --git a/chicken.scm b/chicken.scm
index 281a6874..167e2284 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -82,7 +82,6 @@
(let ([level (string->number (car rest))])
(case level
[(0) #f]
- ;;XXX later add 'unboxing to -O2 and above
[(1)
(set! options (cons 'optimize-leaf-routines options)) ]
[(2)
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 48c417d2..109887c4 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -172,6 +172,7 @@
immediate?
immutable-constants
import-libraries
+ read-info-hook
initialize-analysis-database
initialize-compiler
inline-globally
@@ -239,6 +240,7 @@
put!
qnode
r-c-s
+ read/source-info
real-name
real-name-table
real-name2
@@ -261,8 +263,8 @@
simplify-named-call
sort-symbols
source-filename
- source-info->line
source-info->string
+ source-info->line
standalone-executable
string->c-identifier
string->expr
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index 1de408cf..3f85aed3 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -179,9 +179,9 @@
(let ((ln (get-line x)))
(compiler-warning
'syntax
- "(~a) in format string ~s~a, ~?"
+ "`~a', in format string ~s~a, ~?"
func fstr
- (if ln (sprintf " in line ~a" ln) "")
+ (if ln (sprintf "(~a)" ln) "")
msg args) )
(when ret? (return #f)))
(let ((code '())
diff --git a/compiler.scm b/compiler.scm
index 1c728b16..242c155c 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -4,7 +4,7 @@
; "This is insane. What we clearly want to do is not exactly clear, and is rooted in NCOMPLR."
;
;
-;-----------------------------------------------------------------------------------------------------------
+;--------------------------------------------------------------------------------------------------
; Copyright (c) 2008-2010, The Chicken Team
; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
@@ -111,6 +111,7 @@
; ([##core#]lambda ({<variable>}+ [. <variable>]) <body>)
; ([##core#]set! <variable> <exp>)
; ([##core#]begin <exp> ...)
+; (##core#include <string>)
; (##core#named-lambda <name> <llist> <body>)
; (##core#loop-lambda <llist> <body>)
; (##core#undefined)
@@ -526,7 +527,7 @@
(emit-syntax-trace-info x #f)
(unless (proper-list? x)
(if ln
- (syntax-error (sprintf "(in line ~s) - malformed expression" ln) x)
+ (syntax-error (sprintf "(~a) - malformed expression" ln) x)
(syntax-error "malformed expression" x)))
(set! ##sys#syntax-error-culprit x)
(let* ((name0 (lookup (car x) se))
@@ -803,6 +804,13 @@
(##sys#put! (car b) '##compiler#compiler-syntax (caddr b)))
bs) ) ) ) )
+ ((##core#include)
+ (walk
+ `(##core#begin
+ ,@(fluid-let ((##sys#default-read-info-hook read-info-hook))
+ (##sys#include-forms-from-file (cadr x))))
+ e se dest))
+
((##core#module)
(let* ((name (##sys#strip-syntax (cadr x)))
(exports
@@ -950,7 +958,7 @@
(compiler-warning
'var "assigned global variable `~S' is a macro ~A"
var
- (if ln (sprintf "in line ~S" ln) "") )
+ (if ln (sprintf "(~a)" ln) "") )
(when undefine-shadowed-macros (##sys#undefine-macro! var) ) )
(when (keyword? var)
(compiler-warning 'syntax "assignment to keyword `~S'" var) )
@@ -2149,8 +2157,9 @@
custom
(not (= (llist-length llist) (length (cdr subs)))))
(quit
- "known procedure called with wrong number of arguments: ~A"
- (source-info->string name) ) )
+ "~a: procedure `~a' called with wrong number of arguments"
+ (source-info->line name)
+ (cadr name)))
(register-direct-call! id)
(when custom (register-customizable! varname id))
(list id custom) )
diff --git a/eval.scm b/eval.scm
index f0d37497..63dd823d 100644
--- a/eval.scm
+++ b/eval.scm
@@ -640,6 +640,10 @@
(##sys#canonicalize-body (cddr x) se #f)
e #f tf cntr se))
+ ((##core#include)
+ `(##core#begin
+ ,@(##sys#include-forms-from-file (cadr x))))
+
((##core#module)
(let* ((name (##sys#strip-syntax (cadr x)))
(exports
@@ -938,18 +942,18 @@
(##sys#dload (##sys#make-c-string (##sys#string-append "./" fname)) topentry #t) ) ) )
(call-with-current-continuation
(lambda (abrt)
- (fluid-let ([##sys#read-error-with-line-number #t]
- [##sys#current-source-filename fname]
- [##sys#current-load-path
+ (fluid-let ((##sys#read-error-with-line-number #t)
+ (##sys#current-source-filename fname)
+ (##sys#current-load-path
(and fname
(let ((i (has-sep? fname)))
- (if i (##sys#substring fname 0 (fx+ i 1)) "") ) ) ]
- [##sys#abort-load (lambda () (abrt #f))] )
- (let ([in (if fname (open-input-file fname) input)])
+ (if i (##sys#substring fname 0 (fx+ i 1)) "") ) ) )
+ (##sys#abort-load (lambda () (abrt #f))) )
+ (let ((in (if fname (open-input-file fname) input)))
(##sys#dynamic-wind
(lambda () #f)
(lambda ()
- (let ([c1 (peek-char in)])
+ (let ((c1 (peek-char in)))
(when (char=? c1 (integer->char 127))
(##sys#error 'load "unable to load compiled module" fname _dlerror) ) )
(let ((x1 (read in)))
@@ -1065,6 +1069,23 @@
(loop (cons (##sys#substring str j i) items) i2 i2) ) ]
[else (loop items (fx+ i 1) j)] ) ) ) ) ) )
+(define ##sys#include-forms-from-file
+ (let ((load-verbose load-verbose)
+ (print print)
+ (with-input-from-file with-input-from-file)
+ (read read)
+ (reverse reverse))
+ (lambda (fname)
+ (let ((path (##sys#resolve-include-filename fname #t)))
+ (when (load-verbose) (print "; including " path " ..."))
+ (with-input-from-file path
+ (lambda ()
+ (fluid-let ((##sys#current-source-filename path))
+ (do ((x (read) (read))
+ (xs '() (cons x xs)) )
+ ((eof-object? x)
+ (reverse xs))) ) ) ) ) ) ) )
+
;;; Extensions:
diff --git a/expand.scm b/expand.scm
index c4bb07d8..8854aa20 100644
--- a/expand.scm
+++ b/expand.scm
@@ -545,8 +545,8 @@
[(eq? 'define-values head)
(##sys#check-syntax 'define-values x '(define-values #(_ 0) _) #f se)
(loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
- [(eq? 'begin head)
- (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
+ [(or (eq? 'begin head) (eq? '##core#begin head))
+ (##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
(loop (##sys#append (cdr x) rest) vars vals mvars mvals) ]
((or (memq head vars) (memq head mvars))
(fini vars vals mvars mvals body))
@@ -633,8 +633,8 @@
[ln (get-line-number sexp)] )
(##sys#syntax-error-hook
(if ln
- (string-append "(" (symbol->string id) ") in line " (number->string ln) " - " msg)
- (string-append "(" (symbol->string id) ") " msg) )
+ (string-append "(" ln ") in `" (symbol->string id) "' - " msg)
+ (string-append "in `" (symbol->string id) "' - " msg) )
exp) ) )
(define (lambda-list? x)
diff --git a/library.scm b/library.scm
index 1559b9d6..2c368c9b 100644
--- a/library.scm
+++ b/library.scm
@@ -2232,7 +2232,7 @@ EOF
##sys#warn
(let ((ln (##sys#port-line port)))
(if (and ##sys#read-error-with-line-number ln)
- (string-append msg " in line " (##sys#number->string ln))
+ (string-append "(" ln ") " msg)
msg) )
args) ) ) )
@@ -2244,7 +2244,7 @@ EOF
#:syntax-error
(let ((ln (##sys#port-line port)))
(if (and ##sys#read-error-with-line-number ln)
- (string-append msg " in line " (##sys#number->string ln))
+ (string-append "(" ln ") " msg)
msg) )
args) ) ) )
diff --git a/lolevel.scm b/lolevel.scm
index 2139e6e5..521a6356 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -363,14 +363,45 @@ EOF
(define (pointer-f32-set! p n) (##core#inline "C_u_i_pointer_f32_set" p n))
(define (pointer-f64-set! p n) (##core#inline "C_u_i_pointer_f64_set" p n))
-(define (pointer-u8-ref p) (##core#inline "C_u_i_pointer_u8_ref" p))
-(define (pointer-s8-ref p) (##core#inline "C_u_i_pointer_s8_ref" p))
-(define (pointer-u16-ref p) (##core#inline "C_u_i_pointer_u16_ref" p))
-(define (pointer-s16-ref p) (##core#inline "C_u_i_pointer_s16_ref" p))
-(define (pointer-u32-ref p) (##core#inline_allocate ("C_a_u_i_pointer_u32_ref" 4) p))
-(define (pointer-s32-ref p) (##core#inline_allocate ("C_a_u_i_pointer_s32_ref" 4) p))
-(define (pointer-f32-ref p) (##core#inline_allocate ("C_a_u_i_pointer_f32_ref" 4) p))
-(define (pointer-f64-ref p) (##core#inline_allocate ("C_a_u_i_pointer_f64_ref" 4) p))
+(define pointer-u8-ref
+ (getter-with-setter
+ (lambda (p) (##core#inline "C_u_i_pointer_u8_ref" p))
+ pointer-u8-set!))
+
+(define pointer-s8-ref
+ (getter-with-setter
+ (lambda (p) (##core#inline "C_u_i_pointer_s8_ref" p))
+ pointer-s8-set!))
+
+(define pointer-u16-ref
+ (getter-with-setter
+ (lambda (p) (##core#inline "C_u_i_pointer_u16_ref" p))
+ pointer-u16-set!))
+
+(define pointer-s16-ref
+ (getter-with-setter
+ (lambda (p) (##core#inline "C_u_i_pointer_s16_ref" p))
+ pointer-s16-set!))
+
+(define pointer-u32-ref
+ (getter-with-setter
+ (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_u32_ref" 4) p)) ;XXX hardcoded size
+ pointer-u32-set!))
+
+(define pointer-s32-ref
+ (getter-with-setter
+ (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_s32_ref" 4) p)) ;XXX hardcoded size
+ pointer-s32-set!))
+
+(define pointer-f32-ref
+ (getter-with-setter
+ (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_f32_ref" 4) p)) ;XXX hardcoded size
+ pointer-f32-set!))
+
+(define pointer-f64-ref
+ (getter-with-setter
+ (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_f64_ref" 4) p)) ;XXX hardcoded size
+ pointer-f64-set!))
;;; Procedures extended with data:
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 9b0d998c..0767458f 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -419,15 +419,14 @@
(pp (fragment x))))))
(define (call-result args e loc x params)
(define (pname)
- (sprintf
- "in procedure call to `~s'~a"
- (fragment x)
- (if (and (pair? params) (pair? (cdr params)))
- (let ((n (source-info->line (cadr params))))
- (if (number? n)
- (sprintf " (line ~a)" n)
- ""))
- "")))
+ (sprintf "~ain procedure call to `~s', "
+ (if (and (pair? params) (pair? (cdr params)))
+ (let ((n (source-info->line (cadr params))))
+ (if n
+ (sprintf "~a: " n)
+ ""))
+ "")
+ (fragment x)))
(d "call-result: ~a (~a)" args loc)
(let* ((ptype (car args))
(nargs (length (cdr args)))
@@ -437,7 +436,7 @@
(report
loc
(sprintf
- "expected ~a a value of type `~a', but were given a value of type `~a'"
+ "~aexpected a value of type `~a', but were given a value of type `~a'"
(pname)
xptype
ptype)))
@@ -448,7 +447,7 @@
(report
loc
(sprintf
- "expected ~a ~a argument~a, but where given ~a argument~a"
+ "~aexpected ~a argument~a, but where given ~a argument~a"
(pname) alen (multiples alen)
nargs (multiples nargs)))))
(do ((args (cdr args) (cdr args))
@@ -459,8 +458,8 @@
(report
loc
(sprintf
- "expected argument #~a of type `~a' ~a, but where given an argument of type `~a'"
- i (car atypes) (pname) (car args)))))
+ "~aexpected argument #~a of type `~a', but where given an argument of type `~a'"
+ (pname) i (car atypes) (car args)))))
(let ((r (procedure-result-types ptype values-rest (cdr args))))
(d " result-types: ~a" r)
r))))
diff --git a/support.scm b/support.scm
index 6b7b6d82..88c94a57 100644
--- a/support.scm
+++ b/support.scm
@@ -177,7 +177,7 @@
(cond [(string=? fname "-") (current-input-port)]
[(file-exists? fname) (open-input-file fname)]
[(or (null? line) (not (car line))) (quit "Can not open file ~s" fname)]
- [else (quit "Can not open file ~s in line ~s" fname (car line))] ) )
+ [else (quit "(~a) can not open file ~s" (car line) fname)] ) )
(define (close-checked-input-file port fname)
(unless (string=? fname "-") (close-input-port port)) )
@@ -531,7 +531,8 @@
[else #f] )
(if ln
(let ([rn (real-name name)])
- (list source-filename ln (or rn (##sys#symbol->qualified-string name))) )
+ (list ln
+ (or rn (##sys#symbol->qualified-string name))) )
(##sys#symbol->qualified-string name) ) )
(map walk x) ) ) ) ) )
(else (make-node '##core#call '(#f) (map walk x))) ) )
@@ -1374,17 +1375,15 @@ EOF
(define (source-info->string info)
(if (list? info)
- (let ((file (car info))
- (ln (cadr info))
- (name (caddr info)))
- (let ((lns (->string ln)))
- (conc file ": " lns (make-string (max 0 (- 4 (string-length lns))) #\space) " " name) ) )
- (and info (->string info))) )
+ (let ((ln (car info))
+ (name (cadr info)))
+ (conc ln ":" (make-string (max 0 (- 4 (string-length ln))) #\space) " " name) )
+ info))
(define (source-info->line info)
(if (list? info)
- (cadr info)
- (and info (->string info))) )
+ (car info)
+ (and info (->string info))))
;;; We need this for constant folding:
@@ -1415,6 +1414,23 @@ EOF
(newline) )
+;;; Hook for source information
+
+(define (read-info-hook class data val)
+ (when (and (eq? 'list-info class) (symbol? (car data)))
+ (##sys#hash-table-set!
+ ##sys#line-number-database
+ (car data)
+ (alist-cons
+ data (conc ##sys#current-source-filename ":" val)
+ (or (##sys#hash-table-ref ##sys#line-number-database (car data))
+ '() ) ) ) )
+ data)
+
+(define (read/source-info in)
+ (##sys#read in read-info-hook) )
+
+
;;; "#> ... <#" syntax:
(set! ##sys#user-read-hook
diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm
index 2258554d..a1ed0f93 100644
--- a/tests/lolevel-tests.scm
+++ b/tests/lolevel-tests.scm
@@ -55,9 +55,9 @@
(assert (pointer=? some-chunk (address->pointer (pointer->address some-chunk))))
-; pointer-offset
+; pointer+
-(assert (pointer=? (address->pointer #x9) (pointer-offset (address->pointer #x5) #x4)))
+(assert (pointer=? (address->pointer #x9) (pointer+ (address->pointer #x5) #x4)))
; align-to-word
diff --git a/unboxing.scm b/unboxing.scm
index 28e6a65a..4efe84b8 100644
--- a/unboxing.scm
+++ b/unboxing.scm
@@ -35,7 +35,7 @@
(when (##sys#fudge 13)
(printf "[debug] ~?~%" fstr args)) )
-;(define-syntax d (syntax-rules () ((_ . _) (void))))
+(define-syntax d (syntax-rules () ((_ . _) (void))))
(define (perform-unboxing! node)
@@ -386,7 +386,7 @@
(syntax-rules ()
((_ (name atypes rtype alt) ...)
(begin
- (register-unboxed-op #f 'name 'atypes 'rtype 'alt) ...))))
+ (register-unboxed-op 'name 'atypes 'rtype 'alt) ...))))
(define (register-unboxed-op name atypes rtype alt)
(##sys#put! (symbolify name) '##compiler#unboxed-op (list alt atypes rtype)))
Trap