Changeset 31243 for lang/scheme

Show
Ignore:
Timestamp:
03/15/09 18:09:08 (6 years ago)
Author:
mokehehe
Message:
 
Location:
lang/scheme/3imp
Files:
2 modified

Legend:

Unmodified
Added
Removed
  • lang/scheme/3imp/4.7.scm

    r31230 r31243  
    370370                         (VM a x f c (shift-args n m s)))) 
    371371                (APPLY (argnum) 
    372                        (let ((s (push argnum s))) 
    373                          (cond ((primitive-function? a) 
    374                                                                 (let ((res (call-primitive-function a s argnum))) 
    375                                                                   (do-return res s))) 
    376                                                            ((my-procedure? a) 
    377                                                                 (let ((ss (check-argnum a argnum s))) 
    378                                                                   (VM a (closure-body a) ss a ss))) 
    379                                                            (else 
    380                                                                 (error "invalid application:" a))))) 
     372                                           (do-apply argnum a s)) 
    381373                (RETURN () 
    382374                        (do-return a s)) 
     
    389381                (else 
    390382                 (error "unknown opcode" (car x))))) 
     383 
     384(define (do-apply argnum a s) 
     385  (let ((s (push argnum s))) 
     386        (cond ((primitive-function? a) 
     387                   (let ((res (call-primitive-function a s argnum))) 
     388                         (do-return res s))) 
     389                  ((my-procedure? a) 
     390                   (let ((ss (check-argnum a argnum s))) 
     391                         (VM a (closure-body a) ss a ss))) 
     392                  (else 
     393                   (error "invalid application:" a))))) 
    391394 
    392395(define (do-return a s) 
     
    436439         (ss (push-args2 args s2)) 
    437440         (argnum (- ss s2))) 
    438     (VM c (list APPLY argnum) ss c ss))) 
     441        (do-apply argnum c ss))) 
    439442 
    440443(define (check-argnum c argnum s) 
     
    735738  (define-primitive-function list) 
    736739  (define-primitive-function append) 
     740  (define-primitive-function list*) 
    737741  (define-primitive-function last-pair) 
    738742  (define-primitive-function read) 
     
    747751  (define-primitive-function length) 
    748752  (define-primitive-function gensym) 
     753  (define-primitive-function error) 
    749754 
    750755  (define-primitive-function make-hash-table) 
     
    778783  (define-primitive-function2 (primitive-function? args s) 
    779784                              (procedure? (car args))) 
     785  (define-primitive-function2 (evaluate args s) 
     786                              (evaluate-from-stack (car args) s)) 
     787  (define-primitive-function2 (vm-apply args s) 
     788                              (apply vm-apply s (cadr args) (cddr args))) 
    780789  ) 
    781790 
     
    926935                        `(begin ,@sexps 
    927936                           #t))) 
     937 
     938;;eof 
  • lang/scheme/3imp/opsym2code.scm

    r31152 r31243  
     1#!/usr/local/bin/gosh 
    12 
    23(define optbl