Changeset 12629 in project
- Timestamp:
- 11/28/08 09:28:12 (12 years ago)
- Location:
- chicken/branches/lazy-gensyms
- Files:
-
- 10 edited
Legend:
- Unmodified
- Added
- Removed
-
chicken/branches/lazy-gensyms/NEWS
r12609 r12629 5 5 - added "-update-db" option to chicken-install 6 6 - the compiler now suggests possibly required module-imports 7 - print-names of gensyms are created lazily (borrowing an idea from Dybvig) 7 8 8 9 4.0.0x2 -
chicken/branches/lazy-gensyms/batch-driver.scm
r12610 r12629 388 388 (##sys#put! 389 389 (car e) '##core#db 390 (append ( or (##sys#get (car e) '##core#db)'()) (cdr e))) )390 (append (##sys#get (car e) '##core#db '()) (cdr e))) ) 391 391 (read-file dbfile))) 392 392 -
chicken/branches/lazy-gensyms/c-platform.scm
r12595 r12629 83 83 ##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument 84 84 ##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string ##sys#peek-nonnull-c-string 85 ##sys#peek-and-free-c-string ##sys#peek-and-free-nonnull-c-string 85 ##sys#peek-and-free-c-string ##sys#peek-and-free-nonnull-c-string ##sys#gensym 86 86 ##sys#foreign-block-argument ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#foreign-integer-argument 87 87 ##sys#call-with-current-continuation) ) ) … … 189 189 ##sys#make-structure ##sys#apply ##sys#apply-values ##sys#continuation-graft 190 190 ##sys#bytevector? ##sys#make-vector ##sys#setter ##sys#car ##sys#cdr ##sys#pair? 191 ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv? 191 ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv? ##sys#gensym 192 192 ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument 193 193 ##sys#foreign-block-argument ##sys#foreign-number-vector-argument … … 751 751 (rewrite 'string->list 11 1 '##sys#string->list #t) 752 752 (rewrite 'list->string 11 1 '##sys#list->string #t) 753 (rewrite 'gensym 11 0 '##sys#gensym #t) 753 754 754 755 (rewrite 'vector-set! 11 3 '##sys#setslot #f) -
chicken/branches/lazy-gensyms/compiler.scm
r12610 r12629 465 465 (define (lookup id se) 466 466 (cond ((find-id id se)) 467 ((##sys#get id '##core#macro-alias ))467 ((##sys#get id '##core#macro-alias #f)) 468 468 (else id))) 469 469 … … 517 517 se dest))) ] 518 518 ((not (assq x0 se)) (##sys#alias-global-hook x #f)) ; only if global 519 ((##sys#get x '##core#primitive ))519 ((##sys#get x '##core#primitive #f)) 520 520 (else x)))) 521 521 … … 550 550 (set! ##sys#syntax-error-culprit x) 551 551 (let* ((name0 (lookup (car x) se)) 552 (name (or (and (symbol? name0) (##sys#get name0 '##core#primitive )) name0))552 (name (or (and (symbol? name0) (##sys#get name0 '##core#primitive #f)) name0)) 553 553 (xexpanded (##sys#expand x se))) 554 554 (cond ((not (eq? x xexpanded)) -
chicken/branches/lazy-gensyms/csi.scm
r12612 r12629 639 639 (let ((name (##sys#slot x 1))) 640 640 (cond ((fixnum? name) 641 (fprintf out "uninstantiated uninterned gensym ~a~%" name)) 641 (fprintf out "uninstantiated uninterned symbol with name \"~a~a\"~%" 642 (##sys#get x '##core#gensym-prefix "g") 643 name)) 642 644 (else 643 645 (when (fx= 0 (##sys#byte name 0)) 644 (display "keyword " out) ) ) 645 (fprintf out "~asymbol with name ~S~%" 646 (if (##sys#interned-symbol? x) "" "uninterned ") 647 (##sys#symbol->string x))) 646 (display "keyword " out) ) 647 (fprintf 648 out "~asymbol with name ~S~%" 649 (if (##sys#interned-symbol? x) "" "uninterned ") 650 (##sys#symbol->string x)))) 648 651 (let ((plist (##sys#slot x 2))) 649 652 (unless (null? plist) -
chicken/branches/lazy-gensyms/eval.scm
r12612 r12629 159 159 (set! cache-s s) 160 160 (set! cache-h 161 (let ((sn (##sys#s lot s 1)))161 (let ((sn (##sys#symbol-name s))) 162 162 (##core#inline "C_hash_string" sn))) 163 163 (##core#inline "C_fixnum_modulo" cache-h n)))))) … … 249 249 (define (rename var se) 250 250 (cond ((find-id var se)) 251 ((##sys#get var '##core#macro-alias ))251 ((##sys#get var '##core#macro-alias #f)) 252 252 (else var))) 253 253 … … 300 300 (let ((var (if (not (assq x se)) ; global? 301 301 (##sys#alias-global-hook j #f) 302 ( or (##sys#get j '##core#primitive)j))))302 (##sys#get j '##core#primitive j)))) 303 303 (if ##sys#eval-environment 304 304 (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)]) -
chicken/branches/lazy-gensyms/expand.scm
r12612 r12629 69 69 (define (lookup id se) 70 70 (cond ((assq id se) => cdr) 71 (( ##sys#get id '##core#macro-alias))71 ((memq '##core#macro-alias (##sys#slot id 2)) => cadr) 72 72 (else #f))) 73 73 … … 98 98 (let walk ((x exp)) 99 99 (cond ((symbol? x) 100 ( let ((x2 (if se101 (lookup x se)102 (get x '##core#macro-alias) ) ) )103 (cond ((and alias (not (assq x se)))104 (##sys#alias-global-hook x #f))105 106 ((pair? x2) x)107 (else x2))))100 (if (and alias (not (assq x se))) 101 (##sys#alias-global-hook x #f) 102 (let ((x2 (if se 103 (lookup x se) 104 (##sys#get x '##core#macro-alias #f) ) ) ) 105 (cond ((not x2) x) 106 ((pair? x2) x) 107 (else x2))))) 108 108 ((pair? x) 109 109 (cons (walk (car x)) … … 252 252 (##sys#string->symbol 253 253 (string-append 254 (##sys#slot prefix 1) ;*** must be symbol with name !254 (##sys#slot prefix 1) ;*** must be symbol with name, not uninst. gensym! 255 255 "#" 256 256 (##sys#symbol-name sym) ) ) ) … … 265 265 (else sym))) 266 266 (cond ((##sys#qualified-symbol? sym) sym) 267 ((##sys#get sym '##core#primitive ) =>267 ((##sys#get sym '##core#primitive #f) => 268 268 (lambda (p) 269 269 (dm "(ALIAS) primitive: " p) 270 270 p)) 271 ((##sys#get sym '##core#aliased )271 ((##sys#get sym '##core#aliased #f) 272 272 (dm "(ALIAS) marked: " sym) 273 273 sym) … … 278 278 (if (pair? sym2) ; macro (*** can this be?) 279 279 (mrename sym) 280 ( or (##sys#get sym2 '##core#primitive)sym2)))))280 (##sys#get sym2 '##core#primitive sym2))))) 281 281 (else (mrename sym)))) 282 282 … … 690 690 (let ((result 691 691 (if (and (symbol? s1) (symbol? s2)) 692 (let ((ss1 (or (##sys#get s1 '##core#macro-alias )692 (let ((ss1 (or (##sys#get s1 '##core#macro-alias #f) 693 693 (lookup2 1 s1 dse) 694 694 s1) ) 695 (ss2 (or (##sys#get s2 '##core#macro-alias )695 (ss2 (or (##sys#get s2 '##core#macro-alias #f) 696 696 (lookup2 2 s2 dse) 697 697 s2) ) ) 698 698 (cond ((symbol? ss1) 699 699 (cond ((symbol? ss2) 700 (eq? (or (##sys#get ss1 '##core#primitive ) ss1)701 (or (##sys#get ss2 '##core#primitive ) ss2)))700 (eq? (or (##sys#get ss1 '##core#primitive #f) ss1) 701 (or (##sys#get ss2 '##core#primitive #f) ss2))) 702 702 ((assq ss1 (##sys#macro-environment)) => 703 703 (lambda (a) (eq? (cdr a) ss2))) … … 1592 1592 (unless (memq u elist) 1593 1593 (##sys#warn "reference to possibly unbound identifier" u) 1594 (and-let* ((a (##sys#get u '##core#db )))1594 (and-let* ((a (##sys#get u '##core#db #f))) 1595 1595 (let ((m (cadr a))) 1596 1596 (unless (memq m suggest) -
chicken/branches/lazy-gensyms/library.scm
r12612 r12629 1098 1098 (define ##sys#snafu '##sys#fnord) 1099 1099 (define ##sys#intern-symbol (##core#primitive "C_string_to_symbol")) 1100 (define (##sys#interned-symbol? x) (##core#inline "C_lookup_symbol" x)) 1100 1101 (define (##sys#interned-symbol? x) 1102 (and (not (fixnum? (##sys#slot x 1))) 1103 (##core#inline "C_lookup_symbol" x))) 1101 1104 1102 1105 (define (##sys#string->symbol str) … … 1108 1111 (if (fixnum? n) 1109 1112 (let ((n (##sys#string-append 1110 (or (##sys#get (##sys#slot sym 2) '##core#gensym-prefix) 1111 "g") 1113 (##sys#get sym '##core#gensym-prefix "g") 1112 1114 (##sys#number->string n)))) 1113 1115 (##sys#setslot sym 1 n) … … 1199 1201 (if (fixnum? n2) 1200 1202 "g" 1201 prefix)) ]1203 n2)) ] 1202 1204 [else (err prefix)] ) ) 1203 1205 (err prefix) ) ) ) … … 4675 4677 4676 4678 (define (##sys#put! sym prop val) 4679 (let* ((plist (##sys#slot sym 2)) 4680 (n (##core#inline "C_i_memq" prop plist))) 4681 (if n 4682 (##sys#setslot (##sys#slot n 1) 0 val) 4683 (##sys#setslot sym 2 (cons prop (cons val plist)))) 4684 val)) 4685 4686 (define (put! sym prop val) 4677 4687 (##sys#check-symbol sym 'put!) 4678 (let loop ((plist (##sys#slot sym 2))) 4679 (cond ((null? plist) (##sys#setslot sym 2 (cons prop (cons val (##sys#slot sym 2)))) ) 4680 ((eq? (##sys#slot plist 0) prop) (##sys#setslot (##sys#slot plist 1) 0 val)) 4681 (else (loop (##sys#slot (##sys#slot plist 1) 1)))) ) 4682 val) 4683 4684 (define put! ##sys#put!) 4685 4686 (define (##sys#get sym prop . default) 4687 (##sys#check-symbol sym 'get) 4688 (let loop ((plist (##sys#slot sym 2))) 4689 (cond ((null? plist) (optional default #f)) 4690 ((eq? (##sys#slot plist 0) prop) (##sys#slot (##sys#slot plist 1) 0)) 4691 (else (loop (##sys#slot (##sys#slot plist 1) 1))))) ) 4692 4693 (define get (getter-with-setter ##sys#get put!)) 4688 (##sys#put! sym prop val)) 4689 4690 (define (##sys#get sym prop default) 4691 (let* ((plist (##sys#slot sym 2)) 4692 (n (##core#inline "C_i_memq" prop plist))) 4693 (if n 4694 (##sys#slot (##sys#slot n 1) 0) 4695 default))) 4696 4697 (define get 4698 (getter-with-setter 4699 (lambda (sym prop #!optional default) 4700 (##sys#check-symbol sym 'get) 4701 (##sys#get sym prop default)) 4702 put!)) 4694 4703 4695 4704 (define (remprop! sym prop) -
chicken/branches/lazy-gensyms/support.scm
r12595 r12629 1462 1462 1463 1463 (define (variable-visible? sym) 1464 (let ((p (##sys#get sym '##compiler#visibility )))1464 (let ((p (##sys#get sym '##compiler#visibility #f))) 1465 1465 (case p 1466 1466 ((hidden) #f) … … 1472 1472 1473 1473 (define (variable-mark var mark) 1474 (##sys#get var mark ) )1474 (##sys#get var mark #f) ) 1475 1475 1476 1476 (define intrinsic? (cut variable-mark <> '##compiler#intrinsic)) -
chicken/branches/lazy-gensyms/tweaks.scm
r12301 r12629 49 49 (define-inline (node-subexpressions n) (##sys#slot n 3)) 50 50 51 (define-inline (intrinsic? sym) (##sys#get sym '##compiler#intrinsic ))51 (define-inline (intrinsic? sym) (##sys#get sym '##compiler#intrinsic #f)) 52 52 53 53 (define-inline (mark-variable var mark #!optional (val #t)) … … 55 55 56 56 (define-inline (variable-mark var mark) 57 (##sys#get var mark ) )57 (##sys#get var mark #f) )
Note: See TracChangeset
for help on using the changeset viewer.