Changeset 31641 for lang/scheme

Timestamp:

03/28/09 14:05:37 (4 years ago)

Author:

mokehehe

Message:

lambda内のinternal defineに対応
direct-invoke時にsetされるとおかしかったのを修正

Location:

lang/scheme/3imp

Files:

• 4.7.scm (modified) (10 diffs)
• check.scm (modified) (1 diff)

lang/scheme/3imp/4.7.scm

@@ -140 +140 @@
            (ext-vars (append proper-vars (car e))))
       (let ((free (cdr e))  ; 上のスコープの自由変数をそのまま引き継ぐ
-            (sets (find-setses bodies ext-vars))
+            (sets (set-union s (find-setses bodies ext-vars)))
             (varnum (if (eq? vars proper-vars)
                         (cons (length vars) (length vars))
@@ -148 +148 @@
           (if (null? proper-vars)
               ;; 変数なし(lambda () ...)：EXPAND～SHRINK 自体必要ない
-              (make-boxes sets proper-vars
-                          (compile-lambda-bodies (car e) bodies (cdr e) sets s
-                                                 next))
+              (compile-lambda-bodies (car e) bodies (cdr e) sets s
+                                     next)
             (let ((c (list* EXPAND (length args2)
                            (make-boxes sets proper-vars
@@ -184 +183 @@
                           next)))))
 
-(define (compile-lambda-bodies vars bodies free sets s last)
+(define (compile-lambda-bodies vars bodies free sets s next)
   (let ((ee (cons vars free))
         (ss (set-union sets
@@ -190 +189 @@
     (recur loop ((p bodies))
            (if (null? p)
-               last
+               next
              (compile (car p) ee ss
                       (loop (cdr p)))))))
@@ -333 +332 @@
                       a)
                 (LREF (n . x)
-                             (VM (index f n) x f c s))
+                      (VM (index f n) x f c s))
                 (FREF (n . x)
-                            (VM (index-closure c n) x f c s))
+                      (VM (index-closure c n) x f c s))
                 (GREF (sym . x)
-                              (VM (refer-global sym (lambda () (error "unbound variable:" sym))) x f c s))
+                      (VM (refer-global sym (lambda () (error "unbound variable:" sym))) x f c s))
                 (UNBOX x
-                          (VM (unbox a) x f c s))
+                       (VM (unbox a) x f c s))
                 (CONST (obj . x)
-                          (VM obj x f c s))
+                       (VM obj x f c s))
                 (CLOSE (argnum n body . x)
                        (VM (closure argnum body n s) x f c (- s n)))
@@ -350 +349 @@
                       (VM a (if a then else) f c s))
                 (LSET (n . x)
-                              (set-box! (index f n) a)
-                              (VM a x f c s))
+                      (set-box! (index f n) a)
+                      (VM a x f c s))
                 (FSET (n . x)
-                             (set-box! (index-closure c n) a)
-                             (VM a x f c s))
+                      (set-box! (index-closure c n) a)
+                      (VM a x f c s))
                 (GSET (sym . x)
-                               (assign-global! sym a)
-                               (VM a x f c s))
+                      (assign-global! sym a)
+                      (VM a x f c s))
                 (CONTI (tail? . x)
                        (VM (continuation s tail?) x f c s))
@@ -365 +364 @@
                        (VM a x f c (push ret (push f (push c s)))))
                 (ARG x
-                          (VM a x f c (push a s)))
+                     (VM a x f c (push a s)))
                 (SHIFT (n . x)
                        (let ((m (index s (- n 1))))  ; 一つ前の呼び出しの引数の数
@@ -372 +371 @@
                        (do-apply argnum a s))
                 (RET ()
-                        (do-return a s))
+                     (do-return a s))
                 (EXPAND (argnum . x)
-                               (expand-frame argnum f s)
-                               (VM a x (+ f argnum) c s))
+                        (expand-frame argnum f s)
+                        (VM a x (+ f argnum) c s))
                 (SHRINK (n . x)
-                               (shrink-frame n f s)
-                               (VM a x (- f n) c (- s n)))
+                        (shrink-frame n f s)
+                        (VM a x (- f n) c (- s n)))
                 (else
                  (error "unknown opcode" (car x)))))
@@ -826 +825 @@
 
 (define-special-form (lambda vars . bodies)
-  `(lambda ,vars ,@(map comp-macroexpand-1 bodies)))
+  (define (define? x) (and (pair? x) (eq? (car x) 'define)))
+  (define (normalize-define exp)
+    (let ((name (car exp))
+          (bodies (cdr exp)))
+      (if (pair? name)
+          (normalize-define `(,(car name) (lambda ,(cdr name) ,@bodies)))
+        exp)))
+  (receive (internal-defines actual-bodies)
+           (partition define? bodies)
+    (let ((defines (map (lambda (x) (normalize-define (cdr x))) internal-defines)))
+      (if (null? defines)
+          `(lambda ,vars ,@(map comp-macroexpand-1 bodies))
+        `(lambda ,vars
+           ((lambda ,(map car defines)
+              ,@(map (lambda (e)
+                       `(set! ,(car e) ,(cadr e)))
+                     defines)
+              ,@actual-bodies)
+            ,@(map (lambda (_) '()) defines)))))))
 
 (define-special-form (if . all)
@@ -898 +915 @@
 
 (define-builtin-macro (letrec parms . bodies)
-  `((lambda ,(map car parms)
-          ,@(map (lambda (parm)
-                           (let ((name (car parm))
-                                         (val (cadr parm)))
-                           `(set! ,name ,val)))
-                         parms)
-          ,@bodies)
-        ,@(map (lambda (_) '())
-                   parms)))
+  `((lambda ()
+      ,@(map (lambda (e)
+               `(define ,@e))
+             parms)
+      ,@bodies)))
 
 (define-builtin-macro (cond . exps)

lang/scheme/3imp/check.scm

@@ -119 +119 @@
    (apply
     (apply + 1 2 '(3 4 5)))
-
 ;;;; INNER
+   ;; ��define
+   (internal-define
+    (begin
+      (define hoge 123)
+      (begin hoge)))
+   ;; 
    (simple-direct-invocation
     ((lambda (x) (* x x)) 111))