Changeset 31243 for lang/scheme

Timestamp:

03/15/09 18:09:08 (4 years ago)

Author:

mokehehe

Message:

 

Location:

lang/scheme/3imp

Files:

• 4.7.scm (modified) (7 diffs)
• opsym2code.scm (modified) (1 diff)

lang/scheme/3imp/4.7.scm

@@ -370 +370 @@
                          (VM a x f c (shift-args n m s))))
                 (APPLY (argnum)
-                       (let ((s (push argnum s)))
-                         (cond ((primitive-function? a)
-                                                                (let ((res (call-primitive-function a s argnum)))
-                                                                  (do-return res s)))
-                                                           ((my-procedure? a)
-                                                                (let ((ss (check-argnum a argnum s)))
-                                                                  (VM a (closure-body a) ss a ss)))
-                                                           (else
-                                                                (error "invalid application:" a)))))
+                                           (do-apply argnum a s))
                 (RETURN ()
                         (do-return a s))
@@ -389 +381 @@
                 (else
                  (error "unknown opcode" (car x)))))
+
+(define (do-apply argnum a s)
+  (let ((s (push argnum s)))
+        (cond ((primitive-function? a)
+                   (let ((res (call-primitive-function a s argnum)))
+                         (do-return res s)))
+                  ((my-procedure? a)
+                   (let ((ss (check-argnum a argnum s)))
+                         (VM a (closure-body a) ss a ss)))
+                  (else
+                   (error "invalid application:" a)))))
 
 (define (do-return a s)
@@ -436 +439 @@
          (ss (push-args2 args s2))
          (argnum (- ss s2)))
-    (VM c (list APPLY argnum) ss c ss)))
+        (do-apply argnum c ss)))
 
 (define (check-argnum c argnum s)
@@ -735 +738 @@
   (define-primitive-function list)
   (define-primitive-function append)
+  (define-primitive-function list*)
   (define-primitive-function last-pair)
   (define-primitive-function read)
@@ -747 +751 @@
   (define-primitive-function length)
   (define-primitive-function gensym)
+  (define-primitive-function error)
 
   (define-primitive-function make-hash-table)
@@ -778 +783 @@
   (define-primitive-function2 (primitive-function? args s)
                               (procedure? (car args)))
+  (define-primitive-function2 (evaluate args s)
+                              (evaluate-from-stack (car args) s))
+  (define-primitive-function2 (vm-apply args s)
+                              (apply vm-apply s (cadr args) (cddr args)))
   )
 
@@ -926 +935 @@
                         `(begin ,@sexps
                            #t)))
+
+;;eof

lang/scheme/3imp/opsym2code.scm

@@ +1 @@
+#!/usr/local/bin/gosh
 
 (define optbl