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


Ignore:
Timestamp:
08/14/08 06:20:31 (13 years ago)
Author:
Ivan Raikov
Message:

Some bugs fixed in processing defun declarations.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/3/oru/core.scm

    r11412 r11638  
    198198  ;; 2. fold expressions like (+ a b c d) into nested binops
    199199  (define (normalize-expr expr)
     200    (define (normalize-bnd x)
     201      `(,(first x) ,(normalize-expr (second x))))
    200202    (match expr
     203           (('let bs e)         `(let ,(map normalize-bnd bs) ,(normalize-expr e)))
     204           (('if c t e)         `(if ,(normalize-expr c) ,(normalize-expr t) ,(normalize-expr e)))
    201205           (('+ . es)           (binop-fold '+ (map normalize-expr es)))
    202206           (('- . es)           (let ((es1 (map normalize-expr es)))
     
    307311              )))))
    308312
    309   (define (infer oru-env ftenv formals body)
    310     (let recur ((expr body))
     313  (define (infer oru-env ftenv body)
     314    (let recur ((expr body) (lb (list)))
    311315      (match expr
    312316             (('if c t e)
    313               (let ((ct (recur c))
    314                     (tt (recur t))
    315                     (et (recur e)))
     317              (let ((ct (recur c lb))
     318                    (tt (recur t lb))
     319                    (et (recur e lb)))
    316320                (and ct tt et
    317321                     (begin
     
    321325                           (oru:error 'infer "type mismatch in if statement: then = " tt
    322326                                      " else = " et))))))
     327             (('let bs e)
     328              (let* ((rlb (lambda (x) (recur x lb)))
     329                     (tbs (map rlb (map second bs)))
     330                     (lb1 (append (zip (map first bs) tbs) lb)))
     331                (recur e lb1)))
    323332             
    324333             ((s . es)   
     
    334343                                              (environment-extend! ftenv x ft)))
    335344                                        es fms)
    336                               (let ((ets (map recur es)))
     345                              (let* ((rlb (lambda (x) (recur x lb)))
     346                                     (ets (map rlb es)))
    337347                                (and (every identity ets)
    338348                                     (every (lambda (xt ft) (equal? xt ft)) ets fms)
    339349                                     rt))))))))
    340350             
    341              (id    (cond ((symbol? id)     (environment-ref ftenv id))
     351             (id    (cond ((symbol? id)     (or (lookup-def id lb) (environment-ref ftenv id)))
    342352                          ((number? id)     fptype)
    343353                          ((boolean? id)    'bool)
     
    351361              (sym (if (symbol? name) name (string->symbol name))))
    352362          (letrec ((enumconsts
    353                     (lambda (expr ax)
    354                       (match expr
    355                              (('if . es)  (fold enumconsts ax es))
    356                              ((s . es)    (if (symbol? s)  (cons s (fold enumconsts ax es)) ax))
    357                              (s           (if (and (symbol? s) (environment-includes? const-env s))
    358                                               (cons s ax) ax))))))
     363                    (lambda (lb)
     364                      (lambda (expr ax)
     365                        (match expr
     366                               (('let bs e)  (let ((ec (enumconsts (append (map first bs) lb))))
     367                                               (ec e (fold ec ax (map second bs)))))
     368                               (('if . es)   (fold (enumconsts lb) ax es))
     369                               ((s . es)     (if (symbol? s)  (cons s (fold (enumconsts lb) ax es)) ax))
     370                               (s            (if (and (symbol? s) (not (member s lb))
     371                                                      (environment-includes? const-env s))
     372                                                 (cons s ax) ax)))))))
    359373            (if (environment-has-binding? oru-env sym)
    360374                (oru:error 'defun! ": quantity " sym " already defined")
    361375                (let* ((body    (normalize-expr body))
    362                        (consts  (delete-duplicates (enumconsts body (list))))
     376                       (consts  (delete-duplicates ((enumconsts formals) body (list))))
    363377                       (fc     `(lambda (const-env)
    364378                                  (let ,(map (lambda (v) `(,v (environment-ref const-env ',v))) consts)
     
    367381                 
    368382                  (let* ((ftenv  (make-environment))
    369                          (rt     (infer oru-env ftenv formals body))
     383                         (rt     (infer oru-env ftenv body))
    370384                         (ftypes (filter-map (lambda (x) (and (environment-includes? ftenv x)
    371385                                                              (environment-ref ftenv x)))
Note: See TracChangeset for help on using the changeset viewer.