Changeset 10712 in project
- Timestamp:
- 05/05/08 20:20:23 (13 years ago)
- Location:
- chicken/branches/hygienic
- Files:
-
- 30 edited
Legend:
- Unmodified
- Added
- Removed
-
chicken/branches/hygienic/TODO
r10658 r10712 5 5 * test line-number retention over macro-expansion 6 6 7 * syntax-error 8 ** if ##sys#current-module is set, add name to error message 9 10 * move module-tests into tests/ directory (add to runtests.sh) 11 7 12 * modules 8 ** implement for compiler 9 *** hide unexported module definitions 13 ** checks 14 *** exported id not defined 15 *** redefinition of imported id 16 *** multiple definition of export 17 ** hide unexported module definitions 18 ** support for re-exports of imported bindings 19 fixup vexport/sexport lists 20 ** support for "import-libraries" 21 *** write compiled module registration to extra file 22 *** declaration 23 (emit-import-library [MODULE | (MODULE FILENAME) ...]) 24 *** option 25 -emit-import-library MODULE 26 ** import specs 27 (import SPEC) 28 SPEC = MODULE 29 | (hide SPEC ID1 ...) 30 | (subset SPEC ID1 ...) 31 | (rename SPEC (IDOLD1 IDNEW1) ...) 32 | (prefix SPEC PREFIX) 10 33 11 34 * update manual/NEWS … … 15 38 *** user defined ellipsis 16 39 *** define-compiled-syntax 40 *** modules 17 41 ** ack synrules authors 18 42 ** removals 19 run-time and compile-time situations for eval-when 20 define-foreign-record 21 define-foreign-enum 22 define-record 23 define-macro 43 *** run-time and compile-time situations for eval-when 44 *** syntax 45 define-foreign-record 46 define-foreign-enum 47 define-record 48 define-macro 49 *** compiler options 50 -check-imports 51 -emit-exports 52 -import 24 53 25 54 * csi -
chicken/branches/hygienic/batch-driver.scm
r10629 r10712 37 37 non-foldable-standard-bindings foldable-standard-bindings non-foldable-extended-bindings foldable-extended-bindings 38 38 standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false 39 compiler-cleanup-hook check-global-exports disabled-warnings check-global-imports39 compiler-cleanup-hook disabled-warnings 40 40 file-io-only undefine-shadowed-macros 41 41 unit-name insert-timer-checks used-units inline-max-size … … 65 65 default-declarations units-used-by-default words-per-flonum default-debugging-declarations 66 66 default-profiling-declarations default-optimization-passes 67 inline-max-size file-requirements use-import-table lookup-exports-file67 inline-max-size file-requirements 68 68 foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators 69 69 membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument … … 215 215 (when (memq 't debugging-chicken) (##sys#start-timer)) 216 216 (when (memq 'b debugging-chicken) (set! time-breakdown #t)) 217 ( and-let* ((xfile (memq 'emit-exports options)))218 ( set! export-file-name (cadr xfile)) )217 (when (memq 'emit-exports options) 218 (warning "deprecated compiler option: emit-exports") ) 219 219 (when (memq 'raw options) 220 220 (set! explicit-use-flag #t) … … 223 223 (when (memq 'no-lambda-info options) 224 224 (set! emit-closure-info #f) ) 225 (set! use-import-table (memq 'check-imports options)) 226 (let ((imps (collect-options 'import))) 227 (when (pair? imps) 228 (set! use-import-table #t) 229 (for-each lookup-exports-file imps) ) ) 225 (when (memq 'check-imports options) 226 (compiler-warning 'usage "deprecated compiler option: -check-imports")) 227 (when (memq 'import options) 228 (compiler-warning 'usage "deprecated compiler option: -import")) 230 229 (set! disabled-warnings (map string->symbol (collect-options 'disable-warning))) 231 230 (when (memq 'no-warnings options) … … 529 528 (let ([db (analyze 'opt node2 i progress)]) 530 529 (when first-analysis 531 (when use-import-table (check-global-imports db))532 (check-global-exports db)533 530 (when (memq 'u debugging-chicken) 534 531 (dump-undefined-globals db)) ) … … 571 568 (when (and ##sys#warnings-enabled (> (- (cputime) start-time) funny-message-timeout)) 572 569 (display "(do not worry - still compiling...)\n") ) 573 (when export-file-name574 (dump-exported-globals db export-file-name) )575 570 (when a-only (exit 0)) 576 571 (print-node "closure-converted" '|9| node3) -
chicken/branches/hygienic/chicken-ffi-macros.scm
r10532 r10712 173 173 (bad) ) ) 174 174 (bad) ) 175 '(## sys#void) ) ) ) )175 '(##core#undefined) ) ) ) ) -
chicken/branches/hygienic/chicken-more-macros.scm
r10557 r10712 157 157 ,@(map (lambda (id nt) `(##core#set! ,id ,nt)) 158 158 ids new-tmps) 159 (## sys#void) )159 (##core#undefined) ) 160 160 (,%lambda () ,@body) 161 161 (,%lambda () … … 164 164 ,@(map (lambda (id ot) `(##core#set! ,id ,ot)) 165 165 ids old-tmps) 166 (## sys#void) ) ) ) ) )))166 (##core#undefined) ) ) ) ) ))) 167 167 168 168 (##sys#extend-macro-environment … … 834 834 (if (memq sname vars) 835 835 sname 836 '(## sys#void) ) )836 '(##core#undefined) ) ) 837 837 slotnames) ) ) 838 838 (,%define (,pred ,x) (##sys#structure? ,x ',t)) … … 1024 1024 (let ((head (cadr form)) 1025 1025 (body (cddr form))) 1026 (let* ((body (if (null? body) '((## sys#void)) body))1026 (let* ((body (if (null? body) '((##core#undefined)) body)) 1027 1027 (name (if (pair? head) (car head) head)) 1028 1028 (body (if (pair? head) … … 1034 1034 (if ##sys#enable-runtime-macros 1035 1035 `(,(r 'define) ,name ,body) 1036 '(## sys#void)))))))1036 '(##core#undefined))))))) 1037 1037 1038 1038 -
chicken/branches/hygienic/chicken-setup.scm
r10629 r10712 630 630 631 631 (define (write-info id files info) 632 (let-values (((exports info) (fix-exports id info)))633 632 (let ((info `((files ,@files) 634 ,@exports635 633 ,@(or (and-let* (*repository-tree* 636 634 (a (assq id *repository-tree*)) … … 645 643 (cut pp info)))) 646 644 (unless *windows-shell* (run (chmod a+r ,(quotewrap setup-file)))) 647 write-setup-info)))) 648 649 (define (fix-exports id info) 650 (let-values (((einfo oinfo) (partition (lambda (item) (eq? 'exports (car item))) info))) 651 (let ((exports 652 (if (pair? einfo) 653 (append-map 654 (lambda (eitem) 655 (let loop ((exports (cdr eitem))) 656 (if (null? exports) 657 '() 658 (let ((x (car exports)) 659 (rest (cdr exports)) ) 660 (cond ((string? x) (append (read-file x) (loop rest))) 661 ((symbol? x) (cons x (loop rest))) 662 (else (error "invalid export item" x)) ) ) ) ) ) 663 einfo) 664 (and-let* ((f (file-exists? (make-pathname #f (->string id) "exports")))) 665 (read-file f) ) ) ) ) 666 (if exports 667 (values `((exports ,@exports)) oinfo) 668 (values '() oinfo) ) ) ) ) 645 write-setup-info))) 669 646 670 647 (define (compute-builddir fpath) -
chicken/branches/hygienic/compiler.scm
r10657 r10712 66 66 ; (data <tag1> <exp1> ...) 67 67 ; (post-process <string> ...) 68 ; (emit-exports <string>)69 68 ; (keep-shadowed-macros) 70 69 ; (import <symbol-or-string> ...) … … 119 118 ; (##coresyntax <exp>) 120 119 ; (<exp> {<exp>}) 121 ; (define-syntax <symbol> <ewxo>) 122 ; (define-compiled-syntax <symbol> <ewxo>) 120 ; (define-syntax <symbol> <expr>) 121 ; (define-compiled-syntax <symbol> <expr>) 122 ; (##core#module <symbol> (<name> | (<name> ...) ...) <body>) 123 123 ; 124 124 ; - Core language: … … 266 266 direct-call-ids foreign-type-table first-analysis callback-names disabled-warnings 267 267 initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database! scan-toplevel-assignments 268 compiler-warning import-table use-import-tablecompiler-macro-table compiler-macros-enabled268 compiler-warning compiler-macro-table compiler-macros-enabled 269 269 perform-cps-conversion analyze-expression simplifications perform-high-level-optimizations perform-pre-optimization! 270 270 reorganize-recursive-bindings substitution-table simplify-named-call inline-max-size … … 288 288 make-random-name final-foreign-type real-name-table real-name set-real-name! safe-globals-flag 289 289 location-pointer-map literal-rewrite-hook 290 lookup-exports-fileundefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info290 undefine-shadowed-macros process-lambda-documentation emit-syntax-trace-info 291 291 generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration 292 process-custom-declaration do-lambda-lifting file-requirements emit-closure-info export-file-name292 process-custom-declaration do-lambda-lifting file-requirements emit-closure-info 293 293 foreign-argument-conversion foreign-result-conversion foreign-type-convert-argument foreign-type-convert-result 294 294 big-fixnum?) … … 324 324 (define-constant file-requirements-size 301) 325 325 (define-constant real-name-table-size 997) 326 (define-constant import-table-size 997)327 326 (define-constant default-inline-max-size 10) 328 327 … … 363 362 (define inline-max-size -1) 364 363 (define emit-closure-info #t) 365 (define export-file-name #f)366 (define import-table #f)367 (define use-import-table #f)368 364 (define undefine-shadowed-macros #t) 369 365 (define constant-declarations '()) … … 441 437 (vector-fill! file-requirements '()) 442 438 (set! file-requirements (make-vector file-requirements-size '())) ) 443 (if import-table444 (vector-fill! import-table '())445 (set! import-table (make-vector import-table-size '())) )446 439 (if foreign-type-table 447 440 (vector-fill! foreign-type-table '()) … … 486 479 (define (resolve-variable x0 se dest) 487 480 (let ((x (lookup x0 se))) 488 (cond ((not (symbol? x)) x0) 481 (cond ((not (symbol? x)) x0) ; syntax? 489 482 [(and constants-used (##sys#hash-table-ref constant-table x)) 490 483 => (lambda (val) (walk (car val) se dest)) ] … … 507 500 (finish-foreign-result ft body) 508 501 t) ) ) ] 509 [else (##sys#alias-global-hook x)]))) 502 ((not (assq x0 se)) (##sys#alias-global-hook x)) ; only globals 503 (else x)))) 510 504 511 505 (define (eval/meta form) … … 597 591 id 'require-extension) #f)) ) ) ) 598 592 (compiler-warning 599 'ext "extension `~A' is currently not installed" id) 600 (unless (and-let* (use-import-table 601 ((symbol? id)) 602 (info (##sys#extension-information id #f)) 603 (exps (assq 'exports info)) ) 604 (for-each 605 (cut ##sys#hash-table-set! import-table <> id) 606 (cdr exps) ) 607 #t) 608 (lookup-exports-file id) ) ) 593 'ext "extension `~A' is currently not installed" id)) 609 594 `(begin ,exp ,(loop (cdr ids))) ) ) ) ) 610 595 se dest) ) … … 612 597 ((let) 613 598 (##sys#check-syntax 'let x '(let #((variable _) 0) . #(_ 1)) #f se) 614 (let* ( [bindings (cadr x)]615 [vars (unzip1 bindings)]616 [aliases (map gensym vars)]599 (let* ((bindings (cadr x)) 600 (vars (unzip1 bindings)) 601 (aliases (map gensym vars)) 617 602 (se2 (append (map cons vars aliases) se)) ) 618 603 (set-real-names! aliases vars) … … 626 611 ((lambda ##core#internal-lambda) 627 612 (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se) 628 (let ( [llist (cadr x)]629 [obody (cddr x)])613 (let ((llist (cadr x)) 614 (obody (cddr x)) ) 630 615 (when (##sys#extended-lambda-list? llist) 631 616 (set!-values … … 701 686 ((define-syntax) 702 687 (##sys#check-syntax 'define-syntax x '(define-syntax variable _) #f se) 703 (##sys#extend-macro-environment 704 (lookup (cadr x) se) 705 (##sys#current-environment) 706 (##sys#er-transformer 707 (eval/meta (caddr x)))) 708 (walk 709 (if ##sys#enable-runtime-macros 710 `(##sys#extend-macro-environment 711 ',(cadr x) 712 (##sys#current-environment) 713 (##sys#er-transformer 714 ,(caddr x))) ;*** possibly wrong se? 715 '(##core#undefined) ) 716 se dest)) 688 (let ((name (lookup (cadr x) se)) 689 (tx (caddr x))) 690 (##sys#extend-macro-environment 691 name 692 (##sys#current-environment) 693 (##sys#er-transformer (eval/meta tx))) 694 (##sys#register-export name (##sys#current-module) tx) 695 (walk 696 (if ##sys#enable-runtime-macros 697 `(##sys#extend-macro-environment 698 ',(cadr x) 699 (##sys#current-environment) 700 (##sys#er-transformer 701 ,tx)) ;*** possibly wrong se? 702 '(##core#undefined) ) 703 se dest)) ) 717 704 718 705 ((define-compiled-syntax) 719 706 (##sys#check-syntax 'define-compiled-syntax x '(_ variable _) #f se) 720 (##sys#extend-macro-environment 721 (lookup (cadr x) se) 722 (##sys#current-environment) 723 (##sys#er-transformer 724 (eval/meta (caddr x)))) 725 (walk 726 `(##sys#extend-macro-environment 727 ',(cadr x) 707 (let ((name (lookup (cadr x) se)) 708 (tx (caddr x))) 709 (##sys#extend-macro-environment 710 name 728 711 (##sys#current-environment) 729 (##sys#er-transformer 730 ,(caddr x))) ;*** possibly wrong se? 731 se dest)) 712 (##sys#er-transformer (eval/meta tx))) 713 (##sys#register-export name (##sys#current-module) tx) 714 (walk 715 `(##sys#extend-macro-environment 716 ',(cadr x) 717 (##sys#current-environment) 718 (##sys#er-transformer 719 ,tx)) ;*** possibly wrong se? 720 se dest))) 721 722 ((##core#module) 723 (let* ((name (lookup (cadr x) se)) 724 (exports 725 (map (lambda (exp) 726 (cond ((symbol? exp) (lookup exp se)) 727 ((and (pair? exp) (symbol? (car exp))) 728 (map (cut lookup <> se) exp) ) 729 (else 730 (##sys#syntax-error-hook 731 'module 732 "invalid export syntax" exp name)))) 733 (caddr x))) 734 (me0 ##sys#macro-environment)) 735 (when (pair? se) 736 (##sys#syntax-error-hook 'module "module definition not in toplevel scope" 737 name)) 738 (let-values (((body mreg) 739 (parameterize ((##sys#current-module 740 (##sys#register-module name exports) ) 741 (##sys#import-environment '())) 742 (fluid-let ((##sys#macro-environment ;*** make parameter later 743 ##sys#macro-environment)) 744 (let loop ((body (cdddr x)) (xs '())) 745 (cond 746 ((null? body) 747 (##sys#finalize-module (##sys#current-module) me0) 748 (values 749 (reverse xs) 750 (walk 751 (##sys#compiled-module-registration (##sys#current-module)) 752 (##sys#current-meta-environment) 753 #f) ) ) 754 (else 755 (loop 756 (cdr body) 757 (cons (walk (car body) se #f) xs))))))))) 758 (canonicalize-begin-body 759 (append (list mreg) body))))) 732 760 733 761 ((##core#named-lambda) 734 762 (walk `(,(macro-alias 'lambda se) ,@(cddr x)) se (cadr x)) ) 735 763 736 737 738 739 740 741 742 743 744 745 746 764 ((##core#loop-lambda) 765 (let* ([vars (cadr x)] 766 [obody (cddr x)] 767 [aliases (map gensym vars)] 768 (se2 (append (map cons vars aliases) se)) 769 [body 770 (walk 771 (##sys#canonicalize-body obody se2) 772 se2 #f) ] ) 773 (set-real-names! aliases vars) 774 `(lambda ,aliases ,body) ) ) 747 775 748 776 ((set! ##core#set!) … … 1137 1165 (let ((us (cdr spec))) 1138 1166 (apply register-feature! us) 1139 (when use-import-table1140 (for-each lookup-exports-file us) )1141 1167 (when (pair? us) 1142 1168 (##sys#hash-table-update! file-requirements 'uses (cut lset-union eq? us <>) (lambda () us)) … … 1264 1290 (set! block-globals (lset-difference eq? block-globals syms)) 1265 1291 (set! export-list (lset-union eq? syms (or export-list '()))))) 1266 ((emit-exports)1267 (cond ((null? (cdr spec))1268 (quit "invalid `emit-exports' declaration" spec) )1269 ((not export-file-name)1270 (set! export-file-name (cadr spec))) ) )1271 1292 ((emit-external-prototypes-first) 1272 1293 (set! external-protos-first #t) ) … … 1289 1310 (set! constant-declarations (append syms constant-declarations)) 1290 1311 (quit "invalid arguments to `constant' declaration: ~S" spec)) ) ) 1291 ((import)1292 (let-values (((syms strs)1293 (partition1294 (lambda (x)1295 (cond ((symbol? x) #t)1296 ((string? x) #f)1297 (else (quit "argument to `import' declaration is not a string or symbol" x)) ) )1298 (cdr spec) ) ) )1299 (set! use-import-table #t)1300 (for-each1301 (cut ##sys#hash-table-set! import-table <> "<here>")1302 syms)1303 (for-each lookup-exports-file strs) ) )1304 1312 (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) ) 1305 1313 '(##core#undefined) ) ) ) -
chicken/branches/hygienic/csc.scm
r10629 r10712 175 175 -block -disable-interrupts -fixnum-arithmetic -to-stdout -profile -raw -accumulate-profile 176 176 -check-syntax -case-insensitive -benchmark-mode -shared -compile-syntax -no-lambda-info 177 -lambda-lift -dynamic -disable-stack-overflow-checks -emit-debug-info -check-imports 177 -lambda-lift -dynamic -disable-stack-overflow-checks -emit-debug-info 178 -check-imports ; DEPRECATED 178 179 -emit-external-prototypes-first -inline -extension -release -static-extensions 179 180 -analyze-only -keep-shadowed-macros -disable-compiler-macros) ) … … 182 183 '(-debug -output-file -heap-size -nursery -stack-size -compiler -unit -uses -keyword-style 183 184 -optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue 184 -inline-limit -profile-name -disable-warning -import -require-static-extension 185 -feature -debug-level -heap-growth -heap-shrinkage -heap-initial-size -emit-exports 186 -compress-literals) ) ; DEPRECATED 185 -inline-limit -profile-name -disable-warning 186 -import ; DEPRECATED 187 -require-static-extension 188 -feature -debug-level -heap-growth -heap-shrinkage -heap-initial-size 189 -emit-exports -compress-literals) ) ; DEPRECATED 187 190 188 191 (define-constant shortcuts … … 199 202 (|-X| "-extend") 200 203 (|-N| "-no-usual-integrations") 201 (|-G| "-check-imports") 204 (|-G| "-check-imports") ; DEPRECATED 202 205 (-x "-explicit-use") 203 206 (-u "-unsafe") … … 368 371 -profile-name FILENAME name of the generated profile information file 369 372 -emit-debug-info emit additional debug-information 370 -emit-exports FILENAME write exported toplevel variables to FILENAME371 -G -check-imports look for undefined toplevel variables372 -import FILENAME read externally exported symbols from FILENAME373 373 374 374 Optimization options: -
chicken/branches/hygienic/data-structures.scm
r10624 r10712 71 71 72 72 (include "unsafe-declarations.scm") 73 74 (cond-expand75 ((not unsafe)76 (declare (emit-exports "data-structures.exports")) )77 (else))78 73 79 74 (register-feature! 'data-structures) -
chicken/branches/hygienic/distribution/manifest
r10629 r10712 54 54 csi.c 55 55 eval.c 56 eval.exports57 56 data-structures.c 58 data-structures.exports59 57 extras.c 60 extras.exports61 58 library.c 62 library.exports63 59 lolevel.c 64 lolevel.exports65 60 optimizer.c 66 61 regex.c 67 regex.exports68 62 posixunix.c 69 posix.exports70 63 posixwin.c 71 64 profiler.c 72 65 scheduler.c 73 scheduler.exports74 66 srfi-69.c 75 srfi-69.exports76 67 srfi-1.c 77 srfi-1.exports78 68 srfi-13.c 79 srfi-13.exports80 69 srfi-14.c 81 srfi-14.exports82 70 srfi-18.c 83 srfi-18.exports84 71 srfi-4.c 85 srfi-4.exports86 72 stub.c 87 73 support.c 88 74 tcp.c 89 tcp.exports90 75 ueval.c 91 76 uextras.c … … 104 89 utcp.c 105 90 utils.c 106 utils.exports107 91 uutils.c 108 92 build.scm -
chicken/branches/hygienic/eval.scm
r10658 r10712 96 96 97 97 (include "unsafe-declarations.scm") 98 99 (cond-expand100 ((not unsafe) (declare (emit-exports "eval.exports")))101 (else))102 98 103 99 (define-foreign-variable install-egg-home c-string "C_INSTALL_EGG_HOME") … … 618 614 ((##core#module) 619 615 (let* ((name (rename (cadr x) se)) 620 (exports621 (map (lambda (exp)622 (cond ((symbol? exp) (rename exp se))623 ((and (pair? exp) (symbol? (car exp)))624 616 (exports 617 (map (lambda (exp) 618 (cond ((symbol? exp) (rename exp se)) 619 ((and (pair? exp) (symbol? (car exp))) 620 (map (cut rename <> se) exp) ) 625 621 (else 626 622 (##sys#syntax-error-hook 627 623 'module 628 624 "invalid export syntax" exp name)))) 629 (caddr x))) 630 (me0 ##sys#macro-environment)) 625 (caddr x))) 626 (me0 ##sys#macro-environment)) 627 (when (pair? se) 628 (##sys#syntax-error-hook 'module "module definition not in toplevel scope" 629 name)) 631 630 (parameterize ((##sys#current-module 632 631 (##sys#register-module name exports) ) … … 643 642 (let loop2 ((xs xs)) 644 643 (if (null? xs) 645 (##sys#void) )646 647 648 649 650 651 ((##sys#slot xs 0) v)))))))644 (##sys#void) 645 (let ((n (##sys#slot xs 1))) 646 (cond ((pair? n) 647 ((##sys#slot xs 0) v) 648 (loop2 n)) 649 (else 650 ((##sys#slot xs 0) v)))))))) 652 651 (loop 653 652 (cdr body) … … 1158 1157 (memq id builtin-features/compiled) 1159 1158 (##sys#feature? id) ) ) 1160 (values '(## sys#void) #t) )1159 (values '(##core#undefined) #t) ) 1161 1160 ((memq id special-syntax-files) 1162 1161 (let ((fid (##sys#->feature-id id))) … … 1164 1163 (##sys#load (##sys#resolve-include-filename (##sys#symbol->string id) #t) #f #f) 1165 1164 (set! ##sys#features (cons fid ##sys#features)) ) 1166 (values '(## sys#void) #t) ) )1165 (values '(##core#undefined) #t) ) ) 1167 1166 ((memq id ##sys#core-library-modules) 1168 1167 (values … … 1266 1265 (error "installed extension does not match required version" id vv (caddr spec))) 1267 1266 id) 1268 ( syntax-error'require-extension "invalid version specification" spec)) ) )1267 (##sys#syntax-error-hook 'require-extension "invalid version specification" spec)) ) ) 1269 1268 1270 1269 -
chicken/branches/hygienic/expand.scm
r10658 r10712 440 440 (cons (if (pair? (cddr x)) 441 441 (caddr x) 442 '(## sys#void) )442 '(##core#undefined) ) 443 443 vals) 444 444 mvars mvals) ] … … 651 651 (##sys#check-syntax 'define body '#(_ 0 1)) 652 652 (##sys#register-export head (##sys#current-module)) 653 `(##core#set! ,head ,(if (pair? body) (car body) '(## sys#void))) )653 `(##core#set! ,head ,(if (pair? body) (car body) '(##core#undefined))) ) 654 654 ((pair? (car head)) 655 655 (##sys#check-syntax 'define head '(_ . lambda-list)) … … 966 966 (set! ##sys#macro-environment 967 967 (append (module-sexports mod) ##sys#macro-environment)) 968 '(## sys#void)))))968 '(##core#undefined))))) 969 969 970 970 (##sys#extend-macro-environment … … 973 973 (##sys#er-transformer 974 974 (lambda (x r c) 975 (##sys#check-syntax 'module x '(_ symbol #(symbol 0) . #(_ 1)))975 (##sys#check-syntax 'module x '(_ symbol #(symbol 0) . #(_ 0))) 976 976 `(##core#module ,@(cdr x))))) 977 977 … … 995 995 (make-module name export-list defined-list vexports sexports) 996 996 module? 997 (name module-name) 998 (export-list module-export-list) 999 (defined-list module-defined-list set-module-defined-list!) 1000 (vexports module-vexports set-module-vexports!) 1001 (sexports module-sexports set-module-sexports!) ) 997 (name module-name) ; SYMBOL 998 (export-list module-export-list) ; (SYMBOL | (SYMBOL ...) ...) 999 (defined-list module-defined-list set-module-defined-list!) ; ((SYMBOL . VALUE) ...) 1000 (vexports module-vexports set-module-vexports!) ; (SYMBOL . SYMBOL) 1001 (sexports module-sexports set-module-sexports!) ) ; ((SYMBOL SE TRANSFORMER) ...) 1002 1002 1003 1003 (define (##sys#find-module name) … … 1005 1005 (else (error 'import "module not found" name)))) 1006 1006 1007 (define (##sys#register-export sym mod )1007 (define (##sys#register-export sym mod #!optional val) 1008 1008 (when mod 1009 1009 (when (##sys#find-export sym mod) 1010 1010 (d "defined: " sym) 1011 (set-module-defined-list! mod (cons sym (module-defined-list mod)))))) 1011 (set-module-defined-list! 1012 mod 1013 (cons (cons sym val) 1014 (module-defined-list mod)))))) 1012 1015 1013 1016 (define (##sys#register-module name explist) … … 1015 1018 (set! ##sys#module-table (cons (cons name mod) ##sys#module-table)) 1016 1019 mod) ) 1020 1021 (define (##sys#compiled-module-registration mod) 1022 (let ((dlist (module-defined-list mod))) 1023 `(##sys#register-compiled-module 1024 ',(module-name mod) 1025 ',(module-vexports mod) 1026 (list 1027 ,@(map (lambda (sexport) 1028 (let* ((name (car sexport)) 1029 (a (assq name dlist))) 1030 (unless a 1031 (bomb "exported syntax has no source")) 1032 `(cons ',(car sexport) ,(cdr a)))) 1033 (module-sexports mod)))))) 1034 1035 (define (##sys#register-compiled-module name vexports sexports) 1036 (let ((mod (make-module 1037 name '() '() vexports 1038 (map (lambda (se) 1039 (list (car se) '() (##sys#er-transformer (cdr se)))) 1040 sexports)))) 1041 (set! ##sys#module-table (cons (cons name mod) ##sys#module-table)) 1042 mod)) 1017 1043 1018 1044 (define (##sys#find-export sym mod) … … 1044 1070 (for-each 1045 1071 (lambda (x) 1046 (unless ( memq (car x) dlist)1072 (unless (assq (car x) dlist) 1047 1073 (warning "exported identifier has not been defined" (car x)))) 1048 1074 vexports) 1049 (d `(EXPORTS: ,(module-name mod) ,(m odule-defined-list mod)1075 (d `(EXPORTS: ,(module-name mod) ,(map car dlist) 1050 1076 ,(map car vexports) ,(map car sexports))) 1051 1077 (set-module-vexports! mod vexports) -
chicken/branches/hygienic/library.scm
r10629 r10712 121 121 EOF 122 122 ) ) 123 124 (cond-expand125 ((not unsafe)126 (declare (emit-exports "library.exports")))127 (else) )128 123 129 124 (cond-expand -
chicken/branches/hygienic/lolevel.scm
r10629 r10712 63 63 64 64 (include "unsafe-declarations.scm") 65 66 (cond-expand67 ((not unsafe)68 (declare (emit-exports "lolevel.exports")))69 (else))70 65 71 66 (register-feature! 'lolevel) -
chicken/branches/hygienic/module-tests.scm
r10658 r10712 2 2 3 3 4 ( load"tests/test.scm")4 (include "tests/test.scm") 5 5 6 6 (test-begin "modules") … … 9 9 (module foo (abc def) 10 10 (import scheme) 11 (define (abc x) 12 (display x) 13 (newline) 14 x) 11 (define (abc x) (+ x 33)) 15 12 (define-syntax def 16 13 (syntax-rules () 17 ((_ x) 18 (begin 19 (display "(def) ") 20 (abc x))))) 14 ((_ x) (+ 99 (abc x))))) 21 15 (abc 1)) 22 1)16 34) 23 17 24 18 (test-error "external/unimported variable (fail)" (abc 2)) … … 26 20 27 21 (import foo) 28 (test-equal "external/imported variable" (abc 4) 4)29 22 30 (test-equal "external/imported syntax" (def 5) 5) 23 (test-equal "external/imported variable" (abc 4) 37) 24 (test-equal "external/imported syntax" (def 5) 137) 31 25 32 26 (test-end "modules") -
chicken/branches/hygienic/posixunix.scm
r10629 r10712 490 490 491 491 (include "unsafe-declarations.scm") 492 493 (cond-expand494 ((not unsafe)495 (declare (emit-exports "posix.exports")) )496 (else))497 492 498 493 (register-feature! 'posix) -
chicken/branches/hygienic/posixwin.scm
r10629 r10712 926 926 927 927 (include "unsafe-declarations.scm") 928 929 (cond-expand930 ((not unsafe)931 (declare (emit-exports "posix.exports")))932 (else))933 928 934 929 (register-feature! 'posix) -
chicken/branches/hygienic/private-namespace.scm
r10522 r10712 43 43 (##sys#string->qualified-symbol prefix (symbol->string var)))) 44 44 vars) 45 '(## sys#void) ) ) ) ) )45 '(##core#undefined) ) ) ) ) ) 46 46 (else 47 47 (define-macro (private . args) -
chicken/branches/hygienic/regex.scm
r10522 r10712 81 81 ##sys#check-structure ##sys#check-symbol ##sys#check-blob ##sys#check-integer ) 82 82 (export 83 ##sys#check-chardef-table ) 84 (emit-exports "regex.exports") ) ) 83 ##sys#check-chardef-table ))) 85 84 (else)) 86 85 -
chicken/branches/hygienic/rules.make
r10657 r10712 848 848 $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) LICENSE $(DESTDIR)$(IDOCDIR) 849 849 $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) chicken-more-macros.scm $(DESTDIR)$(IDATADIR) 850 $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) *.exports $(DESTDIR)$(IDATADIR)851 850 -$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) chicken.info $(DESTDIR)$(IINFODIR) 852 851 $(INSTALLINFO_PROGRAM) $(INSTALLINFO_PROGRAM_OPTIONS) --infodir=$(DESTDIR)$(IINFODIR) chicken.info … … 1037 1036 csc.c csi.c \ 1038 1037 chicken.c batch-driver.c compiler.c optimizer.c support.c \ 1039 c-platform.c c-backend.c *.exports1038 c-platform.c c-backend.c 1040 1039 1041 1040 distclean: clean confclean -
chicken/branches/hygienic/scheduler.scm
r10439 r10712 31 31 (disable-interrupts) 32 32 (usual-integrations) 33 (emit-exports "scheduler.exports")34 33 (disable-warning var) 35 34 (hide ##sys#ready-queue-head ##sys#ready-queue-tail ##sys#timeout-list -
chicken/branches/hygienic/srfi-1.scm
r10439 r10712 42 42 43 43 (include "unsafe-declarations.scm") 44 45 (cond-expand46 ((not unsafe)47 (declare (emit-exports "srfi-1.exports")))48 (else))49 44 50 45 (register-feature! 'srfi-1) -
chicken/branches/hygienic/srfi-13.scm
r10522 r10712 46 46 47 47 (include "unsafe-declarations.scm") 48 49 (cond-expand50 ((not unsafe)51 (declare (emit-exports "srfi-13.exports")))52 (else))53 48 54 49 (register-feature! 'srfi-13) -
chicken/branches/hygienic/srfi-14.scm
r10522 r10712 25 25 26 26 (include "unsafe-declarations.scm") 27 28 (cond-expand29 ((not unsafe)30 (declare (emit-exports "srfi-14.exports")))31 (else))32 27 33 28 (register-feature! 'srfi-14) -
chicken/branches/hygienic/srfi-18.scm
r10439 r10712 52 52 53 53 (include "unsafe-declarations.scm") 54 55 (cond-expand56 ((not unsafe)57 (declare (emit-exports "srfi-18.exports")))58 (else))59 54 60 55 (register-feature! 'srfi-18) -
chicken/branches/hygienic/srfi-4.scm
r10439 r10712 82 82 (include "unsafe-declarations.scm") 83 83 84 (cond-expand85 ((not unsafe)86 (declare (emit-exports "srfi-4.exports")))87 (else))88 89 84 90 85 ;;; Helper routines: -
chicken/branches/hygienic/srfi-69.scm
r10624 r10712 56 56 57 57 (include "unsafe-declarations.scm") 58 59 (cond-expand60 ((not unsafe)61 (declare (emit-exports "srfi-69.exports")))62 (else))63 58 64 59 (register-feature! 'srfi-69) -
chicken/branches/hygienic/support.scm
r10522 r10712 38 38 unit-name insert-timer-checks used-units source-filename pending-canonicalizations 39 39 foreign-declarations block-compilation line-number-database-size 40 target-heap-size target-stack-size check-global-exports check-global-imports40 target-heap-size target-stack-size 41 41 default-default-target-heap-size default-default-target-stack-size verbose-mode original-program-size 42 42 current-program-size line-number-database-2 foreign-lambda-stubs immutable-constants foreign-variables … … 54 54 debugging-chicken bomb check-signature posq stringify symbolify build-lambda-list 55 55 string->c-identifier c-ify-string words words->bytes check-and-open-input-file close-checked-input-file fold-inner 56 constant? basic-literal? source-info->string import-table56 constant? basic-literal? source-info->string 57 57 collapsable-literal? immediate? canonicalize-begin-body extract-mutable-constants string->expr get get-all 58 58 put! collect! count! get-line get-line-2 find-lambda-container display-analysis-database varnode qnode … … 65 65 foreign-string-result-reserve parameter-limit eq-inline-operator optimizable-rest-argument-operators 66 66 membership-test-operators membership-unfold-limit valid-compiler-options valid-compiler-options-with-argument 67 default-optimization-iterations chop-separator chop-extension follow-without-loop dump-exported-globals67 default-optimization-iterations chop-separator chop-extension follow-without-loop 68 68 generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration 69 69 foreign-argument-conversion foreign-result-conversion final-foreign-type debugging export-list block-globals 70 lookup-exports-fileconstant-declarations process-lambda-documentation big-fixnum?71 compiler-macro-table register-compiler-macro export-dump-hook export-import-hook70 constant-declarations process-lambda-documentation big-fixnum? 71 compiler-macro-table register-compiler-macro export-dump-hook 72 72 make-random-name foreign-type-convert-result foreign-type-convert-argument process-custom-declaration) 73 73 … … 86 86 (define (bomb . msg-and-args) 87 87 (if (pair? msg-and-args) 88 (apply error (string-append "[internal compiler screwup] " (car msg-and-args)) (cdr msg-and-args))89 (error "[internal compiler screwup]") ) )88 (apply error (string-append "[internal compiler error] " (car msg-and-args)) (cdr msg-and-args)) 89 (error "[internal compiler error]") ) ) 90 90 91 91 (define (debugging mode msg . args) … … 759 759 ;;; Some safety checks and database dumping: 760 760 761 (define (export-dump-hook db file) (void))762 763 (define (dump-exported-globals db file)764 (unless block-compilation765 (with-output-to-file file766 (lambda ()767 (let ((exports '()))768 (##sys#hash-table-for-each769 (lambda (sym plist)770 (when (and (assq 'global plist)771 (assq 'assigned plist)772 (or (and export-list (memq sym export-list))773 (not (memq sym block-globals)) ) )774 (set! exports (cons sym exports)) ) )775 db)776 (for-each777 (lambda (s)778 (write s)779 (newline) )780 (sort exports781 (lambda (s1 s2)782 (string<? (##sys#slot s1 1) (##sys#slot s2 1)))) )783 (export-dump-hook db file) ) ) ) ) )784 785 761 (define (dump-undefined-globals db) 786 762 (##sys#hash-table-for-each … … 803 779 (for-each (cut compiler-warning 'var "exported global variable `~S' is not defined" <>) exps) ) ) ) 804 780 805 (define (check-global-imports db)806 (##sys#hash-table-for-each807 (lambda (sym plist)808 (let ((imp (##sys#hash-table-ref import-table sym))809 (refs (assq 'references plist))810 (assgn (assq 'assigned plist)) )811 (when (assq 'global plist)812 (cond (assgn813 (when imp814 (compiler-warning 'redef "redefinition of imported variable `~s' from `~s'" sym imp) ) )815 ((and (pair? refs) (not imp) (not (keyword? sym)))816 (compiler-warning 'var "variable `~s' used but not imported" sym) ) ) ) ) )817 db) )818 819 781 (define (export-import-hook x id) (void)) 820 821 (define (lookup-exports-file id)822 (and-let* ((xfile (##sys#resolve-include-filename823 (string-append (->string id) ".exports")824 #t #t) )825 ((file-exists? xfile)) )826 (when verbose-mode827 (printf "loading exports file ~a ...~%" xfile) )828 (for-each829 (lambda (exp)830 (if (symbol? exp)831 (##sys#hash-table-set! import-table exp id)832 (export-import-hook exp id) ) )833 (read-file xfile)) ) )834 782 835 783 … … 1280 1228 -accumulate-profile executable emits profiling information in append mode 1281 1229 -no-lambda-info omit additional procedure-information 1282 -emit-exports FILENAME write exported toplevel variables to FILENAME1283 -check-imports look for undefined toplevel variables1284 -import FILENAME read externally exported symbols from FILENAME1285 1230 1286 1231 Optimization options: -
chicken/branches/hygienic/synrules.scm
r10370 r10712 97 97 (define %tail (r 'tail)) 98 98 (define %temp (r 'temp)) 99 (define %syntax-error (r 'syntax-error))99 (define %syntax-error '##sys#syntax-error-hook) 100 100 101 101 (define (make-transformer rules) … … 121 121 0 122 122 (meta-variables pattern 0 '()))))) 123 ( syntax-error"ill-formed syntax rule" rule)))123 (##sys#syntax-error-hook "ill-formed syntax rule" rule))) 124 124 125 125 ;; Generate code to test whether input expression matches pattern … … 226 226 (if (<= (cdr probe) dim) 227 227 template 228 ( syntax-error"template dimension error (too few ellipses?)"229 template))228 (##sys#syntax-error-hook "template dimension error (too few ellipses?)" 229 template)) 230 230 `(,%rename (##core#syntax ,template))))) 231 231 ((segment-template? template) … … 235 235 (free-meta-variables (car template) seg-dim env '()))) 236 236 (if (null? vars) 237 ( syntax-error"too many ellipses" template)237 (##sys#syntax-error-hook "too many ellipses" template) 238 238 (let* ((x (process-template (car template) 239 239 seg-dim … … 305 305 (and (segment-template? pattern) 306 306 (or (null? (cddr pattern)) 307 ( syntax-error"segment matching not implemented" pattern))))307 (##sys#syntax-error-hook "segment matching not implemented" pattern)))) 308 308 309 309 (define (segment-template? pattern) -
chicken/branches/hygienic/tcp.scm
r10522 r10712 90 90 91 91 (register-feature! 'tcp) 92 93 (cond-expand94 ((not unsafe)95 (declare (emit-exports "tcp.exports")))96 (else))97 92 98 93 (define-foreign-variable errno int "errno") -
chicken/branches/hygienic/utils.scm
r10629 r10712 52 52 53 53 (include "unsafe-declarations.scm") 54 55 (cond-expand56 ((not unsafe)57 (declare (emit-exports "utils.exports")))58 (else))59 54 60 55 (register-feature! 'utils)
Note: See TracChangeset
for help on using the changeset viewer.