Changeset 12629 in project

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:

• NEWS (modified) (1 diff)
• batch-driver.scm (modified) (1 diff)
• c-platform.scm (modified) (3 diffs)
• compiler.scm (modified) (3 diffs)
• csi.scm (modified) (1 diff)
• eval.scm (modified) (3 diffs)
• expand.scm (modified) (7 diffs)
• library.scm (modified) (4 diffs)
• support.scm (modified) (2 diffs)
• tweaks.scm (modified) (2 diffs)

chicken/branches/lazy-gensyms/NEWS

@@ -5 +5 @@
 - added "-update-db" option to chicken-install
 - the compiler now suggests possibly required module-imports
+- print-names of gensyms are created lazily (borrowing an idea from Dybvig)
 
 4.0.0x2

chicken/branches/lazy-gensyms/batch-driver.scm

@@ -388 +388 @@
          (##sys#put! 
           (car e) '##core#db
-          (append (or (##sys#get (car e) '##core#db) '()) (cdr e))) )
+          (append (##sys#get (car e) '##core#db '()) (cdr e))) )
        (read-file dbfile)))
 

chicken/branches/lazy-gensyms/c-platform.scm

@@ -83 +83 @@
      ##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument
      ##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string ##sys#peek-nonnull-c-string 
-     ##sys#peek-and-free-c-string ##sys#peek-and-free-nonnull-c-string
+     ##sys#peek-and-free-c-string ##sys#peek-and-free-nonnull-c-string ##sys#gensym
      ##sys#foreign-block-argument ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#foreign-integer-argument
      ##sys#call-with-current-continuation) ) )
@@ -189 +189 @@
     ##sys#make-structure ##sys#apply ##sys#apply-values ##sys#continuation-graft
     ##sys#bytevector? ##sys#make-vector ##sys#setter ##sys#car ##sys#cdr ##sys#pair?
-    ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv?
+    ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv? ##sys#gensym
     ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument
     ##sys#foreign-block-argument ##sys#foreign-number-vector-argument
@@ -751 +751 @@
 (rewrite 'string->list 11 1 '##sys#string->list #t)
 (rewrite 'list->string 11 1 '##sys#list->string #t)
+(rewrite 'gensym 11 0 '##sys#gensym #t)
 
 (rewrite 'vector-set! 11 3 '##sys#setslot #f)

chicken/branches/lazy-gensyms/compiler.scm

@@ -465 +465 @@
   (define (lookup id se)
     (cond ((find-id id se))
-          ((##sys#get id '##core#macro-alias))
+          ((##sys#get id '##core#macro-alias #f))
           (else id)))
 
@@ -517 +517 @@
                      se dest))) ]
             ((not (assq x0 se)) (##sys#alias-global-hook x #f)) ; only if global
-            ((##sys#get x '##core#primitive))
+            ((##sys#get x '##core#primitive #f))
             (else x))))
   
@@ -550 +550 @@
              (set! ##sys#syntax-error-culprit x)
              (let* ((name0 (lookup (car x) se))
-                    (name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
+                    (name (or (and (symbol? name0) (##sys#get name0 '##core#primitive #f)) name0))
                     (xexpanded (##sys#expand x se)))
                (cond ((not (eq? x xexpanded))

chicken/branches/lazy-gensyms/csi.scm

@@ -639 +639 @@
              (let ((name (##sys#slot x 1)))
                (cond ((fixnum? name)
-                      (fprintf out "uninstantiated uninterned gensym ~a~%" name))
+                      (fprintf out "uninstantiated uninterned symbol with name \"~a~a\"~%" 
+                               (##sys#get x '##core#gensym-prefix "g")
+                               name))
                      (else
                       (when (fx= 0 (##sys#byte name 0))
-                        (display "keyword " out) ) )
-                     (fprintf out "~asymbol with name ~S~%"
-                              (if (##sys#interned-symbol? x) "" "uninterned ")
-                              (##sys#symbol->string x)))
+                        (display "keyword " out) ) 
+                      (fprintf 
+                       out "~asymbol with name ~S~%"
+                       (if (##sys#interned-symbol? x) "" "uninterned ")
+                       (##sys#symbol->string x))))
                (let ((plist (##sys#slot x 2)))
                  (unless (null? plist)

chicken/branches/lazy-gensyms/eval.scm

@@ -159 +159 @@
             (set! cache-s s)
             (set! cache-h
-              (let ((sn (##sys#slot s 1)))
+              (let ((sn (##sys#symbol-name s)))
                 (##core#inline "C_hash_string" sn)))
             (##core#inline "C_fixnum_modulo" cache-h n))))))
@@ -249 +249 @@
       (define (rename var se)
         (cond ((find-id var se))
-              ((##sys#get var '##core#macro-alias))
+              ((##sys#get var '##core#macro-alias #f))
               (else var)))
 
@@ -300 +300 @@
                         (let ((var (if (not (assq x se)) ; global?
                                        (##sys#alias-global-hook j #f)
-                                       (or (##sys#get j '##core#primitive) j))))
+                                       (##sys#get j '##core#primitive j))))
                           (if ##sys#eval-environment
                               (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])

chicken/branches/lazy-gensyms/expand.scm

@@ -69 +69 @@
 (define (lookup id se)
   (cond ((assq id se) => cdr)
-        ((##sys#get id '##core#macro-alias))
+        ((memq '##core#macro-alias (##sys#slot id 2)) => cadr)
         (else #f)))
 
@@ -98 +98 @@
   (let walk ((x exp))
     (cond ((symbol? x)
-           (let ((x2 (if se 
-                         (lookup x se)
-                         (get x '##core#macro-alias) ) ) )
-             (cond ((and alias (not (assq x se)))
-                    (##sys#alias-global-hook x #f))
-                   ((not x2) x)
-                   ((pair? x2) x)
-                   (else x2))))
+           (if (and alias (not (assq x se)))
+               (##sys#alias-global-hook x #f)
+               (let ((x2 (if se 
+                             (lookup x se)
+                             (##sys#get x '##core#macro-alias #f) ) ) )
+                 (cond ((not x2) x)
+                       ((pair? x2) x)
+                       (else x2)))))
           ((pair? x)
            (cons (walk (car x))
@@ -252 +252 @@
   (##sys#string->symbol 
    (string-append 
-    (##sys#slot prefix 1)               ;*** must be symbol with name!
+    (##sys#slot prefix 1)               ;*** must be symbol with name, not uninst. gensym!
     "#" 
     (##sys#symbol-name sym) ) ) )
@@ -265 +265 @@
           (else sym)))
   (cond ((##sys#qualified-symbol? sym) sym)
-        ((##sys#get sym '##core#primitive) =>
+        ((##sys#get sym '##core#primitive #f) =>
          (lambda (p)
            (dm "(ALIAS) primitive: " p)
            p))
-        ((##sys#get sym '##core#aliased) 
+        ((##sys#get sym '##core#aliased #f) 
          (dm "(ALIAS) marked: " sym)
          sym)
@@ -278 +278 @@
              (if (pair? sym2)           ; macro (*** can this be?)
                  (mrename sym)
-                 (or (##sys#get sym2 '##core#primitive) sym2)))))
+                 (##sys#get sym2 '##core#primitive sym2)))))
         (else (mrename sym))))
 
@@ -690 +690 @@
       (let ((result
              (if (and (symbol? s1) (symbol? s2))
-                 (let ((ss1 (or (##sys#get s1 '##core#macro-alias)
+                 (let ((ss1 (or (##sys#get s1 '##core#macro-alias #f)
                                 (lookup2 1 s1 dse)
                                 s1) )
-                       (ss2 (or (##sys#get s2 '##core#macro-alias)
+                       (ss2 (or (##sys#get s2 '##core#macro-alias #f)
                                 (lookup2 2 s2 dse)
                                 s2) ) )
                    (cond ((symbol? ss1)
                           (cond ((symbol? ss2) 
-                                 (eq? (or (##sys#get ss1 '##core#primitive) ss1)
-                                      (or (##sys#get ss2 '##core#primitive) ss2)))
+                                 (eq? (or (##sys#get ss1 '##core#primitive #f) ss1)
+                                      (or (##sys#get ss2 '##core#primitive #f) ss2)))
                                 ((assq ss1 (##sys#macro-environment)) =>
                                  (lambda (a) (eq? (cdr a) ss2)))
@@ -1592 +1592 @@
        (unless (memq u elist)
          (##sys#warn "reference to possibly unbound identifier" u)
-         (and-let* ((a (##sys#get u '##core#db)))
+         (and-let* ((a (##sys#get u '##core#db #f)))
            (let ((m (cadr a)))
              (unless (memq m suggest)

chicken/branches/lazy-gensyms/library.scm

@@ -1098 +1098 @@
 (define ##sys#snafu '##sys#fnord)
 (define ##sys#intern-symbol (##core#primitive "C_string_to_symbol"))
-(define (##sys#interned-symbol? x) (##core#inline "C_lookup_symbol" x))
+
+(define (##sys#interned-symbol? x)
+  (and (not (fixnum? (##sys#slot x 1)))
+       (##core#inline "C_lookup_symbol" x)))
 
 (define (##sys#string->symbol str)
@@ -1108 +1111 @@
     (if (fixnum? n)
         (let ((n (##sys#string-append
-                  (or (##sys#get (##sys#slot sym 2) '##core#gensym-prefix)
-                      "g")
+                  (##sys#get sym '##core#gensym-prefix "g")
                   (##sys#number->string n))))
           (##sys#setslot sym 1 n)
@@ -1199 +1201 @@
                                        (if (fixnum? n2)
                                            "g"
-                                           prefix)) ]
+                                           n2)) ]
                                     [else (err prefix)] )  )
                          (err prefix) ) ) )
@@ -4675 +4677 @@
 
 (define (##sys#put! sym prop val)
+  (let* ((plist (##sys#slot sym 2))
+         (n (##core#inline "C_i_memq" prop plist)))
+    (if n
+        (##sys#setslot (##sys#slot n 1) 0 val)
+        (##sys#setslot sym 2 (cons prop (cons val plist))))
+    val))
+
+(define (put! sym prop val)
   (##sys#check-symbol sym 'put!)
-  (let loop ((plist (##sys#slot sym 2)))
-    (cond ((null? plist) (##sys#setslot sym 2 (cons prop (cons val (##sys#slot sym 2)))) )
-          ((eq? (##sys#slot plist 0) prop) (##sys#setslot (##sys#slot plist 1) 0 val))
-          (else (loop (##sys#slot (##sys#slot plist 1) 1)))) )
-  val)
-
-(define put! ##sys#put!)
-
-(define (##sys#get sym prop . default)
-  (##sys#check-symbol sym 'get)
-  (let loop ((plist (##sys#slot sym 2)))
-    (cond ((null? plist) (optional default #f))
-          ((eq? (##sys#slot plist 0) prop) (##sys#slot (##sys#slot plist 1) 0))
-          (else (loop (##sys#slot (##sys#slot plist 1) 1))))) )
-
-(define get (getter-with-setter ##sys#get put!))
+  (##sys#put! sym prop val))
+
+(define (##sys#get sym prop default)
+  (let* ((plist (##sys#slot sym 2))
+         (n (##core#inline "C_i_memq" prop plist)))
+    (if n
+        (##sys#slot (##sys#slot n 1) 0)
+        default)))
+
+(define get
+  (getter-with-setter
+   (lambda (sym prop #!optional default)
+     (##sys#check-symbol sym 'get)
+     (##sys#get sym prop default))
+   put!))
 
 (define (remprop! sym prop)

chicken/branches/lazy-gensyms/support.scm

@@ -1462 +1462 @@
 
 (define (variable-visible? sym)
-  (let ((p (##sys#get sym '##compiler#visibility)))
+  (let ((p (##sys#get sym '##compiler#visibility #f)))
     (case p
       ((hidden) #f)
@@ -1472 +1472 @@
 
 (define (variable-mark var mark)
-  (##sys#get var mark) )
+  (##sys#get var mark #f) )
 
 (define intrinsic? (cut variable-mark <> '##compiler#intrinsic))

chicken/branches/lazy-gensyms/tweaks.scm

@@ -49 +49 @@
 (define-inline (node-subexpressions n) (##sys#slot n 3))
 
-(define-inline (intrinsic? sym) (##sys#get sym '##compiler#intrinsic))
+(define-inline (intrinsic? sym) (##sys#get sym '##compiler#intrinsic #f))
 
 (define-inline (mark-variable var mark #!optional (val #t))
@@ -55 +55 @@
 
 (define-inline (variable-mark var mark)
-  (##sys#get var mark) )
+  (##sys#get var mark #f) )