Changeset 11638 in project for release/3/oru/core.scm

Timestamp:

08/14/08 06:20:31 (13 years ago)

Author:

Ivan Raikov

Message:

Some bugs fixed in processing defun declarations.

File:

• release/3/oru/core.scm (modified) (6 diffs)

release/3/oru/core.scm

@@ -198 +198 @@
   ;; 2. fold expressions like (+ a b c d) into nested binops 
   (define (normalize-expr expr)
+    (define (normalize-bnd x)
+      `(,(first x) ,(normalize-expr (second x))))
     (match expr 
+           (('let bs e)         `(let ,(map normalize-bnd bs) ,(normalize-expr e)))
+           (('if c t e)         `(if ,(normalize-expr c) ,(normalize-expr t) ,(normalize-expr e))) 
            (('+ . es)           (binop-fold '+ (map normalize-expr es)))
            (('- . es)           (let ((es1 (map normalize-expr es)))
@@ -307 +311 @@
               )))))
 
-  (define (infer oru-env ftenv formals body)
-    (let recur ((expr body))
+  (define (infer oru-env ftenv body)
+    (let recur ((expr body) (lb (list)))
       (match expr 
              (('if c t e)
-              (let ((ct (recur c))
-                    (tt (recur t))
-                    (et (recur e)))
+              (let ((ct (recur c lb))
+                    (tt (recur t lb))
+                    (et (recur e lb)))
                 (and ct tt et 
                      (begin
@@ -321 +325 @@
                            (oru:error 'infer "type mismatch in if statement: then = " tt
                                       " else = " et))))))
+             (('let bs e)
+              (let* ((rlb (lambda (x) (recur x lb)))
+                     (tbs (map rlb (map second bs)))
+                     (lb1 (append (zip (map first bs) tbs) lb)))
+                (recur e lb1)))
              
              ((s . es)    
@@ -334 +343 @@
                                               (environment-extend! ftenv x ft)))
                                         es fms)
-                              (let ((ets (map recur es)))
+                              (let* ((rlb (lambda (x) (recur x lb)))
+                                     (ets (map rlb es)))
                                 (and (every identity ets)
                                      (every (lambda (xt ft) (equal? xt ft)) ets fms)
                                      rt))))))))
              
-             (id    (cond ((symbol? id)     (environment-ref ftenv id))
+             (id    (cond ((symbol? id)     (or (lookup-def id lb) (environment-ref ftenv id)))
                           ((number? id)     fptype)
                           ((boolean? id)    'bool)
@@ -351 +361 @@
               (sym (if (symbol? name) name (string->symbol name))))
           (letrec ((enumconsts
-                    (lambda (expr ax)
-                      (match expr 
-                             (('if . es)  (fold enumconsts ax es))
-                             ((s . es)    (if (symbol? s)  (cons s (fold enumconsts ax es)) ax))
-                             (s           (if (and (symbol? s) (environment-includes? const-env s))
-                                              (cons s ax) ax))))))
+                    (lambda (lb)
+                      (lambda (expr ax)
+                        (match expr 
+                               (('let bs e)  (let ((ec (enumconsts (append (map first bs) lb))))
+                                               (ec e (fold ec ax (map second bs)))))
+                               (('if . es)   (fold (enumconsts lb) ax es))
+                               ((s . es)     (if (symbol? s)  (cons s (fold (enumconsts lb) ax es)) ax))
+                               (s            (if (and (symbol? s) (not (member s lb)) 
+                                                      (environment-includes? const-env s))
+                                                 (cons s ax) ax)))))))
             (if (environment-has-binding? oru-env sym)
                 (oru:error 'defun! ": quantity " sym " already defined")
                 (let* ((body    (normalize-expr body))
-                       (consts  (delete-duplicates (enumconsts body (list))))
+                       (consts  (delete-duplicates ((enumconsts formals) body (list))))
                        (fc     `(lambda (const-env)
                                   (let ,(map (lambda (v) `(,v (environment-ref const-env ',v))) consts)
@@ -367 +381 @@
                   
                   (let* ((ftenv  (make-environment))
-                         (rt     (infer oru-env ftenv formals body))
+                         (rt     (infer oru-env ftenv body))
                          (ftypes (filter-map (lambda (x) (and (environment-includes? ftenv x)
                                                               (environment-ref ftenv x)))