Changeset 7383 for lang/elisp

Show
Ignore:
Timestamp:
03/03/08 03:20:00 (7 years ago)
Author:
lieutar
Message:

lang/elisp/escm/trunk: add some changes.

Location:
lang/elisp/escm/trunk
Files:
2 added
3 removed
11 modified

Legend:

Unmodified
Added
Removed
  • lang/elisp/escm/trunk/escm-arity.el

    r6576 r7383  
     1(require 'escm-util) 
     2(require 'escm-cbos) 
     3 
    14(escm-cbos::define-class escm-arity 
    25                         length 
     
    47                         at-least) 
    58 
    6 (defsubst new-escm-arity (argspec) 
     9(defsubst escm-arity::new (argspec) 
    710  "" 
    811  (let ((new (create-escm-arity)) 
     
    1013        (at-least nil)) 
    1114    (while argspec 
    12       (if (consp argspec) ;; I must add check by symbolp. 
    13           (progn (setq fields (cons (car argspec) fields)) 
    14                  (setq argspec (cdr argspec))) 
     15      (if (consp argspec) 
     16          (let ((head (car argspec)) 
     17                (tail (cdr argspec))) 
     18            (if (symbolp head) 
     19                (progn (setq fields  (cons head fields)) 
     20                       (setq argspec tail)) 
     21              (throw 'error (format "wrong type argument: synbolp : %s" head)))) 
    1522        (progn (setq fields (cons argspec fields)) 
    1623               (setq at-least t) 
     
    1926    (escm-arity::set-length   new (length  fields)) 
    2027    (escm-arity::set-at-least new at-least))) 
    21  
    22 (defsubst escm-arity::make-env (self) 
    23   (let* ((fields (escm-util::canonicalize-list self)) 
    24          (new (create-escm-env (length (escm-arity::get-fields self)))) 
    25          (ptr -1) 
    26          (dic (escm-env::get-dic new))) 
    27     (mapcar (lambda (f) (put dic f (setq ptr (1+ ptr)))) fields) 
    28     new)) 
    2928 
    3029(defsubst escm-arity::inject-args! (self env args) 
  • lang/elisp/escm/trunk/escm-cbos.el

    r6576 r7383  
    104104 
    105105(defmacro escm-cbos::define-class (inhspec &rest fields) 
    106   "Creates object constructor and predicate and field-accessors" 
    107   (let* ((name    (car inhspec)) 
    108          (super   (or (cadr inhspec) 'escm-cbos::Object)) 
    109          (fields  (escm-cbos::register-class name super fields)) 
    110          (len     (length fields)) 
    111          (new     (intern (format "create-%s" name))) 
    112          (pred    (intern (format "%s-p"      name)))) 
     106  "Creates object constructor and predicate and field-accessors. 
     107The syntax of `escm-cbos::define-class' is as follows: 
     108 
     109  (escm-cbos::define-class (CLASS [SUPER] [CLONE-MODE]) ATTR...) 
     110 
     111CLASS      ::= Name of the class to be defined. 
     112SUPER      ::= Name of super class. 
     113CLONE-MODE ::= t | nil. if true, . 
     114ATTR       ::= Name of the attribute of the objects. 
     115" 
     116  (let* ((name      (car inhspec)) 
     117         (super     (or (cadr inhspec) 'escm-cbos::Object)) 
     118         (copy-mode (caddr inhspec)) 
     119         (fields    (escm-cbos::register-class name super fields)) 
     120         (len       (length fields)) 
     121         (new       (intern (format "create-%s" name))) 
     122         (pred      (intern (format "%s-p"      name)))) 
    113123    `(progn 
    114124       (defsubst ,new () 
     
    123133 
    124134       ,@(let ((p 0)) 
    125            (mapcar (lambda (f) 
    126                      (setq p (1+ p)) 
    127                      `(progn 
    128                         (defsubst ,(intern (format "%s::set-%s" name f)) (obj val) 
    129                          (aset obj ,p val)) 
    130                         (defsubst ,(intern (format "%s::get-%s" name f)) (obj) 
    131                          (aref obj ,p)))) 
    132                    fields))))) 
     135           (mapcar 
     136            (if copy-mode 
     137                (lambda (f) 
     138                  (setq p (1+ p)) 
     139                  `(progn 
     140                     (defsubst ,(intern (format "%s::set-%s" name f)) (obj val) 
     141                       (let ((new (escm-cbos::clone obj))) 
     142                         (aset new ,p val) 
     143                         new)) 
     144                     (defsubst ,(intern (format "%s::get-%s" name f)) (obj) 
     145                       (aref obj ,p)))) 
     146 
     147              (lambda (f) 
     148                (setq p (1+ p)) 
     149                `(progn 
     150                   (defsubst ,(intern (format "%s::set-%s" name f)) (obj val) 
     151                     (aset obj ,p val)) 
     152                   (defsubst ,(intern (format "%s::get-%s" name f)) (obj) 
     153                     (aref obj ,p))))) 
     154 
     155              fields))))) 
    133156 
    134157 
  • lang/elisp/escm/trunk/escm-compile.el

    r6617 r7383  
    1 (escm-cbos::define-class escm-context 
    2                          argspec 
    3                          envs 
    4                          parent 
    5                          tailp) 
     1(require 'escm-util  ) 
     2(require 'escm-cbos  ) 
     3(require 'escm-syntax) 
     4(require 'escm-icode ) 
     5(require 'escm-env   ) 
     6 
     7(escm-cbos::define-class (escm-context nil t) env tail? func?) 
     8 
     9(defun escm-compile (context sexp) 
     10  "Compiles sexp." 
     11  (cond 
     12   ((and sexp (consp sexp)) 
     13    (let* ((head  (car sexp)) 
     14           (headv (when (symbolp head) (escm-context::gref head)))) 
     15      (if (escm-syntax-p headv) (escm-syntax::apply headv context sexp) 
     16        (escm-compile-apply context sexp)))) 
     17 
     18   ((symbolp sexp) 
     19    (escm-icode (,(if (escm-context::get-callp) 'fref 'ref) 
     20                 (escm-context::get-env context)))) 
     21 
     22   (t              (escm-icode `((store  ,sexp)))))) 
     23 
     24(defsubst escm-compile-apply (context sexp) 
     25  "" 
     26  (let ((head        (car sexp)) 
     27        (tail        (cdr sexp)) 
     28        (arg-context (escm-context::set-tailp context nil)) 
     29        (ret         (escm-iproc::new ()))) 
     30    (mapcar (lambda (x) 
     31              (escm-iproc::merge ret (escm-compile arg-context  x)) 
     32              (escm-iproc::merge ret (escm-icode '((pusha)))))  tail) 
     33    (escm-iproc::merge ret (escm-compile (escm-context::set-func? context t)  head)) 
     34    (escm-iproc::merge ret (escm-icode `((,(if (escm-context::get-tailp context) 
     35                                               'tcall 
     36                                             'call))))))) 
     37 
     38(defsubst escm-compile-if (sexp) 
     39  "" 
     40 (let ((condx     (escm-compile (cadr   sexp))) 
     41       (positivex (escm-compile (caddr  sexp))) 
     42       (negativex (escm-compile (cadddr sexp)))) 
     43 
     44   (cond ((not (escm-iproc::has-jump positivex)) 
     45          (escm-iproc::merge 
     46           condx 
     47           (escm-icode `(unlessv 
     48                         ,(car (escm-iproc::get-body positivex)) 
     49                         ,(escm-iproc::get-first negativex)))) 
     50          (escm-iproc::merge 
     51           condx 
     52           (escm-iproc::new 
     53            (escm-iproc::get-body-without-first negativex)))) 
     54 
     55         ((not (escm-iproc::has-jump positivex)) 
     56          (escm-iproc::merge 
     57           condx 
     58           (escm-icode `(unlessv 
     59                         ,(car (escm-iproc::get-body negativex)) 
     60                         ,(escm-iproc::get-first positivex)))) 
     61          (escm-iproc::merge 
     62           condx 
     63           (escm-iproc::new 
     64            (escm-iproc::get-body-without-first positivex)))) 
     65 
     66         (t 
     67          (escm-iproc::merge negativex 
     68                             (escm-icode `((jmp ,(escm-iproc::length positivex))))) 
     69          (escm-iproc::merge condx 
     70                             (escm-icode `((jt  ,(escm-iproc::length negativex))))) 
     71          (escm-iproc::merge condx negativex) 
     72          (escm-iproc::merge condx positivex))))) 
     73 
     74 
     75(defun escm-compile-define-syntax () 
     76  "" 
     77  ) 
     78 
     79(defun escm-compile-let-syntax () 
     80  "" 
     81  ) 
     82 
     83(defun escm-compile-define (context sexp) 
     84  "" 
     85  ) 
     86 
     87(defun escm-compile-lambda (context sexp) 
     88  "" 
     89  `(store 
     90    ,(let* ((ctx     (escm-context::push context)) 
     91            (arglist (cadr sexp)) 
     92            (body    (cddr sexp)) 
     93            (mid     (let ((asm ())) 
     94                       (while body 
     95                         (let ((head (car body)) 
     96                               (tail (cdr body))) 
     97                           (escm-context::set-tail ctx (not tail)) 
     98                           (setq asm (append asm (escm-compile ctx head))) 
     99                           (setq body tail))))) 
     100            (asm     (escm-optimize mid))) 
     101       (escm-proc::new (escm-context::build-fixed-env env) 
     102                       (escm-assemble asm))))) 
     103 
     104(defun escm-compile-quote (context sexp) 
     105  ) 
     106 
     107(defun escm-compile-quasiquote   (context sexp) 
     108  ) 
     109 
     110(defun escm-compile-unquote (context sexp) 
     111  ) 
    6112 
    7113 
    8114 
     115(add-hook 
     116 'escm-vm::init-hook 
     117 (lambda (vm) 
     118   (escm-define-builtin-syntax vm quote         (function escm-compile-quote)) 
     119   (escm-define-builtin-syntax vm quasiquote    (function escm-compile-quasiquote)) 
     120   (escm-define-builtin-syntax vm unquote       (function escm-compile-unquote)) 
     121   (escm-define-builtin-syntax vm if            (function escm-compile-if)) 
     122   (escm-define-builtin-syntax vm let-syntax    (function escm-compile-let-syntax)) 
     123   (escm-define-builtin-syntax vm define-syntax (function escm-compile-define-syntax)) 
     124   (escm-define-builtin-syntax vm define        (function escm-compile-define)) 
     125   (escm-define-builtin-syntax vm lambda        (function escm-compile-lambda)) 
     126  ));; END OF INITIALIZER 
    9127 
    10 (defun escm-compile (vm context sexp) 
    11   "" 
    12   (cond 
    13    ((and sexp (consp sexp)) 
    14     (let* ((head  (car sexp)) 
    15            (headv (when (symbolp head) 
    16                     (condition-case *err* 
    17                         (escm-env::gref 
    18                          (escm-vm::get-current-env vm) 
    19                          head) 
    20                       (error nil))))) 
    21       (if (escm-syntax-p headv) 
    22           (escm-syntax::apply headv vm context sexp) 
    23         (escm-compile-apply vm context sexp)))) 
    24    ((symbolp sexp) `(ref ,sexp ,(escm-vm::get-current-env vm))) 
    25    (t `((store . ,sexp))))) 
    26  
    27 (defun escm-compile-apply (vm context sexp) 
    28   "" 
    29   (let ((head (car sexp)) 
    30         (tail (cdr sexp))) 
    31  
    32     `(,@(append (mapcar (lambda (x) (append (escm-compile vm x) 
    33                                             '((store))))  tail)) 
    34       ,@(escm-compile vm head) 
    35       ,('(call))))) 
    36  
    37 (escm-define-syntax if     (vm context sexp) 
    38   (let (()))) 
    39  
    40 (escm-define-syntax define (vm context sexp) 
    41   (let ((syms )))) 
    42  
    43 (escm-define-syntax lambda (vm context sexp) 
    44   (let ((syms )))) 
     128(provide 'escm-compile) 
  • lang/elisp/escm/trunk/escm-env.el

    r6617 r7383  
    1 (escm-cbos::define-class (escm-env) parent dic ptr) 
     1(require 'escm-util) 
     2(require 'escm-cbos) 
     3 
     4(defconst escm-env::class-diagram " 
     5 
     6                       ,--------------. 
     7                       |   escm-env   | 
     8                       | <<abstract>> | 
     9                       `--------------' 
     10                              A 
     11                              | 
     12          .-------------------+---------------------. 
     13          |                   |                     | 
     14 ,----------------.  ,--------+---------.  ,--------+----------. 
     15 | escm-fixed-env |<-+ escm-dynamic-env |  | escm-boundary-env | 
     16 `----------------'  `------------------'  `-------------------' 
     17 
     18  escm-env          ... abstract root class of escm environment. 
     19  escm-fixed-env    ... fixed fields enviroment for compiled function. 
     20  escm-dynamic-env  ... it derives escm-fixed-env. 
     21  escm-boundary-env ... this is able to access to native elisp environment. 
     22 
     23") 
     24 
     25(escm-cbos::define-class (escm-env) parent dic) 
     26 
     27(escm-cbos::define-method escm-env escm-env::fref (self sym) 
     28  "" 
     29  (escm-cbos::gref self sym)) 
     30 
     31(escm-cbos::define-method escm-env escm-env::member? (self sym) 
     32  "" 
     33  (plist-member (symbol-plist (escm-env::get-dic)) sym)) 
     34 
     35(escm-cbos::define-method escm-env escm-env::pos (self sym) 
     36  "" 
     37  (get (escm-env::get-dic self) sym)) 
     38 
     39(escm-cbos::define-method escm-env escm-env::make-referer (self env sym) 
     40  "" 
     41  (let ((pos (escm-env::pos self sym))) 
     42    (if pos `(aref ,env ,pos) 
     43      (escm-env::make-referer (escm-env::get-parent self) 
     44                              `(escm-env::get-parent ,env) 
     45                              sym)))) 
     46 
     47(escm-cbos::define-method escm-env escm-env::make-setter (self env sym val) 
     48  "" 
     49  (let ((pos (escm-env::pos self sym))) 
     50    (if pos `(aset ,env ,pos ,val) 
     51      (escm-env::make-setter (escm-env::get-parent self) 
     52                             `(escm-env::get-parent ,env) 
     53                             sym 
     54                             val)))) 
     55 
     56(escm-test::define-test escm env 
     57  "" 
     58  (let* ((e (create-escm-env nil '(a b c))) 
     59         (f (create-escm-env e   '(d e f))) 
     60         (g (create-escm-env f   '(a)))) 
     61    (escm-test "gset! 0" (escm-env::gset! e 'a 1) t) 
     62    (escm-test "gref  0" (eq 1 (escm-env::gref e 'a))) 
     63    (escm-test "gset! 1" (escm-env::gset! f 'b 2) t) 
     64    (escm-test "gref  1" (eq 2 (escm-env::gref  e 'b))) 
     65    (escm-test "gset! 2" (escm-env::gset! g 'a 3) t) 
     66    (escm-test "gref  2" (and (eq 1 (escm-env::gref e 'a)) 
     67                              (eq 3 (escm-env::gref g 'a)))) 
     68    (escm-util::a (escm-env::make-referer f 'env 'a)) 
     69    (escm-util::a (escm-env::make-setter f 'env 'a '((aaa)))))) 
     70 
     71;;(escm-test::run 'escm 'env ) 
     72 
     73;;;-----------;;; 
     74;;;           ;;; 
     75;;; fixed-env ;;; 
     76;;;           ;;; 
     77;;;-----------;;; 
     78 
     79(escm-cbos::define-class (escm-fixed-env escm-env) ptr) 
    280 
    381;; override 
     
    1290    new)) 
    1391 
    14 (escm-cbos::define-method escm-env escm-cbos::clone (self) 
    15   (let ((new (super self))) 
    16     (escm-env::set-ptr new 3) new)) 
    17  
    18 (escm-cbos::define-method escm-env escm-env::push (self val) 
     92(escm-cbos::define-method escm-fixed-env escm-fixed-env::push (self val) 
    1993  (let ((ptr(escm-env::get-ptr self))) 
    2094    (aset self ptr val) 
    2195    (escm-env::set-ptr (1+ ptr)) val)) 
    2296 
    23 (escm-cbos::define-method escm-env escm-env::gref  (self sym) 
     97(escm-cbos::define-method escm-fixed-env escm-env::gref  (self sym) 
    2498  (let ((pos (get (escm-env::get-dic self) sym))) 
    2599    (if pos (aref self pos) 
    26100      (let ((parent (escm-env::get-parent self))) 
    27         (if parent 
    28             (escm-env::gref parent) 
     101        (if parent (escm-env::gref parent) 
    29102          (throw 'escm-env::unbound (format "unbound symbol : %s" sym))))))) 
    30103 
    31 (escm-cbos::define-method escm-env escm-env::gset! (self sym val) 
     104(escm-cbos::define-method escm-fixed-env escm-env::gset! (self sym val) 
    32105  (let ((pos (get (escm-env::get-dic self) sym))) 
    33106    (if pos (aset self pos val) 
    34107      (let ((parent (escm-env::get-parent self))) 
    35         (if parent 
    36             (escm-env::gset! parent sym val) 
     108        (if parent (escm-env::gset! parent sym val) 
    37109          (throw 'escm-env::unbound (format "unbound symbol : %s" sym))))))) 
    38110 
    39 (escm-cbos::define-method escm-env escm-env::pos (self sym) 
    40   (get (escm-env::get-dic self) sym)) 
     111;;;-------------;;; 
     112;;;             ;;; 
     113;;; dynamic-env ;;; 
     114;;;             ;;; 
     115;;;-------------;;; 
    41116 
    42 (escm-cbos::define-method escm-env escm-env::make-referer (self env sym) 
    43   (let ((pos (escm-env::pos self sym))) 
    44     (if pos `(aref ,env ,pos) 
    45       (escm-env::make-referer (escm-env::get-parent self) 
    46                               `(escm-env::get-parent ,env) 
    47                               sym)))) 
     117(escm-cbos::define-class (escm-dynamic-env escm-env) valdic arity fields) 
    48118 
    49 (escm-cbos::define-method escm-env escm-env::make-setter (self env sym val) 
    50   (let ((pos (escm-env::pos self sym))) 
    51     (if pos `(aset ,env ,pos ,val) 
    52       (escm-env::make-setter (escm-env::get-parent self) 
    53                              `(escm-env::get-parent ,env) 
    54                              sym 
    55                              val)))) 
     119(defsubst escm-dynamic-env::new (list) 
     120  "" 
     121  (let ((new create-escm-env)) 
     122    (let ((arity (escm-arity::new list))) 
     123      (mapcar (lambda (sym) (escm-dynamic-env::add-field new sym)) 
     124              (escm-dynamic-env::get-symbols arity)) 
     125      (escm-dynamic-env::set-valdic new (make-symbol "*valdic*")) 
     126      (escm-dynamic-env::set-arity new arity)) 
     127    new)) 
    56128 
    57 (escm-test::deftest escm env 
    58  (let* ((e (create-escm-env nil '(a b c))) 
    59         (f (create-escm-env e   '(d e f))) 
    60         (g (create-escm-env f   '(a)))) 
    61    (escm-test "gset! 0" (escm-env::gset! e 'a 1) t) 
    62    (escm-test "gref  0" (eq 1 (escm-env::gref e 'a))) 
    63    (escm-test "gset! 1" (escm-env::gset! f 'b 2) t) 
    64    (escm-test "gref  1" (eq 2 (escm-env::gref  e 'b))) 
    65    (escm-test "gset! 2" (escm-env::gset! g 'a 3) t) 
    66    (escm-test "gref  2" (and (eq 1 (escm-env::gref e 'a)) 
    67                              (eq 3 (escm-env::gref g 'a)))) 
    68    (escm-util::a (escm-env::make-referer f 'env 'a)) 
    69    (escm-util::a (escm-env::make-setter f 'env 'a '((aaa)))))) 
     129(defsubst escm-dynamic-env::add-field (self sym) 
     130  "" 
     131  (put (escm-env::get-dic         self) sym (length fields)) 
     132  (put (escm-dynamic-env::get-valdic self) sym nil) 
     133  (escm-dynamic-env::set-fields self (cons sym (escm-dynamic-env::get-fields)))) 
    70134 
    71 ;;(escm-test::run 'escm 'env ) 
     135(defsubst escm-dynamic-env::build-fixed-env (self)) 
     136 
     137(escm-cbos::define-method escm-dynamic-env escm-env::gset! (self sym val) 
     138  (if (escm-env::member? self sym) 
     139      (put (escm-dynamic-env::get-valdic self) sym val) 
     140    (let ((parent (escm-env::get-parent self))) 
     141      (if parent 
     142          (escm-env::gset! parent sym val) 
     143        (throw 'escm-env::unbound (format "unbound symbol : %s")))))) 
     144 
     145(escm-cbos::define-method escm-dynamic-env escm-env::gref  (self sym) 
     146  (if (escm-env::member? self sym) 
     147      (get (escm-dynamic-env::get-valdic self) sym) 
     148    (let ((parent (escm-env::get-parent self))) 
     149      (if parent 
     150          (escm-env::gref parent sym) 
     151        (throw 'escm-env::unbound (format "unbound symbol : %s")))))) 
     152 
     153;;; 
     154;;; elisp-env 
     155;;; 
     156 
     157(escm-cbos::define-class (escm-elisp-env escm-env)) 
     158 
     159(escm-cbos::define-method escm-elisp-env escm-env::gref (self sym) 
     160  (let ((dic (escm-env::dic self))) 
     161    (if (plist-member dic sym) 
     162        (get dic sym) 
     163      (let ((retval (condition-case *err* (symbol-value 'sym) 
     164                      (error (condition-case *err* (symbol-function 'sym) 
     165                               (error (throw 'escm::unbound ""))))))) 
     166        (let ((retval (if (functionp retval) 
     167                          (escm-proc::wrap-elisp retval) 
     168                        retval))) 
     169          (put dic sym retval) 
     170          retval))))) 
     171 
     172(escm-cbos::define-method escm-elisp-env escm-env::fref (self sym) 
     173  (let ((dic (escm-env::dic self))) 
     174    (if (plist-member dic sym) 
     175        (get dic sym) 
     176      (let ((retval (condition-case *err* (symbol-function 'sym) 
     177                      (error (condition-case *err* (symbol-value 'sym) 
     178                               (error (throw 'escm::unbound ""))))))) 
     179        (let ((retval (if (functionp retval) 
     180                          (escm-proc::wrap-elisp retval) 
     181                        retval))) 
     182          (put dic sym retval) 
     183          retval))))) 
     184 
     185(escm-cbos::define-method escm-elisp-env escm-env::gset! (self sym val) 
     186  (put (escm-env::dic self) sym val)) 
     187 
     188(escm-cbos::define-method escm-elisp-env escm-env::make-referer (self env sym) 
     189  `(escm-env::gref ,env ,sym)) 
     190 
     191(escm-cbos::define-method escm-elisp-env escm-env::make-setter  (self env sym val) 
     192  `(escm-env::gset! ,env ,sym ,val)) 
     193 
    72194(provide 'escm-env) 
  • lang/elisp/escm/trunk/escm-proc.el

    r6617 r7383  
     1(require 'escm-bos) 
     2(require 'escm-env) 
     3 
    14(escm-cbos::defclass escm-proc 
    25                     env 
     
    1114    new)) 
    1215 
    13 (defmacro escm-defun () 
    14   (let (()) 
    15     )) 
     16(defsubst escm-wrapped-proc::new (fun) 
     17  (let ((new (create-escm-wrapped-proc))) 
     18    (escm-proc::set-body 
     19     (vector 
     20      (byte-compile (lambda (vm) 
     21                      (escm-vm::set-current-value 
     22                       vm 
     23                       (apply fun (escm-vm::get-current-args vm))))) 
     24      (function escm-vm::ret))))) 
  • lang/elisp/escm/trunk/escm-syntax.el

    r6617 r7383  
     1(require 'escm-cbos) 
     2(require 'escm-proc) 
    13 
    2 (defmacro escm-define-syntax (name argspec &rest body) 
    3   ) 
     4(escm-cbos::define-class (escm-syntax) proc) 
     5(escm-cbos::define-class (escm-builtin-syntax escm-syntax)) 
    46 
    5 (put 'escm-define-syntax 'lisp-indent-function 'defun) 
     7(escm-cbos::define-method escm-syntax escm-syntax::apply (self context sexp) 
     8  (escm-vm::apply (escm-context::get-vm context) 
     9                  (escm-syntax::get-proc self) 
     10                  (list sexp))) 
    611 
     12(escm-cbos::define-method escm-builtin-syntax escm-syntax-apply  (self context sexp) 
     13  (apply (escm-syntax::get-proc self) 
     14         (list context sexp))) 
    715 
     16(defsubst escm-syntax::new (proc) 
     17  (let ((self (create-escm-syntax))) (escm-syntax::set-proc proc) self)) 
     18 
     19(defsubst escm-builtin-syntax::new (proc) 
     20  (let ((self (create-escm-builtin-syntax))) 
     21    (escm-syntax::set-proc proc) 
     22    self)) 
     23 
     24(defmacro escm-define-builtin-syntax (name argspec &rest body) 
     25  `(escm-builtin-syntax::new  `(lambda ,argspec ,@body))) 
     26 
     27(put 'escm-define-builtin-syntax 'lisp-indent-function 'defun) 
     28 
     29(provide 'escm-syntax) 
  • lang/elisp/escm/trunk/escm-test.el

    r6617 r7383  
    88 
    99(defun escm-test::run-test (reporter project name all) 
    10   "runs provided test." 
     10  "Runs provided test." 
    1111  (let* ((errors  ()) 
    1212         (failed  ())) 
     
    1414    (apply reporter (list project name  (length all) failed)))) 
    1515 
    16 (defmacro escm-test::deftest (project name &rest body) 
    17   "defines new test as belongs the `project'." 
     16(defmacro escm-test::define-test (project name &rest body) 
     17  "Defines new test as belongs the PROJECT." 
    1818  `(put 'escm-test::tests 
    1919        ',project 
    2020        (cons (cons ',name ',body) (get 'escm-test::tests ',project)))) 
    21 (put 'escm-test::deftest 'lisp-indent-function 'defun) 
     21(put 'escm-test::define-test 'lisp-indent-function 'defun) 
    2222 
    2323(defun escm-test::report-single (project name all failed) 
     24  "" 
    2425  (if failed 
    2526      (with-output-to-temp-buffer "*escm-test*" 
     
    3031 
    3132(defun escm-test::project-alist () 
    32   "returns all project names as alist." 
     33  "Returns all project names as alist." 
    3334  (let((src (symbol-plist 'escm-test::tests)) 
    3435       (ret ())) 
     
    3940 
    4041(defun escm-test::run (project &optional name) 
    41   "runs all tests what belongs given project." 
     42  "Runs all tests what belongs the PROJECT." 
    4243  (interactive 
    4344   (let* ((prj (intern (completing-read "project: " 
     
    6869 
    6970(provide 'escm-test) 
    70  
  • lang/elisp/escm/trunk/escm-util.el

    r6617 r7383  
     1(require 'cl) 
    12 
    23(defmacro escm-util::expand (&rest body) 
    3   "expands anonymous macro as standard macro." 
     4  "Expands anonymous macro as standard macro." 
    45  (cons 'progn (eval body))) 
    56 
     
    78;;; list utilities. 
    89;;; 
    9 (defsubst escm-util::walk-node (fun src &optional pred) 
    10   "" 
     10(defsubst escm-util::walk-node (fun tree &optional pred) 
     11  "Apply FUN to each leaves of TREE, and make a tree of the results. 
     12Nodes in the TREE are lists, and leaves in there are atoms." 
    1113  (let ((retstack              nil) 
    12         (srcstack              (list src)) 
     14        (srcstack              (list tree)) 
    1315        (ret                   nil) 
    1416        (src                   nil) 
     
    4446 
    4547(defun escm-util::list-splice (list n &optional len replacement) 
    46   "like a splice in perl." 
     48  "Removes items of List , like a \"splice\" in perlfunc." 
    4749  (append (escm-util::take n list) 
    4850          replacement 
     
    5052 
    5153(defun escm-util::a (&rest args) 
    52   "" 
     54  "Prints args to minibuffer." 
    5355  (read-char (format "%S" args)) 
    5456  nil) 
    5557 
    5658(defsubst escm-util::get-arity (fun) 
    57   "returns argument list." 
     59  "Returns arguments list of function." 
    5860  (if (functionp fun) 
    5961      (cond ((subrp fun) (subr-arity fun)) 
  • lang/elisp/escm/trunk/escm-util.file.el

    r6576 r7383  
     1(require 'escm-util) 
     2 
    13;;; 
    24;;; file utilities 
     
    8082     (escm-util::close *fh*) 
    8183     (reverse *ret*))) 
     84 
     85(provide 'escm-util.file) 
  • lang/elisp/escm/trunk/escm-vm.el

    r6617 r7383  
    22(require 'escm-cbos) 
    33(require 'escm-proc) 
    4 (require 'escm-wrapped-proc) 
    54 
    6 (defconst 'escm-vm::init-hook ()) 
     5(defconst 'escm-vm::init-hook    ()) 
     6(defconst 'escm-vm::serial-number 0) 
    77(defun escm-vm-init (vm) (run-hook-with-args 'escm-vm::init-hook vm)) 
    88 
     
    5858    (escm-vm::push-args vm ()))) 
    5959 
     60 
    6061(defsubst escm-vm::t-call (vm) 
    6162  (let ((proc   (escm-vm::get-current-val)) 
     
    6970    (escm-vm::set-current-pc    vm  0) 
    7071    (escm-vm::set-current-args  vm  ()))) 
     72 
    7173 
    7274(defsubst escm-vm::ret (vm) 
     
    8688  (escm-vm::pop-args vm)) 
    8789 
     90 
    8891(defsubst escm-vm::step (vm) 
    8992  (let ((pc  (escm-vm::get-current-pc vm))) 
    9093    (apply (aref (escm-vm::get-current-proc vm) pc) (list vm)) 
    9194    (escm-vm::set-current-pc vm (1+ pc)))) 
     95 
     96 
     97(defsubst escm-vm::apply (vm proc args) 
     98  (let ((procs  (escm-vm::get-proc-stack vm)) 
     99        (retval (progn (escm-vm::set-proc-stack ()) 
     100                       (escm-vm::set-current-args  vn args) 
     101                       (escm-vm::set-current-value vm proc) 
     102                       (escm-vm::call vm) 
     103                       (while (escm-vm::get-proc-stack vm) 
     104                         (escm-vm::step vm))))) 
     105    (escm-vm::set-proc-stack vm proc) 
     106    retval)) 
  • lang/elisp/escm/trunk/escm.el

    r6617 r7383  
     1(require 'escm-util) 
    12(require 'escm-vm) 
    23 
    34(defvar escm-default-vm nil) 
    4 (defsubst escm-default-vm () (or escm-default-vm 
    5                                  (progn (setq escm-default-vm (escm-vm::new)) 
    6                                         escm-default-vm))) 
     5(defsubst escm-default-vm () 
     6  (or escm-default-vm 
     7      (progn (setq escm-default-vm (escm-vm::new)) 
     8             escm-default-vm))) 
    79 
    810(defsubst escm-eval  (exp) 
     
    1113(defsubst escm-apply (proc args) 
    1214 (escm-vm::apply (escm-default-vm) proc args)) 
     15 
     16(defmacro escm-define (&rest body) (escm-eval `(define ,@body))) 
     17(unless (fboundp 'define) (defalias 'define 'escm-define)) 
     18 
     19(defun escm-locate-library (name) 
     20  (or (locate-library name) 
     21      (locate-library (concat (escm-util::basename name) ".escm")))) 
     22 
     23(defun escm-load    (file) 
     24  (when (symbolp file) (setq file (symbol-name file))) 
     25  ()) 
     26 
     27(defadvice require (around escm-load first (sym) activate) 
     28  "" 
     29  (condition-case *err* ad-do-it 
     30    (file-error (escm-load sym)))) 
     31 
     32(defadvice load (around escm-load first (file) activate) 
     33  "" 
     34  (condition-case *err* ad-do-it 
     35    (file-error (escm-load file)))) 
     36 
     37(provide 'escm)