Changeset 9113 for lang/elisp

Show
Ignore:
Timestamp:
04/08/08 10:54:59 (8 months ago)
Author:
lieutar
Message:

lang/elisp/escm/trunk: I added new instruction into intermediate code.

Location:
lang/elisp/escm/trunk
Files:
4 added
16 modified

Legend:

Unmodified
Added
Removed

  • lang/elisp/escm/trunk/DEVELOPERSTOOLS.el

    r8609 r9113  
     1;; initialize enviroment for developer. 
    12(let ((dir (file-name-directory (buffer-file-name)))) 
     3 
    24  (unless (member  dir load-path ) 
    35    (setq load-path (cons dir load-path))) 
     6 
    47  (require 'escm) 
     8 
    59  (global-set-key [?\C-c ?e ?a] 'escm-debug::activate) 
    610  (global-set-key [?\C-c ?e ?d] 'escm-debug::deactivate) 
    7   (dired (file-name-directory (buffer-file-name)))) 
     11  (global-set-key [?\C-c ?e ?c] 
     12                  (lambda () 
     13                    (interactive) 
     14                    (setq escm-default-vm nil) 
     15                    (message "default vm is resetted."))) 
     16  (global-set-key [?\C-c ?e ?e] 'escm-eval-last-sexp) 
     17  nil) 
    818 
     19 
     20;; dired 
     21(dired (file-name-directory (buffer-file-name))) 
     22 
     23 
     24;; sample codes 
    925(when nil 
    1026 
     27  (escm-vm::eval (escm-vm::new)  '(+ 0 1 2 3)) 
    1128  (escm-vm::eval (escm-vm::new)  '(+ 0 1 (* 2 3) 4)) 
    1229  (escm-vm::eval (escm-vm::new)  '(if nil 1 2)) 
    13  
    1430  (escm-vm::eval 
    1531   (escm-vm::new) 
    … …  
    1733       (define (fact n) (if (= n 1) n (* n (fact (- n 1))))) 
    1834       (fact 3)))) 
     35 
     36  (progn  
     37    (defun fib (n) 
     38      (if (< n 2) 
     39          1 
     40        (+ (fib (- n 2)) 
     41           (fib (- n 1))))) 
     42    (fib 7)) 
     43 
     44  (escm-eval '(fib 7)) 
     45 
     46  (escm-vm::eval 
     47   (escm-vm::new) 
     48   '((lambda () 
     49       (message (call/cc (lambda (cont) 
     50                           (cont "abc"))))))) 
     51 
     52 
    1953 
    2054  (escm-vm::eval 
    … …  
    3165   (escm-vm::new) 
    3266   '((lambda () 
     67       (define (fib-iter a b n) 
     68         (if (zero? n) 
     69             (+ a b) 
     70           (fib-iter b 
     71                     (+ a b) 
     72                     (- n 1)))) 
     73       (define (fib n) (fib-iter 0 1 n)) 
     74       (fib 12)))) 
     75;;  
    3376 
    34        (define (fib-iter a b n) 
    35          (if (= 0 n) 
    36              (+ a b) 
    37            (fib-iter 
    38             b 
    39             (+ a b) 
    40             (- n 1)))) 
     77  (let* ((def '((define (fib-iter a b n) 
     78                  (if (zero? n) 
     79                      (+ a b) 
     80                    (fib-iter b 
     81                              (+ a b) 
     82                              (- n 1)))) 
     83                (define (fib n) (fib-iter 0 1 n)))) 
     84         (bm   (lambda (x) 
     85                 (escm-util::benchmark 
     86                  (escm-vm::eval (escm-vm::new) x)) 
     87                 escm-util::benchmark::result))) 
     88    (list (funcall bm nil) 
     89          (funcall bm `((lambda () ,@def ))) 
     90          (funcall bm `((lambda () ,@def (fib 1)))) 
     91          (funcall bm `((lambda () ,@def (fib 10)))) 
     92          (funcall bm `((lambda () ,@def (fib 100)))))) 
    4193 
    42        (define (fib n) 
    43          (fib-iter 0 1 n)) 
     94  (escm-vm::eval (escm-vm::new) '`a) 
    4495 
    45        (fib 32) 
    46        ))) 
     96  (escm-vm::eval 
     97   (escm-vm::new) '((lambda () 
     98                      (define-syntax a (lambda (_ . x) (list 'quote x))) 
     99                      (a b c)))) 
    47100 
    48   (progn 
    49     (define (fact n) (if (= n 1)        n (* n (- n 1)))) 
    50     (escm-eval '(fact 5)) 
    51     ) 
    52  
    53  
     101  (define (fact n) (if (= n 1) 
     102                       n 
     103                     (* n (fact (- n 1))))) 
     104  (escm-eval '(fact 20)) 
     105  (fact 1) 
     106  ((elambda (a b) (+ a b)) 1 2) 
    54107  ) 

  • lang/elisp/escm/trunk/escm-arity.el

    r8609 r9113  
    5555    new)) 
    5656 
    57  
    58  
    5957(defsubst escm-arity::inject-args! (self env args) 
    6058  (let ((p        (escm-arity::get-length   self)) 
    … …  
    6967(provide 'escm-arity) 
    7068 
    71  
    72  
    73  
    7469;;; test codes 
    7570(escm-test::define-test escm arity 
    7671  (let ((z (escm-arity::new  ())) 
    77         (o (escm-arity::new  '(a b c))) 
     72        (a0 (escm-arity::new  '(a b c))) 
    7873        (a1 (escm-arity::new 'a)) 
    79         (a2 (escm-arity::new '(a . b)))) 
     74        (a2 (escm-arity::new '(a b . c))) 
     75 
     76        (e0 (escm-fixed-env::new nil '(a b c))) 
     77        (e1 (escm-fixed-env::new nil '(a))) 
     78        (e2 (escm-fixed-env::new nil '(a b c)))) 
     79 
    8080    (escm-test one1         (= 1 (escm-arity::get-length a1))) 
    8181    (escm-test zero         (= 0 (escm-arity::get-length z))) 
    82     (escm-test three        (= 3 (escm-arity::get-length o))) 
     82    (escm-test three        (= 3 (escm-arity::get-length a0))) 
    8383    (escm-test not-at-least (not (escm-arity::get-at-least z))) 
     84 
     85    (escm-test at-least-1   (escm-arity::get-at-least a1)) 
    8486    (escm-test at-least-2   (escm-arity::get-at-least a2)) 
    85     (escm-test at-least-1   (escm-arity::get-at-least a1))) 
    86   ) 
     87 
     88    (escm-test inject-args0 
     89               (progn 
     90                 (escm-arity::inject-args! a0 e0 '(1 2 3)) 
     91                 (equal '(1 2 3) 
     92                        (list (escm-env::gref e0 'a) 
     93                              (escm-env::gref e0 'b) 
     94                              (escm-env::gref e0 'c))))) 
     95 
     96     
     97    (escm-test inject-args1 
     98               (progn 
     99                 (escm-arity::inject-args! a1 e1 '(x y z)) 
     100                 (equal '(x y z) 
     101                        (escm-env::gref e1 'a)))) 
     102 
     103     
     104    (escm-test inject-args2 
     105               (progn 
     106                 (escm-arity::inject-args! a2 e2 '(a b c d)) 
     107                 (equal '(a b (c d)) 
     108                        (list (escm-env::gref e2 'a) 
     109                              (escm-env::gref e2 'b) 
     110                              (escm-env::gref e2 'c))))))) 
    87111;; (escm-test::run 'escm 'arity) 
    88112 

  • lang/elisp/escm/trunk/escm-base.el

    r8609 r9113  
    1414 
    1515 
    16  
    17  
    1816;; errors for escm 
    1917(escm-util::define-signals 
    2018 '(escm-error "" 
     19   (escm-syntax-error  "") 
    2120   (escm-void-variable "") 
    22    (escm-unsupported ""))) 
     21   (escm-unsupported   ""))) 
    2322 
    2423(provide 'escm-base) 

  • lang/elisp/escm/trunk/escm-cbos.el

    r8609 r9113  
    8181  "defines method of escm-cbos objects."    
    8282  `(progn 
    83      ,(when t;;(not (fboundp 'name)) 
     83     ,(when (not (fboundp 'name)) 
    8484        `(defsubst ,name (*object* &rest args) 
    8585           (escm-cbos::run-method ',name *object* args))) 
    … …  
    9191          (get 'escm-cbos::class-vmt ',class) 
    9292          ',name 
    93           ;;      (byte-compile (escm-cbos::expand-method ',args ',body))) 
    94           (escm-cbos::expand-method ',args ',body)) 
     93          (byte-compile (escm-cbos::expand-method ',args ',body))) 
     94          ;;(escm-cbos::expand-method ',args ',body)) 
    9595        ) 
    9696     ',name)) 

  • lang/elisp/escm/trunk/escm-compile.el

    r8609 r9113  
    33;; Copyright (C) 2008  Free Software Foundation, Inc. 
    44 
    5 ;; Author: (require 'escm-util  ) <onishi@THOTH> 
     5;; Author: <onishi@THOTH> 
    66;; Keywords: lisp 
    77 
    … …  
    2727;;; Code: 
    2828 
    29 (require 'escm-base  ) 
    30 (require 'escm-syntax) 
    31 (require 'escm-icode ) 
    32 (require 'escm-env   ) 
     29(require 'escm-base   ) 
     30(require 'escm-syntax ) 
     31(require 'escm-icode  ) 
     32(require 'escm-env    ) 
    3333(require 'escm-context) 
    34  
    3534 
    3635(defun escm-compile (context sexp) 
    … …  
    9493         (context (escm-context::new root)) 
    9594         (r       (escm-compile-apply context '(a (b 1) c))) 
    96          (ex       (escm-icode `((push) 
    97  
    98                                    (push) 
     95         (ex       (escm-icode `((push 1) 
     96 
     97                                   (push 1) 
    9998                                     (store 1) 
    10099                                     (to-arg) 
    … …  
    113112;; (escm-test::run 'escm 'escm-compile-apply) 
    114113 
    115  
    116  
    117  
    118114(defsubst escm-compile-if::ifv0 (context condx positivex negativex) 
     115  "" 
    119116  (let ((posi0 (escm-iproc::get-first-block positivex)) 
    120117        (nega0 (escm-iproc::get-first-block negativex)) 
    … …  
    126123 
    127124(defsubst escm-compile-if::ifv1 (context condx positivex negativex) 
     125  "" 
    128126  (let ((posi0 (escm-iproc::get-first-block positivex)) 
    129127        (nega0 (escm-iproc::get-first-block negativex)) 
    … …  
    135133 
    136134(defsubst escm-compile-if::with-jump (context condx positivex negativex) 
     135  "" 
    137136  (escm-iproc::merge negativex 
    138137                     (escm-icode `((jmp ,(escm-iproc::length positivex))))) 
    … …  
    156155         (t (escm-compile-if::with-jump context condx positivex negativex))))) 
    157156 
    158  
    159157;;; 
    160158(escm-test::define-test escm escm-compile-if 
    … …  
    163161 
    164162         (r0      nil) 
    165          (e0      (escm-icode `((fref x ,root) 
     163         (e0      (escm-icode `((push 1) 
     164                                (fref x ,root) 
    166165                                (call) 
    167166                                (ifv ((ref y ,root)) 
    … …  
    172171 
    173172    (escm-test compile-0 (setq r0 (escm-compile-if context '(if (x) y z))) t) 
    174     (escm-test::p 'compile-0 (escm-iproc::to-string r0)) 
    175     (escm-test::p 'compile-0 (escm-iproc::to-string e0)) 
     173    (escm-test::p 'r0 (escm-iproc::to-string r0)) 
     174    (escm-test::p 'e0 (escm-iproc::to-string e0)) 
    176175    (escm-test check-0 (equal r0 e0)) 
    177176 
    … …  
    190189;;(escm-test::run 'escm 'escm-compile-if) 
    191190 
    192  
    193  
    194  
    195  
    196  
     191(defun escm-compile-elamba (context sexp) 
     192  (let* ((elfun (byte-compile (cons 'lambda (cdr sexp))))) 
     193    (escm-icode `((store ,(escm-wrapped-proc::new elfun)))))) 
     194 
     195 
     196 
     197(defun escm-compile-let (context sexp) 
     198  (let* ((bindings (cadr sexp)) 
     199         (body     (cddr sexp)) 
     200         (name     (unless (listp binding) 
     201                     (let ((name bindings)) 
     202                       (setq bindings (car body)) 
     203                       (setq body     (cdr body)) 
     204                       name))) 
     205         (syms    ()) 
     206         (vals    ())) 
     207    (mapcar 
     208     (lambda (b) 
     209       (setq syms (cons (car  b) syms)) 
     210       (setq vals (cons (escm-compile 
     211                         (escm-context::set-tail? context nil) 
     212                         (cadr b)) vals)) bindings) 
     213     bindings) 
     214    (when name (setq syms (cons name syms))) 
     215    (let ((proc (escm-compile context `(lambda ,syms ,body))) 
     216          (ret  (escm-iproc::new ()))) 
     217      
     218      (mapcar 
     219       (lambda (v) (escm-iproc::merge ret v)) 
     220       (if name (cons (escm-iproc `((store-to-arg ,proc))) vals) 
     221         vals)) 
     222      ret))) 
     223;; 
     224 
     225;; 
    197226(defun escm-compile-define-syntax (context sexp) 
    198227  (let ((name (cadr  sexp)) 
    199         (proc (caddr sexp))) 
     228        (proc (escm-vm::eval 
     229               (escm-context::get-vm context) 
     230               (caddr sexp)))) 
    200231    (escm-env::define (escm-context::get-env context) 
    201232                      name 
    202                       (escm-syntax::new proc)))) 
     233                      (escm-syntax::new proc)) 
     234    (escm-icode `((store ',name))))) 
     235 
     236(escm-test::define-test escm define-syntax 
     237  (let* ((vm  (escm-vm::new)) 
     238         (env (escm-vm::current-env vm)) 
     239         (ctx (escm-context::new env vm))) 
     240  (escm-test compile0 (escm-compile-define-syntax 
     241                       ctx 
     242                       '(define-syntax x (lambda (_ . body) 
     243                                           1))) 
     244             t) 
     245  (escm-test compile1 (escm-syntax-p (escm-env::gref env 'x))) 
     246  (escm-test expand   (escm-iproc::equal (escm-icode '((store 1))) 
     247                                         (escm-test::p "result" (escm-compile ctx '(x))))) 
     248  )) 
     249;; (escm-test::run 'escm 'define-syntax) 
     250 
     251 
     252 
     253 
    203254;; 
    204255(defun escm-compile-let-syntax (context sexp) 
    … …  
    218269    ret)) 
    219270 
    220 ;;;; 
    221  
     271;; 
    222272(defsubst escm-compile-lambda1 (context sexp) 
    223273  (let* ((argspec (cadr sexp)) 
    … …  
    239289    (escm-iproc::to-proc proc arity (escm-context::get-env ctx)))) 
    240290 
     291;; 
    241292(defun escm-compile-lambda (context sexp) 
    242   "" 
    243293  (escm-icode `((store-proc ,(escm-compile-lambda1 context sexp))))) 
    244 ;;; 
     294 
     295;; 
    245296(escm-test::define-test escm escm-compile-lambda 
    246297  (let* ((vm      (escm-vm::new)) 
    … …  
    263314;; (escm-test::run 'escm 'escm-compile-lambda) 
    264315 
     316;; 
     317(defun escm-compile-elambda (context sexp) 
     318  (let ((body (cdr sexp))) 
     319    (escm-icode 
     320     `((store-proc 
     321        ,(escm-wrapped-proc::new 
     322          (if  (= (length body) 1) 
     323              body 
     324            (byte-compile (cons 'lambda body))))))))) 
    265325 
    266326;; 
    … …  
    271331      `(, name ,(caddr sexp))))) 
    272332 
     333;; 
    273334(defun escm-compile-define (context sexp) 
    274335  (let* ((spec (escm-compile-define1  context sexp)) 
    … …  
    281342                                     (store ',name)))))) 
    282343 
     344;; 
    283345(escm-test::define-test escm escm-compile-define 
    284346  (let* ((vm  (escm-vm::new)) 
    … …  
    292354    (escm-test::p 
    293355     "ex0" 
    294      (escm-iproc::to-string (escm-compile context '(define (a n) n)))) 
     356     (escm-iproc::to-string 
     357      (escm-compile context '(define (a n) n)))) 
    295358 
    296359    (escm-test::p 
    297360     "ex1" 
    298      (escm-iproc::to-string (escm-compile context '((lambda (n) (define (a n) n) (a n)) 5)))) 
     361     (escm-iproc::to-string 
     362      (escm-compile context '((lambda (n) (define (a n) n) (a n)) 5)))) 
    299363 
    300364    (escm-test::p 
    301365     "ex2" 
    302      (escm-iproc::to-string (escm-compile context '((lambda () (define (a n) n) (a 5)))))) 
     366     (escm-iproc::to-string 
     367      (escm-compile context '((lambda () (define (a n) n) (a 5)))))) 
    303368     )) 
    304369;;; (escm-test::run 'escm 'escm-compile-define) 
    305370 
    306  
    307371;; 
    308372(defun escm-compile-quote (context sexp) 
    309373  (escm-icode `((store ',(cadr sexp))))) 
    310374 
    311  
    312  
    313  
    314 ;;(setq escm-vm::init-hook nil) 
    315 (add-hook 
    316  'escm-vm::init-hook 
    317  (lambda (vm) 
    318  
    319    (escm-define-builtin-syntax vm quote 
    320      (function escm-compile-quote)) 
    321  
    322    (escm-define-builtin-syntax vm if 
    323      (function escm-compile-if)) 
    324  
    325    (escm-define-builtin-syntax vm let-syntax 
    326      (function escm-compile-let-syntax)) 
    327  
    328    (escm-define-builtin-syntax vm define-syntax 
    329      (function escm-compile-define-syntax)) 
    330  
    331    (escm-define-builtin-syntax vm define 
    332      (function escm-compile-define)) 
    333  
    334    (escm-define-builtin-syntax vm lambda 
    335      (function escm-compile-lambda)) 
    336   ));; END OF INITIALIZER 
    337  
    338  
    339  
     375;; 
     376(defsubst escm-compile::init-vm (vm) 
     377 
     378  (mapcar 
     379   (lambda (spec) 
     380     (escm-define-builtin-syntax 
     381       vm (car spec) (cadr spec))) 
     382   `((quote         escm-compile-quote) 
     383     (if            escm-compile-if) 
     384     (let           escm-compile-let) 
     385     (let-syntax    escm-compile-let-syntax) 
     386     (define-syntax escm-compile-define-syntax) 
     387     (define        escm-compile-define) 
     388     (lambda        escm-compile-lambda) 
     389     (elambda       escm-compile-elambda))) 
     390 
     391   (escm-vm::eval 
     392    vm 
     393    '(define-syntax quasiquote 
     394         (lambda (_ . body) 
     395           (expand-quasiquote (list 'quote body))))) 
     396  ) 
     397 
     398(add-hook 'escm-vm::init-hook (function escm-compile::init-vm)) 
    340399 
    341400(provide 'escm-compile) 

  • lang/elisp/escm/trunk/escm-context.el

    r8609 r9113  
    3131(escm-cbos::define-class 
    3232 (escm-context escm-object t) 
    33  (objdic :copy)         ;; created objects. 
     33 (objdic :copy)  ;; created objects. 
    3434 (env    :copy)  ;; environment of current context. 
    3535 (vm     :copy)  ;; virtual machine. 
    … …  
    102102    `(let ((e (escm-fixed-env::new ,syms))) 
    103103       ,@(mapcar (lambda (sv) 
    104                    `(escm-env::gset! e ',(car sv) ,(escm-object::elize (cdr sv)))) 
     104                   `(escm-env::gset! 
     105                     e ',(car sv) ,(escm-object::elize (cdr sv)))) 
    105106                 symval) 
    106107       e))) 

  • lang/elisp/escm/trunk/escm-debug.el

    r8609 r9113  
    154154(defface  escm-debug::other-block-face 
    155155  '((((class color) (background light)) 
    156      (:foreground "DarkGreen"  :background "gray80")) 
     156     (:foreground "green" )) 
    157157    (((class color) (background dark)) 
    158158     (:foreground "purple")) 
    … …  
    196196      (setq vmwin (split-window-horizontally)) 
    197197      (shrink-window-horizontally (- (window-width) 20)) 
    198 ;;      (setq vmwin (split-window)) 
    199  
    200198      (select-window vmwin) 
    201199      (switch-to-buffer vmbuf) 
    … …  
    215213  (ad-deactivate 'escm-debug)) 
    216214 
    217  
    218215(provide 'escm-debug) 
    219216;;; escm-debug.el ends here 

  • lang/elisp/escm/trunk/escm-env.el

    r8609 r9113  
    114114                                       sym)))) 
    115115 
    116 ;; (escm-iproc::report (escm-compile-apply (escm-context::new (escm-root-env::new)) '(* n (a 1)))) 
    117 ;; (escm-iproc::report (escm-compile-if (escm-context::new (escm-root-env::new)) ' (if (< n 2) 1 (* n (a (- n 1)))))) 
    118 ;; 
    119 ;; (escm-vm::eval (escm-vm::new) '((lambda() (define (a n) n) (a 5)))) 
    120 ;; (escm-vm::eval (escm-vm::new) '(< 2 5)) 
    121  
    122  
    123116;;;;;;;;;; 
    124  
    125117(escm-cbos::define-method escm-env escm-env::make-setter (self env sym val) 
    126118  "" 
    … …  
    268260  (escm-dynamic-env::gset! self sym val)) 
    269261 
    270  
    271262(defsubst escm-dynamic-env::gref (self sym) 
    272263  (if (escm-env::member? self sym) 
    … …  
    279270(escm-cbos::define-method escm-dynamic-env escm-env::gref (self sym) 
    280271  (escm-dynamic-env::gref self sym)) 
     272 
    281273 
    282274;; test code for escm-dynamic-env 
    … …  
    297289                                  (eq 3 (escm-env::gref gg 'a)))))) 
    298290;; (escm-test::run 'escm 'dynamic-env) 
     291 
     292;;; 
     293;;; pseudo-env 
     294;;; 
     295(escm-cbos::define-class (escm-pseudo-env escm-dynamic-env)) 
     296(defun escm-pseudo-env::new (parent syms) 
     297  ) 
     298 
    299299 
    300300;;; 
    … …  
    382382    new)) 
    383383 
     384(escm-cbos::define-method escm-dynamic-env escm-env::make-function-referer 
     385  (self env sym) 
     386  `(escm-env::fref ,env ',sym)) 
     387 
     388 
    384389(escm-cbos::define-method escm-dynamic-env escm-env::make-referer 
    385390  (self env sym) 

  • lang/elisp/escm/trunk/escm-icode.el

    r8609 r9113  
    9696 
    9797(defsubst escm-pseudo-iproc::new (body src)