minimal scheme with an ability to call elisp functions. elispの練習で書いた

00-schel.el

(setq max-lisp-eval-depth 100000)
(setq max-specpdl-size 100000)
(setq debug-on-error t)

(defun compile (x next)
  (cond
   ((symbolp x) (list 'refer x next)) ;;variables
   ((listp x)
    (let ((code (car x)) (arg (cdr x)))
      (cond
       ((eq code 'schel) ;;native funcall
        (list 'native 
              (car arg) 
              (mapcar '(lambda (it) (compile it '(halt))) (cdr arg))
              next))
       ((eq code 'quote) (list 'constant (car arg) next)) ;;quote
       ((eq code 'lambda_) ;;lambda takes variable number of arguments
        (list 'close (car arg) (recursive-compile (cdr arg) '(return_)) next))
       ((eq code 'if)
        (let ((thenc (compile (cadr arg) next))
              (elsec (compile (caddr arg) next)))
          (compile (car arg) (list 'test thenc elsec))))
       ((eq code 'setq)
        (compile (cadr arg) (list 'assign (car arg) next)))
       (t ;;funcall
        (let ((recur '(lambda (args c)
                        (if (null args)
                            (list 'frame next c)
                          (funcall recur (cdr args)
                                 (compile (car args)
                                          (list 'argument c)))))))
          (funcall recur (cdr x) (compile (car x) '(apply))))))))
   (t (list 'constant x next)))) ;;constants

(defun recursive-compile (lis end)
  (if (null lis) end
    (compile (car lis) (recursive-compile (cdr lis) end))))

(defun extend (env vars vals)
  (cons (cons vars vals) env))

;; a: the accumulator
;; x: the next expression
;; e: the current environment
;; r: the current value rub
;; s: the current stack (p51)

(defun VM (a x e r s)
;;  (sit-for 0.1)
;;  (message "acum: %s" a)
;;  (message "xecu: %s" x)
;;  (message "env : %s" e)
;;  (message "rib : %s" r)
;;  (message "stak: %s" s)
;;  (message "%s" " ")
  (let ((code (car x))
        (arg (cdr x)))
    (cond
     ((eq code 'halt) a)
     ((eq code 'native)  ;;call an elisp function
      (message "env : %s" e)
      (let* ((params (mapcar '(lambda (x) (VM a x e r s)) (cadr arg)))
             (result (apply-with-env (car arg) params e)))
        (VM result (caddr arg) e r s)))
     ((eq code 'refer)
      (VM (car (lookup (car arg) e)) (cadr arg) e r s))
     ((eq code 'constant)
      (VM (car arg) (cadr arg) e r s))
     ((eq code 'close)
      (VM (closure (cadr arg) e (car arg)) (caddr arg) e r s))
     ((eq code 'test) 
      (VM a (if a (car arg) (cadr arg)) e r s))
     ((eq code 'assign) 
      (progn
        (setcar (lookup (car arg) e) a)
        (VM a (cadr arg) e r s)))
     ((eq code 'frame) 
      (VM a (cadr arg) e '() (call-frame (car arg) e r s)))
     ((eq code 'argument) 
      (VM a (car arg) e (cons a r) s))
     ((eq code 'apply)
      (let ((body (car a)) (e (cadr a)) (vars (caddr a)))
        (VM a body (extend e vars r) '() s)))
     ((eq code 'return_)
      (let ((x (car s)) (e (cadr s)) (r (caddr s)) (s (cadddr s)))
        (VM a x e r s)))
     (t (progn
          (message "%s %s" "undefined instruction" code)
          (error "undefined instruction")
          nil)))))

(defun p (txt)
  (message "%s" txt)
  txt)

(defun lookup (var env)
  (let ((nxtrib '(lambda (e_)
                    (if (null e_) (error (message "lookup failed %s" var))
                      (let ((nxtelt '(lambda (vars vals)
                                       (cond
                                        ((null vars) (funcall nxtrib (cdr e_)))
                                        ((eq (car vars) var) vals)
                                        (t (funcall nxtelt (cdr vars) (cdr vals)))))))
                        (funcall nxtelt (caar e_) (cdar e_)))))))
    (funcall nxtrib env)))

;;@test
;;(lookup 'y '(((x y) 2 3)))

(defun closure (body e_ vars)
  (list body e_ vars))

(defun continuation (s_)
  (closure (list 'nuate s_ 'v) '() '(v)))

(defun call-frame (x_ e_ r_ s_)
  (list x_ e_ r_ s_))

(defun evaluate (lis)
  (VM '() (recursive-compile lis '(halt)) '() '() '()))

;;; call schel with current environment ;;;
;;'(((x y) 1 2) ((z a) 3 4)) ;;env
;;'(((x 1) (y 2)) ((z 3) (a 4))) ;;pair-up
;;'((x 1) (y 2) (z 3) (a 4)) ;;let

(defun pair-up (ls1 ls2)
  (if (or (null ls1) (null ls2)) nil
  (cons (list (car ls1) (car ls2)) (pair-up (cdr ls1) (cdr ls2)))))

(defmacro apply-with-env (funname arglis env)
  (let ((letified (reduce '(lambda (memo it)
                    (append memo (pair-up (car it) (cdr it))))
                 (eval env)
                 :initial-value nil)))
    (message "letified ---- %s" letified)
    (if (null letified)
        `(apply ,funname ,arglis)
      `(let ,letified
         (apply ,funname ,arglis)))))

;;@test
;;(apply-with-env 'message `("a:%d b:%d c:%d" ,a ,b ,c) '(((a b) 1 2) ((c) 3)))

;;;;;; examples ;;;;;;

;;calling schel functions with atoms
(evaluate '((schel + 1 2 ((lambda_ (x) x) 3)) ))

;;schel is now able to work with local scopes
(evaluate '(
            ((lambda_ (who be)
                      ((lambda_ (what)
                                (schel message "%s %s %s" who be what))
                       "yamapiko"))
             "My name" "is")
            ))
(evaluate '(
            ((lambda_ (prepend)
                      (schel mapcar (quote (lambda (x) (message "%s %d" prepend x))) (schel list 1 2 3)))
             "SCHEL> ")))

;;lexical scoping
(evaluate '(
            ((lambda_ (fn1 fn2)
                      (setq fn2 (lambda_ () localvar))
                      (setq fn1 (lambda_ (localvar) (fn2)))
                      (fn1 "locally binded to fn1")) ;;throws lookup failure exception
             0 0)))

01-changelog.txt

20120816
スペシャルフォームschelでelispの関数を呼ぶときにVMの環境を参照できるようにした。マクロでletを作ってその中で評価する。
  ((lambda_ (prepend)
            (schel mapcar (quote (lambda (x) (message "%s %d" prepend x))) (schel list 1 2 3)))
   "SCHEL> ")

equal -> eq