Changeset 9113 for lang/elisp

Show
Ignore:
Timestamp:
04/08/08 10:54:59 (7 years 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) 
    98   (let ((new (create-escm-iproc))) 
     98  (let ((new (create-escm-pseudo-iproc))) 
    9999    (escm-iproc::set-body new body) 
    100100    (escm-iproc::set-src  new src) 
     
    102102 
    103103(defsubst escm-iproc::to-proc (self arity env) 
     104  "Creates `escm-proc' object from the arguments. 
     105The created object contains codes that is explained by SELF. 
     106The applying the procedure is under the ENV." 
    104107  (escm-proc::new 
    105108   arity 
     
    107110   (escm-iproc::build  self) 
    108111   self)) 
     112 
     113(defsubst escm-iproc::to-pseudo-iproc (self arity env) 
     114  ()) 
    109115 
    110116(defun escm-iproc::to-debug-info1 (self) 
     
    166172             ((escm-cbos::isa node 'escm-iblock-content) 
    167173              (list (escm-iblock::new (list node)))) 
    168              (t (signal 'error '(panic))))))) 
     174             (t (signal 'error (list 'panic node))))))) 
    169175  self) 
    170176 
  • lang/elisp/escm/trunk/escm-preprocess.el

    r8609 r9113  
    2929(require 'escm-base) 
    3030 
     31(defsubst escm-preprocess::process-elisp-quotes::procsym (sym) 
     32  (let ((name (symbol-name sym))) 
     33    (if (member name '("`" ",@" ",")) sym 
     34      (cond  ((string-match "`"  name) 
     35              (list 'quasiquote (intern (substring name 1)))) 
     36 
     37             ((string-match ",@" name) 
     38              (list 'unquote-splicing (intern (substring name 2)))) 
     39 
     40             ((string-match ","  name) 
     41              (list 'unquote (intern (substring name 1)))) 
     42 
     43             (t sym))))) 
     44 
    3145(defun escm-preprocess::process-elisp-quotes (sexp) 
    3246  (if(listp sexp) 
     
    3448            (last     nil) 
    3549            (qq       (intern "`")) 
    36             (uq       (intern ","))) 
     50            (uq       (intern ",")) 
     51            (uqs      (intern ",@"))) 
     52 
    3753        (while sexp 
    3854          (let ((next)) 
    3955            (if (listp sexp) 
    40                 (setq retval 
    41                       (cons 
    42                        (let ((head (car sexp))) 
    43                          (if (listp head) 
    44                              (progn 
    45                                (setq next (cdr sexp)) 
    46                                (escm-preprocess::preprocess-elisp-quotes head)) 
    47                            (cond 
    48                             ((eq head qq) 
    49                              (setq next (cddr sexp)) 
    50                              (list 'quasiquote 
    51                                    (escm-preprocess::preprocess-elisp-quotes 
    52                                     (cadr sexp)))) 
    53                             ((eq head uq) 
    54                              (setq next (cddr sexp)) 
    55                              (list 'unquote 
    56                                    (escm-preprocess::preprocess-elisp-quotes 
    57                                     (cadr sexp)))) 
    58                             (t 
    59                              (setq next (cdr sexp)) 
    60                              head))) 
    61                          ) 
    62                        retval)) 
     56                (setq 
     57                 retval 
     58                 (cons 
     59                  (let ((head (car sexp))) 
     60                    (cond 
     61                     ((listp head) 
     62                      (setq next (cdr sexp)) 
     63                      (escm-preprocess::process-elisp-quotes head)) 
     64 
     65                     ((symbolp head) 
     66                      (let ((head 
     67                             (escm-preprocess::process-elisp-quotes::procsym 
     68                              head))) 
     69                        (cond 
     70                         ((listp head) 
     71                          (setq next (cdr sexp)) 
     72                          head) 
     73 
     74                         ((eq head qq) 
     75                          (setq next (cdr sexp)) 
     76                          'quasiquote) 
     77 
     78                         ((eq head uqs) 
     79                          (setq next (cddr sexp)) 
     80                          (list 'unquote-splicing 
     81                                (escm-preprocess::process-elisp-quotes 
     82                                 (cadr sexp)))) 
     83 
     84                         ((eq head uq) 
     85                          (setq next (cddr sexp)) 
     86                          (list 'unquote 
     87                                (escm-preprocess::process-elisp-quotes 
     88                                 (cadr sexp)))) 
     89 
     90                         (t (setq next (cdr sexp)) 
     91                            head)))) 
     92 
     93                     (t (setq next (cdr sexp)) 
     94                        head))) 
     95                  retval)) 
    6396              (progn 
    6497                (setq last (list sexp)) 
    6598                (setq sexp nil))) 
    66             (setq sexp next))) 
     99            (setq sexp next))) 
    67100        (append (reverse retval) last)) 
    68     sexp)) 
     101    (escm-preprocess::process-elisp-quotes::procsym sexp))) 
    69102 
    70103 
    71104 
     105(escm-test::define-test escm escm-preprocess 
     106 
     107  (escm-test sym0 
     108             (eq (escm-preprocess::process-elisp-quotes::procsym (intern "`")) 
     109                 (intern "`"))) 
     110  (escm-test sym1 
     111             (eq (escm-preprocess::process-elisp-quotes::procsym (intern ",")) 
     112                 (intern ","))) 
     113  (escm-test sym2 
     114             (eq (escm-preprocess::process-elisp-quotes::procsym (intern ",@")) 
     115                 (intern ",@"))) 
     116 
     117  (escm-test normal-list 
     118             (equal 
     119              '(a b c) 
     120              (escm-test::p  
     121               'quasiquote 
     122               (escm-preprocess::process-elisp-quotes '(a b c))))) 
     123 
     124  (escm-test quasiquote-0 
     125             (equal 
     126              '(a (quasiquote (b)) c) 
     127              (escm-test::p  
     128               'quasiquote 
     129               (escm-preprocess::process-elisp-quotes '(a `(b) c))))) 
     130 
     131  (escm-test quasiquote-1 
     132             (equal 
     133              '(quasiquote (a (unquote (b (unquote c))) 
     134                              (unquote-splicing d) (unquote-splicing (e f)))) 
     135              (escm-test::p  
     136               'quasiquote 
     137               (escm-preprocess::process-elisp-quotes 
     138                '(`(a ,(b ,c) ,@d ,@(e f)))))))) 
     139;;(escm-test::run 'escm 'escm-preprocess) 
     140 
    72141(provide 'escm-preprocess) 
    73142;;; escm-preprocess.el ends here 
  • lang/elisp/escm/trunk/escm-proc.el

    r8609 r9113  
     1;;; escm-proc.el --- 
     2 
     3;; Copyright (C) 2008  Free Software Foundation, Inc. 
     4 
     5;; Author: Zaurus User <zaurus@localhost.localdomain> 
     6;; Keywords: 
     7 
     8;; This file is free software; you can redistribute it and/or modify 
     9;; it under the terms of the GNU General Public License as published by 
     10;; the Free Software Foundation; either version 2, or (at your option) 
     11;; any later version. 
     12 
     13;; This file is distributed in the hope that it will be useful, 
     14;; but WITHOUT ANY WARRANTY; without even the implied warranty of 
     15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
     16;; GNU General Public License for more details. 
     17 
     18;; You should have received a copy of the GNU General Public License 
     19;; along with GNU Emacs; see the file COPYING.  If not, write to 
     20;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
     21;; Boston, MA 02111-1307, USA. 
     22 
     23;;; Commentary: 
     24 
     25;; 
     26 
     27;;; Code: 
     28 
    129(require 'escm-base) 
    230(require 'escm-env) 
     
    2755    new)) 
    2856 
    29  
    30  
     57(escm-cbos::define-method escm-proc escm-proc::to-elisp-function (self vm) 
     58  `(lambda (&optional *args*) 
     59     (escm-vm::apply ,vm ,self *args*))) 
     60 
     61 
     62 
     63;;; 
    3164(escm-cbos::define-class (escm-wrapped-proc escm-proc)) 
     65(escm-cbos::define-class (escm-wrapped-vm-method escm-wrapped-proc)) 
     66 
     67(escm-cbos::define-method 
     68  escm-wrapped-proc escm-wrapped-proc::make-expression (self fun) 
     69  `(apply ,(if (symbolp fun) (symbol-function fun) fun) 
     70          (escm-wrapped-proc-env::get-arg (escm-vm::current-env vm)))) 
     71 
     72(escm-cbos::define-method 
     73  escm-wrapped-vm-method escm-wrapped-proc::make-expression (self fun) 
     74  `(apply ,(if (symbolp fun) (symbol-function fun) fun) 
     75          (escm-wrapped-proc-env::get-arg 
     76           (cons vm (escm-vm::current-env vm))))) 
     77 
     78 
     79 
     80 
     81(defsubst escm-wrapped-proc::initialize (new fun) 
     82  (escm-proc::set-body 
     83   new 
     84   (vector 
     85;;      (byte-compile 
     86    `(lambda (vm *env*) 
     87       (escm-vm::set-current-val 
     88        vm ,(escm-wrapped-proc::make-expression new fun)) 
     89       (escm-vm::ret vm)) 
     90    ;;       ) 
     91    )) 
     92  (escm-proc::set-src new (escm-pseudo-iproc::new nil ["apply-subr" "ret"]))) 
     93 
    3294(defsubst escm-wrapped-proc::new (fun) 
    3395  (let ((new (create-escm-wrapped-proc))) 
    34     (escm-proc::set-body 
    35      new 
    36      (vector 
    37 ;;      (byte-compile 
    38        `(lambda (vm *env*) 
    39           (escm-vm::set-current-val 
    40            vm (apply ,(if (symbolp fun) (symbol-function fun) fun) 
    41                      (escm-wrapped-proc-env::get-arg (escm-vm::current-env vm)))) 
    42           (escm-vm::ret vm)) 
    43 ;;       ) 
    44       )) 
    45     (escm-proc::set-src new (escm-pseudo-iproc::new nil ["apply-subr" "ret"])) 
    46     new)) 
     96    (escm-wrapped-proc::initialize new fun) 
     97    new)) 
     98 
     99(defsubst escm-wrapped-vm-method::new (fun) 
     100  (let ((new (create-escm-wrapped-vm-method))) 
     101    (escm-wrapped-proc::initialize new fun) 
     102    new)) 
     103 
     104;;(escm-wrapped-proc::new (function +)) 
     105 
    47106;;   (escm-vm::eval (escm-vm::new)  '(+ 1 2)) 
    48107 
    49 (escm-cbos::define-method escm-wrapped-proc escm-proc::runtime-env (self vm) 
     108(escm-cbos::define-method 
     109  escm-wrapped-proc escm-proc::runtime-env (self vm) 
    50110  (escm-wrapped-proc-env::new (reverse (escm-vm::current-arg vm)))) 
    51111 
    52 (escm-cbos::define-method escm-wrapped-proc escm-proc::activate (self vm) 
     112(escm-cbos::define-method 
     113  escm-wrapped-proc escm-proc::activate (self vm) 
    53114  self) 
    54115 
    55  
     116(defsubst escm-continuation::new (vm) 
     117  (create-escm-wrapped-vm-method 
     118   `(lambda (vm val) 
     119      (let ((cont ,(let ((cont (create-escm-vm))) 
     120                     (set-env-stack  cont (copy-list (get-env-stack  vm))) 
     121                     (set-proc-stack cont (copy-list (get-proc-stack vm))) 
     122                     (set-src-stack  cont (copy-list (get-src-stack  vm))) 
     123                     (set-pc-stack   cont (copy-list (get-pc-stack   vm))) 
     124                     (set-arg-stack  cont (copy-list (get-arg-stack  vm)))) 
     125                     cont)) 
     126        (set-env-stack  vm (get-env-stack  cont)) 
     127        (set-proc-stack vm (get-proc-stack cont)) 
     128        (set-src-stack  vm (get-src-stack  cont)) 
     129        (set-pc-stack   vm (get-pc-stack   cont)) 
     130        (set-arg-stack  vm (get-arg-stack  cont)) 
     131        (set-val-stack  vm (list            val)))))) 
     132 
     133(defun escm::values (vm &rest vals) 
     134  (escm-vm::set-val-stack vm vals)) 
     135 
     136 
     137(defsubst escm::expand-quasiquote::list (vm sexp) 
     138  (apply (function append) 
     139         (mapcar (lambda (ex) 
     140                   (escm::expand-quasiquote1 vm ex)) 
     141                 sexp))) 
     142 
     143(defsubst escm::expand-quasiquote::special (vm sexp) 
     144  (when (listp sexp) 
     145    (case (car sexp) 
     146      (('unquote) 
     147       (list (escm-vm::eval vm sexp))) 
     148      (('unquote-splicing) 
     149       (escm-vm::eval vm sexp))))) 
     150 
     151(defsubst escm::expand-quasiquote1 (vm sexp) 
     152  (or 
     153   (escm::expand-quasiquote::special vm sexp) 
     154   (escm::expand-quasiquote::list    vm sexp) 
     155   (list sexp))) 
     156 
     157(defun escm::expand-quasiquote (vm sexp) 
     158  (car (escm::expand-quasiquote1 vm (cadr sexp)))) 
     159 
     160(defun escm::apply   (vm proc &rest args) 
     161  (let ((rargs (reverse args))) 
     162    (escm-vm::push-arg vm (append (reverse (cdr args)) (car args))) 
     163    (escm-vm::call vm proc))) 
     164 
     165(defun escm::eval    (vm sexp &optional context) 
     166  (let ((proc (escm-vm::compile-top-level vm))) 
     167    (escm-vm::call vm proc))) 
     168 
     169(defun escm::call/cc (vm proc) 
     170  (escm-vm::push-arg vm (list (escm-continuation::new vm))) 
     171  (escm-vm::call vm proc)) 
    56172 
    57173(defun escm-proc::initialize-vm (vm) 
    58   (escm-vm::define vm 'pair? (escm-wrapped-proc::new (function consp))) 
    59   (escm-vm::define vm 'zero? (escm-wrapped-proc::new (lambda (n) (= n 0)))) 
    60   (escm-vm::define vm 'null? (escm-wrapped-proc::new 'null)) 
     174  (mapcar 
     175 
     176   (lambda (spec) 
     177     (let ((fun  (car spec)) 
     178           (bind (cdr spec))) 
     179       (mapcar 
     180        (lambda (spec) 
     181          (escm-vm::define 
     182           vm (car spec) (apply fun (cdr spec)))) 
     183        bind))) 
     184 
     185   `((escm-wrapped-proc::new 
     186      . ((pair?  consp) 
     187         (zero?  ,(lambda (n) (= n 0))) 
     188         (list?  listp) 
     189         (null?  null) 
     190         )) 
     191 
     192     (escm-wrapped-vm-method::new 
     193      . ((expand-quasiquote      escm::expand-quasiquote) 
     194         (values                 escm::values) 
     195         (apply                  escm::apply) 
     196         (eval                   escm::eval) 
     197         (call/cc                escm::call/cc) 
     198         (call-with-continuation escm::call/cc) 
     199         )))) 
    61200  ) 
    62201(add-hook 'escm-vm::init-hook (function escm-proc::initialize-vm)) 
    63202 
    64203(provide 'escm-proc) 
     204;;; escm-proc.el ends here 
  • lang/elisp/escm/trunk/escm-syntax.el

    r8609 r9113  
     1;;; escm-syntax.el ---  
     2 
     3;; Copyright (C) 2008  Free Software Foundation, Inc. 
     4 
     5;; Author: (require 'escm-base) <onishi@THOTH> 
     6;; Keywords:  
     7 
     8;; This file is free software; you can redistribute it and/or modify 
     9;; it under the terms of the GNU General Public License as published by 
     10;; the Free Software Foundation; either version 2, or (at your option) 
     11;; any later version. 
     12 
     13;; This file is distributed in the hope that it will be useful, 
     14;; but WITHOUT ANY WARRANTY; without even the implied warranty of 
     15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
     16;; GNU General Public License for more details. 
     17 
     18;; You should have received a copy of the GNU General Public License 
     19;; along with GNU Emacs; see the file COPYING.  If not, write to 
     20;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, 
     21;; Boston, MA 02111-1307, USA. 
     22 
     23;;; Commentary: 
     24 
     25;;  
     26 
     27;;; Code: 
     28 
    129(require 'escm-base) 
    230(require 'escm-proc) 
     
    533(escm-cbos::define-class (escm-builtin-syntax escm-syntax)) 
    634 
    7 (escm-cbos::define-method 
    8  escm-syntax escm-syntax::apply (self context sexp) 
    9  (escm-compile context 
    10                (escm-vm::apply 
    11                 (escm-context::get-vm context) (escm-syntax::get-proc self) 
    12                 (list sexp)))) 
     35(defsubst escm-syntax::apply1 (self context sexp) 
     36  (let ((vm (escm-context::get-vm context))) 
     37    (escm-compile 
     38     context 
     39     (escm-vm::apply vm 
     40                     (escm-proc::activate (escm-syntax::get-proc self) vm) 
     41                     (list sexp))))) 
     42 
     43(escm-cbos::define-method escm-syntax escm-syntax::apply (self context sexp) 
     44 (escm-syntax::apply1 self context sexp)) 
    1345 
    1446(escm-cbos::define-method 
     
    1850 
    1951(defsubst escm-syntax::new (proc) 
    20   (let ((self (create-escm-syntax))) (escm-syntax::set-proc proc) self)) 
     52  (let ((self (create-escm-syntax))) 
     53    (escm-syntax::set-proc 
     54     self 
     55     proc) 
     56    self)) 
     57 
    2158 
    2259(defsubst escm-builtin-syntax::new (proc) 
     
    2562    self)) 
    2663 
    27 (defmacro escm-define-builtin-syntax (vm name fun) 
    28   `(escm-vm::define ,vm 
    29                     ',name 
    30                     (escm-builtin-syntax::new ,fun))) 
     64(defun escm-define-builtin-syntax (vm name fun) 
     65  (escm-vm::define vm 
     66                   name 
     67                   (escm-builtin-syntax::new fun))) 
     68(put 'escm-define-builtin-syntax 'lisp-indent-function 'defun) 
    3169 
    3270 
    33 (put 'escm-define-builtin-syntax 'lisp-indent-function 'defun) 
     71;; 
     72 
    3473 
    3574(provide 'escm-syntax) 
     75 
     76;;; escm-syntax.el ends here 
  • lang/elisp/escm/trunk/escm-test.el

    r8322 r9113  
    197197  (use-local-map escm-test::report-mode-map)) 
    198198 
    199  
    200199(defmacro escm-test::define-test (project name &rest body) 
    201200  "Defines new test as belongs the PROJECT." 
     
    218217           (escm-util::stext 
    219218            `(face escm-test::ok-face ,(format "%s ... ok!" (cadr r))))) 
     219 
    220220          ((:print) 
    221221           (escm-util::stext 
    222222            `(face escm-test::print-face ,(format "%s :" (cadr r))) 
    223223            (format "%S" (cddr r)))) 
     224 
    224225          ((:failed) 
    225226           (escm-util::stext 
    226             `(face escm-test::faild-face ,(format "%s :" (cadr r))) 
    227             (format " %s" (caddr r)))))) 
     227            `(face   escm-test::faild-face 
     228             ,(format "%s :" (cadr r))) 
     229            (format " %s" (caddr r))))) 
     230        ) 
    228231      report 
    229232      "\n")) 
  • lang/elisp/escm/trunk/escm-util.el

    r8609 r9113  
    1 ;;; hoge.el ---  
     1;;; escm-util.el ---  
    22 
    33;; Copyright (C) 2008  Free Software Foundation, Inc. 
     
    2727;;; Code: 
    2828(require 'escm-util.minimal) 
     29(require 'escm-test) 
    2930 
    3031(defmacro escm-util::expand (&rest body) 
     
    7576          (setq retstack (cdr retstack))))) 
    7677    ret)) 
    77  
    78  
    79  
    8078 
    8179(defun escm-util::take (n list) 
     
    129127 
    130128 
     129(defsubst escm-util::zip-with (f list-of-lists) 
     130  (let ((ret  nil) 
     131        (cont t)) 
     132 
     133    (while cont 
     134      (setq ret (cons 
     135                 (apply f (mapcar 'car list-of-lists)) 
     136                 ret)) 
     137      (setq cont nil) 
     138      (setq list-of-lists 
     139            (mapcar (lambda (l) 
     140                      (when (cdr l) (setq cont t)) 
     141                      (cdr l)) list-of-lists))) 
     142 
     143    (reverse ret))) 
     144 
     145(escm-test::define-test escm escm-util::zip-with 
     146  (escm-test escm-util::zip-with 
     147             (equal (list (- 1 2 3 4 5) 
     148                          (- 9 8 7 6 5) 
     149                          (- 4 5 6 7 8)) 
     150                    (escm-util::zip-with '- 
     151                                         '((1 9 4) 
     152                                           (2 8 5) 
     153                                           (3 7 6) 
     154                                           (4 6 7) 
     155                                           (5 5 8)))))) 
     156;; (escm-test::run 'escm 'escm-util::zip-with) 
     157 
     158(defun escm-util::time-sub (a b) 
     159 (let ((r (escm-util::zip-with '- (list a b)))) 
     160   (when (> 0 (nth 2 r)) 
     161     (setcar (nthcdr 2 r) (+  (nth 2 r) 65536)) 
     162     (setcar (nthcdr 1 r) (1- (nth 1 r) ))) 
     163   (when (> 0 (nth 1 r)) 
     164     (setcar (nthcdr 1 r) (+ (nth 1 r) 65536)) 
     165     (setcar r (1- (car r)))) 
     166   r)) 
     167 
     168 
     169 
     170 
     171(defconst escm-util::benchmark::result nil) 
     172(defmacro escm-util::benchmark (&optional body) 
     173  `(let* ((*start-of-benchmark* (current-time)) 
     174          (result (eval ',body))) 
     175     (setq escm-util::benchmark::result 
     176           (escm-util::time-sub (current-time) 
     177                                *start-of-benchmark*)) 
     178     result)) 
     179 
     180(progn 
     181  (escm-util::benchmark 
     182   (funcall 
     183    (lambda (f n) (funcall f f n)) 
     184    (lambda (f n) 
     185      (if (< n 2) 
     186          1 
     187        (+ (funcall f f (- n 2)) 
     188           (funcall f f (- n 1))))) 
     189    24)) 
     190  escm-util::benchmark::result) 
     191 
    131192(provide 'escm-util) 
    132193;;; escm-util.el ends here. 
  • lang/elisp/escm/trunk/escm-vm.el

    r8609 r9113  
    2727;;; Code: 
    2828 
    29 (require 'escm-base   ) 
    30 (require 'escm-proc   ) 
    31 (require 'escm-compile) 
    32 (require 'escm-debug  ) 
     29(require 'escm-base       ) 
     30(require 'escm-proc       ) 
     31(require 'escm-preprocess ) 
     32(require 'escm-compile    ) 
     33(require 'escm-debug      ) 
     34 
    3335 
    3436(defvar   escm-vm::init-hook    ()) 
     
    3638(defun escm-vm-init (vm) 
    3739  (run-hook-with-args 'escm-vm::init-hook vm)) 
    38  
    39 ;; (escm-vm::eval (escm-vm::new) '((lambda (a b) (* a b)) 3 4)) 
    4040 
    4141(escm-util::expand 
     
    101101    (escm-vm::push-pc   vm -1))) 
    102102 
    103  
    104103(defsubst escm-vm::tail-call (vm &optional proc) 
    105104  (let* ((proc   (or proc (escm-vm::current-val  vm)))) 
     
    107106    (escm-vm::set-current-proc  vm  (escm-proc::get-body   proc)) 
    108107    (escm-vm::set-current-env   vm  (escm-proc::runtime-env proc vm)) 
    109     (escm-vm::pop-arg vm ) 
     108    (escm-vm::pop-arg           vm ) 
    110109    (escm-vm::set-current-pc    vm  -1))) 
    111110 
     
    122121  (escm-vm::pop-env  vm) 
    123122  (escm-vm::pop-pc   vm) 
    124   (escm-debug::leave)) 
    125  
    126 ;;(escm-vm::eval (escm-vm::new) '(+ 1 2)) 
     123  (escm-debug::leave   )) 
    127124 
    128125(defsubst escm-vm::to-arg (vm arg) 
    129   (escm-vm::set-current-arg vm 
    130                             (cons arg (escm-vm::current-arg vm)))) 
    131  
     126  (escm-vm::set-current-arg 
     127   vm (cons arg (escm-vm::current-arg vm)))) 
    132128 
    133129(defsubst escm-vm::jmp (vm n) 
     
    136132 
    137133(defsubst escm-vm::step (vm) 
    138   (apply (aref (escm-vm::current-proc vm) (escm-vm::current-pc vm)) 
     134  (apply (aref (escm-vm::current-proc vm) 
     135               (escm-vm::current-pc   vm)) 
    139136         (list vm (escm-vm::current-env vm))) 
    140137  (escm-vm::set-current-pc vm (1+ (escm-vm::current-pc vm)))) 
     
    142139(defsubst escm-vm::apply (vm proc args) 
    143140  (let ((procs  (escm-vm::get-proc-stack vm)) 
    144         (retval (progn (escm-vm::set-proc-stack  vm ()) 
    145                        (escm-vm::set-current-arg vm args) 
    146                        (escm-vm::set-current-val vm proc) 
    147                        (escm-vm::call vm) 
    148                        (escm-vm::set-current-pc vm 0) 
     141        (retval (progn (escm-vm::set-proc-stack vm ()) 
     142                       (escm-vm::push-arg       vm (reverse args)) 
     143                       (escm-vm::call           vm proc) 
     144                       (escm-vm::push-pc        vm 0) 
    149145                       (while (escm-vm::get-proc-stack vm) 
    150146                         (escm-vm::step vm)) 
     
    153149    retval)) 
    154150 
    155  
    156151(defsubst escm-vm::compile (vm sexp) 
    157152  (escm-iproc::merge  
    158    (escm-compile (escm-context::new (escm-vm::current-env vm)) 
    159                  sexp) 
     153   (escm-compile (escm-context::set-tail? 
     154                  (escm-context::new (escm-vm::current-env vm) vm) t) 
     155                 (escm-preprocess::process-elisp-quotes sexp)) 
    160156   (escm-icode '((ret))))) 
    161157 
     158(defsubst escm-vm::compile-top-level (vm sexp) 
     159  (let ((iproc (escm-vm::compile vm sexp))) 
     160    (escm-iproc::set-src iproc sexp) 
     161    (escm-iproc::to-proc iproc 
     162                         (escm-arity::new ()) 
     163                         (escm-vm::current-env vm)))) 
     164 
    162165(defun escm-vm::eval (vm sexp) 
    163   (let ((iproc  (escm-vm::compile vm sexp))) 
    164     (escm-iproc::set-src iproc sexp) 
    165     (escm-vm::apply vm 
    166                     (escm-iproc::to-proc iproc 
    167                                          (escm-arity::new ()) 
    168                                          (escm-vm::current-env vm)) 
    169                     nil))) 
    170  
    171 ;;(insert (format "\n%S" (escm-env::fref (escm-vm::current-env (escm-vm::new)) '+))) 
    172  
     166  (escm-vm::apply vm (escm-vm::compile-top-level vm sexp)  nil)) 
    173167 
    174168(defsubst escm-vm::define (vm sym val) 
     
    176170                    sym val)) 
    177171 
     172(defun escm-vm::locate-library (vm name) 
     173  (let ((load-pathes ((escm-vm::eval vm '*load-path*) 
     174                      load-path)) 
     175        (ret nil)) 
     176    (while (not (null ret) 
     177                load-pathes) 
     178      (let ((load-path (car load-pathes))) 
     179        (or (locate-library name) 
     180            (let ((suffixes '(".escmc" 
     181                              ".escm" 
     182                              ".scm"))) 
     183              (while (and (null ret) 
     184                          suffixes) 
     185                (setq (locate-library 
     186                       (concat  (escm-util::basename name) 
     187                                (car suffixes)))) 
     188                (setq suffixes (cdr suffixes)))))) 
     189      (setq load-pathes (cdr load-pathes))) 
     190    ret)) 
     191 
     192(defsubst escm-vm::load1 (vm path) 
     193   
     194  ) 
     195 
     196(defun escm-vm::load (vm name) 
     197  (let ((path (escm-vm::locate-library vm name))) 
     198    (when path (escm-vm::load1 path)))) 
     199 
    178200(provide 'escm-vm) 
    179201;;; escm-vm.el ends here 
  • lang/elisp/escm/trunk/escm.el

    r8609 r9113  
    1313 (escm-vm::apply (escm-default-vm) proc args)) 
    1414 
    15 (defmacro escm-define (&rest body) (escm-eval `(define ,@body))) 
    16 (unless (fboundp 'define) (defalias 'define 'escm-define)) 
     15(defmacro define (&rest body) `(escm-eval '(define ,@body))) 
     16 
     17(defmacro define-syntax (&rest body) `(escm-eval '(define-syntax ,@body))) 
     18 
     19(defun escm-eval-last-sexp () 
     20  "Evaluate sexp previous of point in your buffer by `escm-default-vm'." 
     21  (interactive) 
     22  (let ((v (escm-eval 
     23            (read (buffer-substring-no-properties 
     24                   (progn (backward-sexp ) (point)) 
     25                   (progn (forward-sexp  ) (point))))))) 
     26    (message (format "%S" v)) 
     27    v)) 
     28 
     29(defun escm-locate-library (name) 
     30  (escm-vm::locate-library name)) 
    1731 
    1832 
    1933(when nil 
    20   (defun escm-locate-library (name) 
    21     (or (locate-library name) 
    22         (locate-library (concat (escm-util::basename name) ".escm")))) 
     34 
    2335 
    2436  (defun escm-load    (file) 
     
    3446    "" 
    3547    (condition-case *err* ad-do-it 
    36       (file-error (escm-load file))))) 
     48      (file-error (escm-load file)))) 
     49 
     50  ) 
    3751   
    3852(provide 'escm)