unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* Associate type information to tree-il expansions
@ 2011-05-14 18:57 Stefan Israelsson Tampe
  2011-11-23 22:04 ` Andy Wingo
  0 siblings, 1 reply; 3+ messages in thread
From: Stefan Israelsson Tampe @ 2011-05-14 18:57 UTC (permalink / raw)
  To: Andy Wingo; +Cc: guile-devel


[-- Attachment #1.1: Type: text/plain, Size: 543 bytes --]

Hi,

For the sake of discussion. I've tried to implement a let directive where we
type the variable like

(macroexpand '(let ((A : integer 1)) A))
$2 = #<tree-il (let (A) (#{A 110}#) ((const 1)) (lexical A #{A 110}#)
(integer))>

So we see how we specify a type of A as integer and that this information
transfers to the tree-il
representation. The model here is to add types at the end of the record.
This is a minimal try to let
you chime in to argue.

Anyway to see the code consider the patches (git diff) that follows the
email.

/Stefan

[-- Attachment #1.2: Type: text/html, Size: 712 bytes --]

[-- Attachment #2: module-let-types.diff --]
[-- Type: text/x-patch, Size: 7706 bytes --]

diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 5380ba7..51f3ec9 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -418,14 +418,14 @@
             (make-sequence src exps))))
 
     (define build-let
-      (lambda (src ids vars val-exps body-exp)
+      (lambda (src ids vars val-exps tps body-exp)
         (for-each maybe-name-value! ids val-exps)
         (if (null? vars)
             body-exp
-            (make-let src ids vars val-exps body-exp))))
+            (make-let src ids vars val-exps body-exp tps))))
 
     (define build-named-let
-      (lambda (src ids vars val-exps body-exp)
+      (lambda (src ids vars val-exps tps body-exp)
         (let ((f (car vars))
               (f-name (car ids))
               (vars (cdr vars))
@@ -2025,8 +2025,8 @@
                        (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
 
     (global-extend 'core 'let
-                   (let ()
-                     (define (chi-let e r w s mod constructor ids vals exps)
+                   (let ()                    
+                     (define (chi-let e r w s mod constructor ids vals tp exps)
                        (if (not (valid-bound-ids? ids))
                            (syntax-violation 'let "duplicate bound variable" e)
                            (let ((labels (gen-labels ids))
@@ -2034,28 +2034,68 @@
                              (let ((nw (make-binding-wrap ids labels w))
                                    (nr (extend-var-env labels new-vars r)))
                                (constructor s
-                                            (map syntax->datum ids)
-                                            new-vars
-                                            (map (lambda (x) (chi x r w mod)) vals)
-                                            (chi-body exps (source-wrap e nw s mod)
-                                                      nr nw mod))))))
+                                  (map syntax->datum ids)
+                                  new-vars  
+                                  (map (lambda (x) (chi x r w mod)) 
+                                       vals)
+                                  tp
+                                  (chi-body exps 
+                                            (source-wrap e nw s mod)
+                                            nr nw mod))))))
+
+                     (define (extract-type-information e)
+                       (define (f e)
+                         (syntax-case e (:)
+                           ( (_ (s : t v) . l)
+                            (cons (syntax->datum #'t) (f #'(0 . l))))
+                           ( (_ (s v)     . l)
+                            (cons #f (f #'(0 . l))))
+                           ( (_)
+                            '())))
+                       (f e))
+
+                     (define (extract-old-information e)
+                       (define (f e)
+                         (syntax-case e (:)
+                           ((_ (s : t v) . l)
+                            (cons #'(s v) (f #'(0 . l))))
+                           ((_ (s v)     . l)
+                            (cons #'(s v) (f #'(0 . l))))
+                           ((_)
+                            '())))
+                       (f e))
+
                      (lambda (e r w s mod)
-                       (syntax-case e ()
-                         ((_ ((id val) ...) e1 e2 ...)
-                          (and-map id? #'(id ...))
-                          (chi-let e r w s mod
-                                   build-let
-                                   #'(id ...)
-                                   #'(val ...)
-                                   #'(e1 e2 ...)))
-                         ((_ f ((id val) ...) e1 e2 ...)
-                          (and (id? #'f) (and-map id? #'(id ...)))
-                          (chi-let e r w s mod
-                                   build-named-let
-                                   #'(f id ...)
-                                   #'(val ...)
-                                   #'(e1 e2 ...)))
-                         (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
+                       (let* ((old (syntax-case e () 
+                                     ((h (a ...) e ...)
+                                      (with-syntax 
+                                          ((aa (extract-old-information 
+                                                #'(0 a ...))))
+                                        #'(h aa e ...)))
+                                     ((h . l) #'(h . l))))
+                              (tp  (syntax-case e ()
+                                     ((h (a ...) e ...)
+                                      (extract-type-information #'(0 a ...)))
+                                     ((h . l) #f))))
+
+                         (syntax-case old ()
+                           ((_ ((id val) ...) e1 e2 ...)
+                            (and-map id? #'(id ...))
+                            (chi-let old r w s mod
+                                     build-let
+                                     #'(id ...)
+                                     #'(val ...)
+                                     tp
+                                     #'(e1 e2 ...)))
+                           ((_ f ((id val) ...) e1 e2 ...)
+                            (and (id? #'f) (and-map id? #'(id ...)))
+                            (chi-let e r w s mod
+                                     build-named-let
+                                     #'(f id ...)
+                                     #'(val ...)
+                                     tp
+                                     #'(e1 e2 ...)))                            
+                           (_ (syntax-violation 'let "bad let" (source-wrap e w s mod))))))))
 
 
     (global-extend 'core 'letrec
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 221cf26..cb4180e 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -41,7 +41,7 @@
                           lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
                           lambda-case-inits lambda-case-gensyms
                           lambda-case-body lambda-case-alternate
-            <let> let? make-let let-src let-names let-gensyms let-vals let-body
+            <let> let? make-let let-src let-names let-gensyms let-vals let-body let-types
             <letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
             <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
             <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
@@ -105,8 +105,16 @@
                                      out)))))))
              #`(begin #,@(reverse out))))))))
 
+;; 
 (borrow-core-vtables)
 
+;; patching make-let
+(define old-make-let make-let)
+(define (make-let a b c d e . l)
+  (if (pair? l)
+      (old-make-let a b c d e (car l))
+      (old-make-let a b c d e #f     )))
+
   ;; (<void>)
   ;; (<const> exp)
   ;; (<primitive-ref> name)
@@ -297,8 +305,11 @@
     ((<sequence> exps)
      `(begin ,@(map unparse-tree-il exps)))
 
-    ((<let> names gensyms vals body)
-     `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+    ((<let> names gensyms vals body types)
+     `(let ,names ,gensyms 
+           ,(map unparse-tree-il vals) 
+           ,(unparse-tree-il body) 
+           ,types))
 
     ((<letrec> in-order? names gensyms vals body)
      `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms

^ permalink raw reply related	[flat|nested] 3+ messages in thread

end of thread, other threads:[~2011-11-24 13:55 UTC | newest]

Thread overview: 3+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2011-05-14 18:57 Associate type information to tree-il expansions Stefan Israelsson Tampe
2011-11-23 22:04 ` Andy Wingo
2011-11-24 13:55   ` Stefan Israelsson Tampe

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).