~ chicken-core (chicken-5) 5a40360d93ede5d85f9db33ae72634b7c077e7fc
commit 5a40360d93ede5d85f9db33ae72634b7c077e7fc
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Mar 9 04:33:10 2011 -0500
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Mar 9 04:33:10 2011 -0500
-emit-type-file; types.db work; type-declaration syntax; stripping/globalizing in type-declarations; type-validation
diff --git a/batch-driver.scm b/batch-driver.scm
index 4c7de665..13d78814 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -75,6 +75,8 @@
(time0 #f)
(time-breakdown #f)
(forms '())
+ (inline-output-file #f)
+ (type-output-file #f)
(cleanup-forms '(((##sys#implicit-exit-handler))))
(profile (or (memq 'profile options)
(memq 'accumulate-profile options)
@@ -224,6 +226,8 @@
(set! inline-locally #t) ; otherwise this option makes no sense
(set! local-definitions #t)
(set! inline-output-file (option-arg ifile)))
+ (and-let* ((tfile (memq 'emit-type-file options)))
+ (set! type-outout-file (option-arg tfile)))
(and-let* ([inlimit (memq 'inline-limit options)])
(set! inline-max-size
(let ([arg (option-arg inlimit)])
@@ -484,6 +488,10 @@
(when (memq 'check-syntax options) (exit))
+ (when type-output-file
+ (dribble "generating type file `~a' ..." type-output-file)
+ (emit-type-file type-output-file db))
+
(let ([proc (user-pass)])
(when proc
(dribble "User pass...")
@@ -500,7 +508,6 @@
(print-node "initial node tree" '|T| node0)
(initialize-analysis-database)
-<<<<<<< HEAD
(when (or do-scrutinize do-specialize)
;;;XXX hardcoded database file name
(unless (memq 'ignore-repository options)
diff --git a/c-platform.scm b/c-platform.scm
index a65c386a..9250e4c7 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -101,6 +101,7 @@
parenthesis-synonyms
prelude postlude prologue epilogue nursery extend feature no-feature types
emit-import-library emit-inline-file static-extension consult-inline-file
+ emit-type-file
heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path) )
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 20c9e822..136b45bc 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1110,6 +1110,25 @@
(##core#let-compiler-syntax (binding ...) body ...)))))
+;;; type-declaration syntax
+
+(##sys#extend-macro-environment ;XXX not documented yet
+ ': '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax ': x '(_ symbol _))
+ (let ((name (##sys#globalize (cadr x)))
+ (type (##sys#strip-syntax (caddr x))))
+ (validate-type type name)
+ (cond ((memq #:csi ##sys#features) '(##core#undefined))
+ (else
+ (when (and (pair? type)
+ (eq? 'procedure (car type))
+ (not (symbol? (cadr type))))
+ (set! type `(procedure ,(##sys#strip-syntax name) ,@(cdr type))))
+ `(##core#declare (type (,name ,type)))))))))
+
+
(##sys#macro-subset me0 ##sys#default-macro-environment)))
;; register features
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 679a62c8..b156ba30 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -108,6 +108,7 @@
emit-profile
emit-syntax-trace-info
emit-trace-info
+ emit-type-file
enable-inline-files
encode-literal
eq-inline-operator
@@ -165,6 +166,7 @@
get-line
get-line-2
get-list
+ globalize
hide-variable
immediate?
immutable-constants
@@ -175,7 +177,6 @@
inline-lambda-bindings
inline-locally
inline-max-size
- inline-output-file
inline-substitutions-enabled
inline-table
inline-table-used
@@ -199,6 +200,7 @@
make-variable-list
mark-variable
match-node
+ match-specialization
membership-test-operators
membership-unfold-limit
no-argc-checks
@@ -262,6 +264,7 @@
source-filename
source-info->string
source-info->line
+ specialize-node!
standalone-executable
string->c-identifier
string->expr
@@ -287,6 +290,7 @@
update-line-number-database
update-line-number-database!
used-units
+ validate-type
valid-c-identifier?
valid-compiler-options
valid-compiler-options-with-argument
diff --git a/compiler.scm b/compiler.scm
index 3d637c6d..2beb740a 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -332,7 +332,6 @@
(define standalone-executable #t)
(define local-definitions #f)
(define inline-locally #f)
-(define inline-output-file #f)
(define enable-inline-files #f)
(define compiler-syntax-enabled #t)
(define unchecked-specialized-arithmetic #f)
@@ -1262,24 +1261,17 @@
'() (##sys#current-environment) #f #f #f) ) )
-(define (process-declaration spec se) ; se unused in the moment
+(define (process-declaration spec se)
(define (check-decl spec minlen . maxlen)
(let ([n (length (cdr spec))])
(if (or (< n minlen) (> n (optional maxlen 99999)))
(syntax-error "invalid declaration" spec) ) ) )
(define (stripa x) ; global aliasing
- (globalize x))
+ (##sys#globalize x se))
(define (strip x) ; raw symbol
(##sys#strip-syntax x))
(define stripu ##sys#strip-syntax)
- (define (globalize sym)
- (if (symbol? sym)
- (let loop ((se se)) ; ignores syntax bindings
- (cond ((null? se) (##sys#alias-global-hook sym #f #f)) ;XXX could hint at decl (3rd arg)
- ((and (eq? sym (caar se)) (symbol? (cdar se))) (cdar se))
- (else (loop (cdr se)))))
- sym))
- (define (globalize-all syms) (map globalize syms))
+ (define (globalize-all syms) (map (cut ##sys#globalize <> se) syms))
(call-with-current-continuation
(lambda (return)
(unless (pair? spec)
@@ -1474,14 +1466,20 @@
((type)
(for-each
(lambda (spec)
- (cond ((and (list? spec) (symbol? (car spec)) (>= (length spec) 2))
- (##sys#put! (car spec) '##core#type (cadr spec))
- (##sys#put! (car spec) '##core#declared-type #t)
- (when (pair? (cddr spec))
- (##sys#put! (car spec) '##core#specializations (cddr spec))))
- (else
- (warning "illegal type declaration item" spec))))
- (globalize-all (cdr spec))))
+ (if (not (and (list? spec) (>= 2 (length spec)) (symbol? (car spec))))
+ (warning "illegal type declaration" (##sys#strip-syntax spec))
+ (let ((name (globalize (car spec)))
+ (type (##sys#strip-syntax (cadr spec))))
+ (cond ((validate-type type name)
+ (##sys#put! name '##core#type type)
+ (##sys#put! name '##core#declared-type #t)
+ (when (pair? (cddr spec))
+ (##sys#put!
+ name '##core#specializations
+ (##sys#strip-syntax (cddr spec)))))
+ (else
+ (warning "illegal type declaration" (##sys#strip-syntax spec)))))))
+ (cdr spec)))
((unsafe-specialized-arithmetic)
(set! unchecked-specialized-arithmetic #t))
(else (warning "illegal declaration specifier" spec)) )
diff --git a/csc.scm b/csc.scm
index bc840c79..626c46df 100644
--- a/csc.scm
+++ b/csc.scm
@@ -145,7 +145,7 @@
'(-debug -output-file -heap-size -nursery -stack-size -compiler -unit -uses -keyword-style
-optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue
-inline-limit -profile-name
- -emit-inline-file -types
+ -emit-inline-file -types -emit-type-file
-feature -debug-level -heap-growth -heap-shrinkage -heap-initial-size -consult-inline-file
-emit-import-library
-no-feature))
@@ -374,6 +374,7 @@ Usage: #{csc} FILENAME | OPTION ...
-n -emit-inline-file FILENAME generate file with globally inlinable
procedures (implies -inline -local)
-consult-inline-file FILENAME explicitly load inline file
+ -emit-type-file FILENAME write type-declaration information into file
-no-argc-checks disable argument count checks
-no-bound-checks disable bound variable checks
-no-procedure-checks disable procedure call checks
diff --git a/expand.scm b/expand.scm
index 4424e084..921a6d3c 100644
--- a/expand.scm
+++ b/expand.scm
@@ -123,6 +123,17 @@
(append (map (lambda (x y) (cons x y)) vars aliases) se)) ; inline cons
+;;; resolve symbol to global name
+
+(define (##sys#globalize sym se)
+ (if (symbol? sym)
+ (let loop ((se se)) ; ignores syntax bindings
+ (cond ((null? se) (##sys#alias-global-hook sym #f #f)) ;XXX could hint at decl (3rd arg)
+ ((and (eq? sym (caar se)) (symbol? (cdar se))) (cdar se))
+ (else (loop (cdr se)))))
+ sym))
+
+
;;; Macro handling
(define ##sys#macro-environment (make-parameter '()))
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 1c1832e5..a785b4ed 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -743,3 +743,28 @@
((eq? 'quote (car x)) x) ; to handle numeric constants
(else (cons (subst (car x)) (subst (cdr x))))))
(copy-node! (build-node-graph (subst template)) node)))
+
+(define (validate-type type name)
+ (define (validate t)
+ (cond ((memq t '(* string symbol char number boolean list pair
+ procedure vector null eof undefined port blob
+ pointer locative fixnum float pointer-vector deprecated)))
+ ((not (pair? t)) #f)
+ ((eq? 'or (car t))
+ (and (list t)
+ (every validate (cdr t))))
+ ((eq? 'struct (car t))
+ (and (= 2 (length t)) (symbol? (cadr t))))
+ ((eq? 'procedure (car t))
+ (and (pair? (cdr t))
+ (let ((t (if (symbol? (cadr t)) (cddr t) (cdr t))))
+ (and (pair? t)
+ (list? (car t))
+ (every
+ validate
+ (remove (cut memq <> '(#!optional #!rest values)) (car t)))
+ (or (eq? '* (cddr t))
+ (and (list? (cddr t))
+ (every validate (cddr t))))))))
+ (else #f)))
+ (validate type))
diff --git a/support.scm b/support.scm
index e8d07231..e79395a8 100644
--- a/support.scm
+++ b/support.scm
@@ -736,6 +736,23 @@
(loop)))))))
+;;; write declared types to file
+
+(define (emit-type-file filename db)
+ (with-output-to-file filename
+ (lambda ()
+ (print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
+ source-filename "\n")
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (when (variable-visible? sym)
+ (and-let* ((type (variable-mark sym '##core#declared-type)))
+ (let ((specs (or (variable-mark sym '##core#specializations) '())))
+ (pp (cons* sym type specs))))))
+ db)
+ (print "; END OF FILE"))))
+
+
;;; Match node-structure with pattern:
(define (match-node node pat vars)
@@ -1504,6 +1521,7 @@ Usage: chicken FILENAME OPTION ...
-no-lambda-info omit additional procedure-information
-scrutinize perform local flow analysis for static checks
-types FILENAME load additional type database
+ -emit-type-file FILENAME write type-declaration information into file
Optimization options:
diff --git a/types.db b/types.db
index d8cb229c..45035e41 100644
--- a/types.db
+++ b/types.db
@@ -425,10 +425,7 @@
(arithmetic-shift (procedure arithmetic-shift (number number) number))
(bit-set? (procedure bit-set? (number fixnum) boolean)
- ((fixnum fixnum)
- (not (eq? 0 (##core#inline
- "C_fixnum_and" #(1)
- (##core#inline "C_fixnum_shift_left" 1 #(2)))))))
+ ((fixnum fixnum) (##core#inline "C_u_i_bit_setp" #(1) #(2))))
(bitwise-and (procedure bitwise-and (#!rest number) number)
((fixnum fixnum) (##core#inline "C_fixnum_and" #(1) #(2))))
@@ -1324,7 +1321,6 @@
;; srfi-1
-;;XXX...
(alist-cons (procedure alist-cons (* * *) list))
(alist-copy (procedure alist-copy (list) list))
(alist-delete (procedure alist-delete (* list #!optional (procedure (* *) *)) list))
@@ -1339,7 +1335,10 @@
(break! (procedure break! ((procedure (*) *) list) list list))
(car+cdr (procedure car+cdr (pair) * *))
(circular-list (procedure circular-list (#!rest) list))
-(circular-list? (procedure circular-list? (*) boolean))
+
+(circular-list? (procedure circular-list? (*) boolean)
+ ((null) (let ((#:tmp #(1))) #f)))
+
(concatenate (procedure concatenate (list) list))
(concatenate! (procedure concatenate! (list) list))
(cons* (procedure cons* (* #!rest) pair))
@@ -1361,7 +1360,10 @@
(filter-map (procedure filter-map ((procedure (* #!rest) *) list #!rest list) list))
(find (procedure find ((procedure (*) *) list) *))
(find-tail (procedure find-tail ((procedure (*) *) list) *))
-(first (procedure first (pair) *))
+
+(first (procedure first (pair) *)
+ ((pair) (##core#inline "C_u_i_car" #(1))))
+
(fold (procedure fold ((procedure (* #!rest) *) * #!rest list) *))
(fold-right (procedure fold-right ((procedure (* #!rest) *) * #!rest list) *))
(fourth (procedure fourth (pair) *))
@@ -1390,14 +1392,25 @@
(map! (procedure map! ((procedure (*) *) list #!rest list) list))
(map-in-order (procedure map-in-order ((procedure (*) *) list #!rest list) list))
(ninth (procedure ninth (pair) *))
-(not-pair? (procedure not-pair? (*) boolean))
-(null-list? (procedure null-list? (list) boolean))
+
+(not-pair? (procedure not-pair? (*) boolean)
+ ((pair) (let ((#:tmp #(1))) #f))
+ (((not pair)) (let ((#:tmp #(1))) #t)))
+
+(null-list? (procedure null-list? (list) boolean)
+ ((pair) (let ((#:tmp #(1))) #f))
+ ((list) (let ((#:tmp #(1))) #f))
+ ((null) (let ((#:tmp #(1))) #t)))
+
(pair-fold (procedure pair-fold (procedure * list #!rest list) *))
(pair-fold-right (procedure pair-fold-right (procedure * list #!rest list) *))
(pair-for-each (procedure pair-for-each ((procedure (#!rest) . *) list #!rest list) undefined))
(partition (procedure partition ((procedure (*) *) list) list list))
(partition! (procedure partition! ((procedure (*) *) list) list list))
-(proper-list? (procedure proper-list? (*) boolean))
+
+(proper-list? (procedure proper-list? (*) boolean)
+ ((null) (let ((#:tmp #(1))) #t)))
+
(reduce (procedure reduce ((procedure (* *) *) * list) *))
(reduce-right (procedure reduce-right ((procedure (* *) *) * list) *))
(remove (procedure remove ((procedure (*) *) list) list))
@@ -1424,11 +1437,12 @@
(unzip3 (procedure unzip3 (list) list list list))
(unzip4 (procedure unzip4 (list) list list list list))
(unzip5 (procedure unzip5 (list) list list list list list))
-(xcons (procedure xcons (* *) pair))
+(xcons (procedure xcons (* *) pair)
(zip (procedure zip (list #!rest list) list))
;; srfi-13
+;;XXX...
(check-substring-spec (procedure check-substring-spec (* string fixnum fixnum) undefined))
(kmp-step (procedure kmp-step (string vector char fixnum (procedure (char char) *) fixnum) fixnum))
(make-kmp-restart-vector (procedure make-kmp-restart-vector (string #!optional (procedure (* *) *) fixnum fixnum) vector))
Trap