Kawaでかいたプログラム

;compile.scm
(define code '((mov ax 10)
	       (print ax)))



(define (byte-compile source-name out-name)
		(let ((code (read-source source-name))
			  (out (open-output-file out-name)))
		  (receive (o-l m-l) (compile code '() '())
				   (display "int code[]={" out)
				   (print-c  o-l out)
				   (print-last out))))



(define (read-source source-name)
	(let ((in (open-input-file source-name)))
	 (letrec ((loop (lambda (code in)
                          (let ((a (read in)))
				(if (eof-object? a)
				  (reverse code)
				  (loop (cons a code) in))))))
				  (loop '() in))))

		 

(define (compile code out-list mem-list)
	(if (null? code)
	    (values (reverse out-list) (reverse mem-list))
	    (receive (o-l m-l) (compile-line (car code))
			       (compile (cdr code)
					(cons o-l out-list)
					(cons m-l mem-list)))))

				   



(define (print-c code out)
	(if (null? code)
	   '()
	  (begin
	   (print-line (car code) out)
           (print-c (cdr code) out))))

		

(define (print-line code out)
	(cond ((list? code)
	       (byte-print out code))
	      (else
	       (byte-p code out))))



(define (print-last out)
	(display 4 out)
	(display "};" out))



(define (byte-p a out)
	(display a out)
	(display ", " out))

(define (byte-print out args)
	;(display args)
	(let loop ((l args))
	     (if (not (null? l))
		(begin
	         (byte-p (car l) out)
	         (loop (cdr l))))))



(define (compile-line code)
	(cond ((eq? (car code) 'mov)
	       (values (list 0 (caddr code)) #f))
	      ((eq? (car code) 'add)
	       (values 1 #f))
	      ((eq? (car code) 'print)
		(values 3 #f))))





//cpu.c

#include 

extern int code[];





int main(){

  return vm(code, 3);

}



int vm(int code[], int len){

  int ax;

  int pc_count=0;

  int last = 0;

  while(last == 0){

    switch(code[pc_count]){

    case 0:

      pc_count++;

      ax = code[pc_count];

      break;

    case 1://加算

      pc_count++;

      ax = ax+code[pc_count];

      break;

    case 2://減算

      pc_count++;

      ax = ax-code[pc_count];

      break;

    case 3://出力

      printf("%d\n", ax);

      break;

    case 4: //終了

      last = 1;

      break;

    case 5: //jmp

      pc_count++

      pc_count = code[pc_count];

      pc_count--; //下でpc_count++される為

      break

      }

    pc_count++;

  }

  return 1;

}



//test.txt
(mov ax 10)
(print ax)



使い方
kawaでcompile.scmを読み込んで
(byte-compile "test.txt" "test.c")
を実行すると、test.cが作成されます。
それから、
gcc -o test test.c vm.c
などでコンパイルするとtest.txtの内容が実行できるファイルが作成されます。

(define (run tokens)
		(define (calc p cur tape)
				(set-cdr! (assq cur tape)
						  (p (cdr (assq cur tape)) 1)))		
		(let ((tape '((0 . 0))) (cur 0) (pc 0)
			  (jumps (analyze_jumps tokens '() '() 0)))
		  (while (< pc (length tokens))
			(let ((token (list-ref  tokens pc)))
			  (cond
			   ((eq? token '+)
				(calc + cur tape))
			   ((eq? token '-)
				(calc - cur tape))
			   ((eq? token '>)
				(set! cur (+ cur 1))
				(if (not (assq cur tape))
					(set! tape (cons (cons cur 0) tape))))
			   ((eq? token '<)
				(set! cur (- cur 1))
				(if (< cur 0)
					(error "開始地点より左には移動できません")))
			   ((eq? token 'd) ;.
				(display (integer->char
						  (cdr (assq cur tape)))))
			   ((eq? token 'c) ;,
				(set-cdr! (assq cur tape) (read)))
			   ((eq? token '[)
				(if (= (cdr (assq cur tape)) 0)
					(set! pc (cdr (assq jumps pc)))))
			   ((eq? token '])
				(if (not (= (cdr (assq cur tape)) 0))
					(set! pc (cdr (assq pc jumps))))))
			  (set! pc (+ pc 1))))))


(define (analyze_jumps tokens  jumps starts i)
		(define (set-jumps to from jumps)
				(cons (cons from to) (cons (cons to from) jumps)))
		(cond ((null? tokens)
			   (if (null? starts)
				   jumps
				 (error "「[」が多すぎます")))
			  ((eq? (car tokens) '[)
			   (analyze_jumps (cdr tokens)
							  jumps
							  (cons  i starts)
							  (+ i 1)))
			  ((eq? (car tokens) '])
			   (if (null? starts)
				   (error "「]」が多すぎます")
				 (analyze_jumps (cdr tokens)
						  (set-jumps i (car starts) jumps)
						  (cdr starts)
						  (+ i 1))))
			  (else
			   (analyze_jumps (cdr tokens) jumps starts (+ i 1)))))
		

;Aを出力するサンプル

(define tokens '(+ + + + + +
		     [ > + + + + + + + + + + < - ]
		     > + + + + + d))
(run tokens)
;ループ処理の部分もできました

(define (run tokens)
		(define (calc p cur tape)
				(set-cdr! (assq cur tape)
						  (p (cdr (assq cur tape)) 1)))

		

		(let ((tape '((0 . 0))) (cur 0) (pc 0))
		  (while (< pc (length tokens))
			(let ((token (list-ref  tokens pc)))
			  (cond
			   ((eq? token '+)
				(calc + cur tape))
			   ((eq? token '-)
				(calc - cur tape))
			   ((eq? token '>)
				(set! cur (+ cur 1))
				(if (not (assq cur tape))
					(set! tape (cons (cons cur 0) tape))))
			   ((eq? token '<)
				(set! cur (- cur 1))
				(if (< cur 0)
					(error "開始地点より左には移動できません")))
			   ((eq? token 'd)
				(display (integer->char
						  (cdr (assq cur tape)))))
			   ((eq? token 'c)
				(set-cdr! (assq cur tape) (read)))))
			(set! pc (+ pc 1)))))
;Aを出力するサンプル

(define tokens '(+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

		+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + d))

(run tokens)



;最近,「Rubyで作る奇妙なプログラミング言語」読んでいて、勉強するついでに

;Brainf*ckのインタプリタのコードをkawaで書いてみました。まだ途中なので、
;ループの部分は書けていません。

(define primitive-procedures

  (list (list 'car car)

        (list 'cdr cdr)

        (list 'cons cons)

		(list 'string->list string->list)

        (list 'null? null?)

		(list 'list list)

		(list '+ +)

		(list '* *)

		(list '/ /)

		(list '< <)

		))



(define (primitive-procedure-names)

  (map car

       primitive-procedures))



(define (primitive-procedure-objects)

  (map (lambda (proc) (list 'primitive (cadr proc)))

       primitive-procedures))



(define (init-primitive-procedure)

	(make-frame (primitive-procedure-names)

		    (primitive-procedure-objects)))



(define (init-env)

	(let 

	    ((env (list (init-primitive-procedure))))

	  (define-variable! 'a 10 env)

	  env))



(define (make-frame names objects)

	(map (lambda (a b) (cons a b))

	     names

	     objects))



(define (extend-environment vars vals base-env)

		(if (pair? (cdr vars))

			(if (= (length vars) (length vals))

				(cons (make-frame vars vals) base-env)

			  (if (< (length vars) (length vals))

				  (error-display "Too many arguments supplied")

				(error-display "Too few arguments supplied" )))

		  (cons (make-frame (list (car vars) (cdr vars))

							(list (car vals) (cdr vals))) base-env)))

	

(define (myeval exp env)

	(cond ((self-eval? exp) exp)

	      ((symbol? exp) (lookup-variable-value exp env))

	      ((print-env? exp) env)

	      ((quote? exp) (cadr exp))

	      ((set? exp) (set-variable-value! (cadr exp)

					       (myeval (caddr exp) env)

					       env))

	      ((define? exp) (eval-define exp env))

	      ((lambda? exp) (make-procedure

			      (lambda-parameters exp)

			      (lambda-body exp)

			      env))

	      ((begin? exp) (begin-eval (cdr exp) env))

	      ((if? exp)

	       (eval-if exp env))

		  ((cond? exp) (eval-cond (cdr exp) env))

		  ((let? exp) (myeval (let->combination exp) env))

		  ((apply? exp) (myapply (myeval (cadr exp) env) (myeval (caddr exp) env)))

		  ((map? exp) (mymap exp env))

		  ((quasiquote? exp) (quasiquote-eval (cadr exp) env))

		  ((defmacro? exp) (make-macro (cdr exp) env))

	      ((application? exp)

		   (let ((proc (myeval (car exp) env)))

			 (if (macro? proc)

				 (eval-macro proc (cdr exp) env)

				 (myapply proc

						  (list-of-values (cdr exp) env)))))

		   (else

			(error-display "Unknown expression type -- EVAL"))))



(define (cons1 a)

		(cons a '()))

(define (map? proc)

		(tagged-list? proc 'map))

(define (print-env? proc)

		(tagged-list? proc 'print-env))

(define (mymap exp env)

		(define (loop-map proc val lis)

				  (if (null? val)

					  (reverse lis)

					(loop-map

					 proc

					 (cdr val)

					 (cons (myapply proc (cons1 (car val))) lis))))

		(loop-map (myeval (cadr exp) env) (myeval (caddr exp) env) '()))

					 

(define (apply? proc)

		(tagged-list? proc 'apply))

(define (true? proc)

	(eq? proc #t))



(define (cond? proc)

	(tagged-list? proc 'cond))



(define (eval-if exp env)

	(if (myeval (get-predicate exp) env)

	    (myeval (get-if-true exp) env)

	  (myeval (get-if-false exp) env)))



(define (eval-cond exp env)

	(cond ((eq? (caar exp) 'else)

	       (myeval (cadar exp) env))

	      ((true? (myeval (caar exp) env))

	       (myeval (cadar exp) env))

	      ((not (null? (cdr exp)))

	       (eval-cond (cdr exp) env))))



       (define (define? proc)

			   (tagged-list? proc 'define))



(define (application? exp) (pair? exp))



(define (primitive-procedure? proc)

  (tagged-list? proc 'primitive))



(define (compound-procedure? p)

  (tagged-list? p 'procedure))



(define (proc-parameters proc) (cadr proc))



(define (proc-body proc) (caddr proc))



(define (proc-env proc) (cadddr proc))



(define (myapply proc arg)

	(cond ((primitive-procedure? proc)

	       (apply (cadr proc) arg))

	      ((compound-procedure? proc)

	       (begin-eval

			(proc-body proc)

			(extend-environment

			 (proc-parameters proc)

			 arg

			 (proc-env proc))))

		  (else

		   (error-display

			"Unknown procedure type --APPLY"))))



(define (list-of-values exps env)

  (if (null? exps)

      '()

      (cons (myeval (car exps) env)

            (list-of-values (cdr exps) env))))



(define (error-display str)

	(display str)

	str)

;(if x #t #f)

(define (if? exp)

	(tagged-list? exp 'if))



(define (get-predicate exp)

	(cadr exp))



(define (get-if-true exp)

	(caddr exp))



(define (get-if-false exp)

	(cadddr exp))



(define (define? exp)

	(tagged-list? exp 'define))



(define (lambda? exp)

	(tagged-list? exp 'lambda))



(define (add-frame frame env)

	(cons frame env))



(define (get-variable-value l)

	(cdr l))



(define (get-frame env)

	(car env))



(define (first-variable var env)

	(assoc var (get-frame env)))



(define (make-variable var val)

	(cons var val))



(define (define-variable! var val env)

	(let ((v (first-variable var env)))

	  (if v

	      (set-cdr! v val)

	    (set-car! env (append (list (cons var val)) (get-frame env))))))



(define (set-variable-value! var val env)

	(if (null? env)

	    (error-display (string-append "Unbound variable " (symbol->string var)))

	  (let ((va (first-variable var env)))

		(if va

		    (begin

		     (set-cdr! va val)

		     'ok)

		  (set-variable-value! var val (cdr env))))))





		     

(define (lookup-variable-value var env)

	(if (null? env)

	    (error-display (string-append "Unbound variable " (symbol->string var)))

	  (let ((val (first-variable var env)))

	    (if val

			(get-variable-value val)

	      (lookup-variable-value var (cdr env))))))



(define (self-eval? exp)

	(or (string? exp) (number? exp)))



(define (tagged-list? exp tag)

	(if (pair? exp)

	    (eq? (car exp) tag)

	  #f))

		 

		 

(define (quote? exp)

	(tagged-list? exp 'quote))



(define (set? exp)

	(tagged-list? exp 'set!))



(define (begin? exp)

	(tagged-list? exp 'begin))



(define (begin-eval exp env)

	(if (null? (cdr exp))

	    (myeval (car exp) env)

	  (begin

	   (myeval (car exp) env)

	   (begin-eval (cdr exp) env))))

	  

(define (make-procedure parameters body env)

  (list 'procedure parameters body env))



(define (lambda-parameters exp) (cadr exp))



(define (lambda-body exp) (cddr exp))



(define (make-lambda parameters body)

	(cons 'lambda (cons parameters body)))



(define (eval-define exp env)

	(if (symbol? (cadr exp))

	    (define-variable! (cadr exp)

			      (myeval (caddr exp) env)

						  env)

	  (define-variable! (caadr exp)

			    (myeval (make-lambda (cdadr exp)

									 (cddr exp))

				    env)

			    env)))

(define env (init-env))



(define (let->combination exp)

		(let* ((lis (cadr exp))

			   (var-list (map car lis))

			   (val-list (map cadr lis)))

		  (cons (cons 'lambda (cons var-list (cddr exp))) val-list)))



(define (let? exp)

	(tagged-list? exp 'let))



;マクロ

(define (quasiquote? proc)

	(tagged-list? proc 'quasiquote))



(define (unquote? proc)

	(tagged-list? proc 'unquote))



(define (unquote-splicing? proc)

	(tagged-list? proc 'unquote-splicing))



(define (quasiquote-eval exp env)

	(define (loop exp lis)

		(cond ((null? exp) (reverse lis))

		      ((unquote? (car exp))

		       (loop (cdr exp) (cons (myeval (cadr (car exp)) env) lis)))

		      ((unquote-splicing? (car exp))

		       (loop (cdr exp) (reverse (append (reverse lis) (myeval (cadr (car exp)) env)))))

			  ((pair? (car exp))

			   (loop (cdr exp) (cons (loop (car exp) '()) lis))) ;(a b cd (,@a))

		      (else

		       (loop (cdr exp) (cons (car exp) lis)))))

	(loop exp '()))

(define (defmacro? proc)

		(tagged-list? proc 'define-macro))

(define (macro? proc)

		(tagged-list? proc 'macro))



(define (eval-macro proc arg env)

		(myeval (begin-eval

				 (proc-body proc)

				 (extend-environment

				  (proc-parameters proc)

				  arg

				  (proc-env proc)))

				env))

(define (make-macro-procedure exp env)

		(list (lambda-parameters exp) (lambda-body exp) env))



(define (make-macro exp env)

		(if (symbol? (car exp))

			(define-variable! (car exp)

							  (cons 'macro (make-macro-procedure (cadr exp) env)) env)

		  (define-variable! (caar exp)

							(cons 'macro (make-macro-procedure (make-lambda

																(cdar exp)

																(cdr exp))

															   env))

							env)))
;実行方法
;(myeval '(+ 10 20 30 40) env)

(require 'gui)
(run-application
 (Window title: "こんにちは"
	 content: (Label "こんにちは世界")))

;'guiというライブラリを使うと、kawaでのguiプログラミングが
;楽になりそうです。
;今までActionListenerなどの処理を、kawaでどうやるか悩んでいたのですが
;このライブラリには、この処理を簡単に書く方法が用意されているようです。

;sicpの問題1.3
(define (sum2-squares a b c)
  (if (< a b)
      (if (< a c)
	  (+ (* b b) (* c c))
	  (+ (* a a) (* b b)))
      (if (< b c)
	  (+ (* a a) (* c c))
	  (+ (* a a) (* b b)))))

(define-namespace File )

(define f (File:new "test.txt"))

(display "ファイルサイズ: ")
(display (f:length))