Changeset 12629 in project for chicken


Ignore:
Timestamp:
11/28/08 09:28:12 (12 years ago)
Author:
felix winkelmann
Message:

support for lazy gensyms; some refactoring in get/put\!

Location:
chicken/branches/lazy-gensyms
Files:
10 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/lazy-gensyms/NEWS

    r12609 r12629  
    55- added "-update-db" option to chicken-install
    66- the compiler now suggests possibly required module-imports
     7- print-names of gensyms are created lazily (borrowing an idea from Dybvig)
    78
    894.0.0x2
  • chicken/branches/lazy-gensyms/batch-driver.scm

    r12610 r12629  
    388388         (##sys#put!
    389389          (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))) )
    391391       (read-file dbfile)))
    392392
  • chicken/branches/lazy-gensyms/c-platform.scm

    r12595 r12629  
    8383     ##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument
    8484     ##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
    8686     ##sys#foreign-block-argument ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#foreign-integer-argument
    8787     ##sys#call-with-current-continuation) ) )
     
    189189    ##sys#make-structure ##sys#apply ##sys#apply-values ##sys#continuation-graft
    190190    ##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
    192192    ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument
    193193    ##sys#foreign-block-argument ##sys#foreign-number-vector-argument
     
    751751(rewrite 'string->list 11 1 '##sys#string->list #t)
    752752(rewrite 'list->string 11 1 '##sys#list->string #t)
     753(rewrite 'gensym 11 0 '##sys#gensym #t)
    753754
    754755(rewrite 'vector-set! 11 3 '##sys#setslot #f)
  • chicken/branches/lazy-gensyms/compiler.scm

    r12610 r12629  
    465465  (define (lookup id se)
    466466    (cond ((find-id id se))
    467           ((##sys#get id '##core#macro-alias))
     467          ((##sys#get id '##core#macro-alias #f))
    468468          (else id)))
    469469
     
    517517                     se dest))) ]
    518518            ((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))
    520520            (else x))))
    521521 
     
    550550             (set! ##sys#syntax-error-culprit x)
    551551             (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))
    553553                    (xexpanded (##sys#expand x se)))
    554554               (cond ((not (eq? x xexpanded))
  • chicken/branches/lazy-gensyms/csi.scm

    r12612 r12629  
    639639             (let ((name (##sys#slot x 1)))
    640640               (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))
    642644                     (else
    643645                      (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))))
    648651               (let ((plist (##sys#slot x 2)))
    649652                 (unless (null? plist)
  • chicken/branches/lazy-gensyms/eval.scm

    r12612 r12629  
    159159            (set! cache-s s)
    160160            (set! cache-h
    161               (let ((sn (##sys#slot s 1)))
     161              (let ((sn (##sys#symbol-name s)))
    162162                (##core#inline "C_hash_string" sn)))
    163163            (##core#inline "C_fixnum_modulo" cache-h n))))))
     
    249249      (define (rename var se)
    250250        (cond ((find-id var se))
    251               ((##sys#get var '##core#macro-alias))
     251              ((##sys#get var '##core#macro-alias #f))
    252252              (else var)))
    253253
     
    300300                        (let ((var (if (not (assq x se)) ; global?
    301301                                       (##sys#alias-global-hook j #f)
    302                                        (or (##sys#get j '##core#primitive) j))))
     302                                       (##sys#get j '##core#primitive j))))
    303303                          (if ##sys#eval-environment
    304304                              (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
  • chicken/branches/lazy-gensyms/expand.scm

    r12612 r12629  
    6969(define (lookup id se)
    7070  (cond ((assq id se) => cdr)
    71         ((##sys#get id '##core#macro-alias))
     71        ((memq '##core#macro-alias (##sys#slot id 2)) => cadr)
    7272        (else #f)))
    7373
     
    9898  (let walk ((x exp))
    9999    (cond ((symbol? x)
    100            (let ((x2 (if se
    101                          (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                    ((not x2) x)
    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)))))
    108108          ((pair? x)
    109109           (cons (walk (car x))
     
    252252  (##sys#string->symbol
    253253   (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!
    255255    "#"
    256256    (##sys#symbol-name sym) ) ) )
     
    265265          (else sym)))
    266266  (cond ((##sys#qualified-symbol? sym) sym)
    267         ((##sys#get sym '##core#primitive) =>
     267        ((##sys#get sym '##core#primitive #f) =>
    268268         (lambda (p)
    269269           (dm "(ALIAS) primitive: " p)
    270270           p))
    271         ((##sys#get sym '##core#aliased)
     271        ((##sys#get sym '##core#aliased #f)
    272272         (dm "(ALIAS) marked: " sym)
    273273         sym)
     
    278278             (if (pair? sym2)           ; macro (*** can this be?)
    279279                 (mrename sym)
    280                  (or (##sys#get sym2 '##core#primitive) sym2)))))
     280                 (##sys#get sym2 '##core#primitive sym2)))))
    281281        (else (mrename sym))))
    282282
     
    690690      (let ((result
    691691             (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)
    693693                                (lookup2 1 s1 dse)
    694694                                s1) )
    695                        (ss2 (or (##sys#get s2 '##core#macro-alias)
     695                       (ss2 (or (##sys#get s2 '##core#macro-alias #f)
    696696                                (lookup2 2 s2 dse)
    697697                                s2) ) )
    698698                   (cond ((symbol? ss1)
    699699                          (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)))
    702702                                ((assq ss1 (##sys#macro-environment)) =>
    703703                                 (lambda (a) (eq? (cdr a) ss2)))
     
    15921592       (unless (memq u elist)
    15931593         (##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)))
    15951595           (let ((m (cadr a)))
    15961596             (unless (memq m suggest)
  • chicken/branches/lazy-gensyms/library.scm

    r12612 r12629  
    10981098(define ##sys#snafu '##sys#fnord)
    10991099(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)))
    11011104
    11021105(define (##sys#string->symbol str)
     
    11081111    (if (fixnum? n)
    11091112        (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")
    11121114                  (##sys#number->string n))))
    11131115          (##sys#setslot sym 1 n)
     
    11991201                                       (if (fixnum? n2)
    12001202                                           "g"
    1201                                            prefix)) ]
     1203                                           n2)) ]
    12021204                                    [else (err prefix)] )  )
    12031205                         (err prefix) ) ) )
     
    46754677
    46764678(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)
    46774687  (##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!))
    46944703
    46954704(define (remprop! sym prop)
  • chicken/branches/lazy-gensyms/support.scm

    r12595 r12629  
    14621462
    14631463(define (variable-visible? sym)
    1464   (let ((p (##sys#get sym '##compiler#visibility)))
     1464  (let ((p (##sys#get sym '##compiler#visibility #f)))
    14651465    (case p
    14661466      ((hidden) #f)
     
    14721472
    14731473(define (variable-mark var mark)
    1474   (##sys#get var mark) )
     1474  (##sys#get var mark #f) )
    14751475
    14761476(define intrinsic? (cut variable-mark <> '##compiler#intrinsic))
  • chicken/branches/lazy-gensyms/tweaks.scm

    r12301 r12629  
    4949(define-inline (node-subexpressions n) (##sys#slot n 3))
    5050
    51 (define-inline (intrinsic? sym) (##sys#get sym '##compiler#intrinsic))
     51(define-inline (intrinsic? sym) (##sys#get sym '##compiler#intrinsic #f))
    5252
    5353(define-inline (mark-variable var mark #!optional (val #t))
     
    5555
    5656(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.