3.txt

;;;;;;;;;;
;;;*set_additional_func()
;;;;;;;;;;
*set_additional_func
  mov $sarg0, "(define caar (lambda (x) (car (car x))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define cadr (lambda (x) (car (cdr x))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define cdar (lambda (x) (cdr (car x))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define cddr (lambda (x) (cdr (cdr x))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define list (lambda lst lst))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define assq (lambda (key lst) (if (null? lst) nil (if (eq? key (caar lst)) (car lst) (assq key (cdr lst))))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define length (lambda (lst) (letrec ((length-iter (lambda (n lst) (if (null? lst) n (length-iter (+ n 1) (cdr lst)))))) (length-iter 0 lst))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define list-ref (lambda (lst n) (car (list-tail lst n))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define list-tail (lambda (lst n) (if (eq? n 0) lst (list-tail (cdr lst) (- n 1)))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define append (lambda (x y) (if (null? x) y (cons (car x) (append (cdr x) y)))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define map (lambda (fn lst . more) (letrec ((map1 (lambda (l) (if (null? l) nil (cons (fn (car l)) (map1 (cdr l)))))) (map-more (lambda (l m) (if (null? l) nil (cons (apply fn (car l) (map car m)) (map-more (cdr l) (map cdr m))))))) (if (null? more) (map1 lst) (map-more lst more)))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define list? (lambda (x) (if (eq? x nil) #t (if (pair? x) (list? (cdr x)) #f))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define not (lambda (x) (eq? x #f)))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define memq (lambda (x lst) (if (null? lst) #f (if (eq? x (car lst)) lst (memq x (cdr lst))))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define member (lambda (x lst) (if (null? lst) #f (if (equal? x (car lst)) lst (member x (cdr lst))))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov $sarg0, "(define assoc (lambda (key lst) (if (null? lst) nil (if (equal? key (caar lst)) (car lst) (assoc key (cdr lst))))))"
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
textclear
  mov %adv_additional, 1
  return




*free_mode
  gosub *destroy_title
  print 1
  speak_mode
bgm ms_ex
  mov %adv_bgm, 1
  mov %adv_tmp, 0
  mov %save_flag, 0  ;セーブ不能
  csp SP_R : csp SP_L
  r_show ari_n
  mov %adv_char, 1    ;=arisa

  ;;ゲーム進行状況を読み込む
  csvopen "arisa.szk", "rc"
  csvread %adv_clear
  csvclose

  ;;Lisp側の準備
  mov %adv_rmode, 0
  if %adv_additional == 0 gosub *set_additional_func
  gosub *create_new_env  ;自由にいじれるように新しい環境を作る
  mov %arg0, %ret
  mov %toplevel_env, %arg0
  gosub *push  ;GC対策
  mov %arg1, %global_env
  gosub *nconc
  mov %eval_limit, 0
*fm01
  mov %gc_run, 0  ;GC起動回数を初期化
  mov %current_proc, %nil
  mov %current_env, %toplevel_env
  mov %adv_error, 0
  mov $sarg0, ""
  textclear
  gosub *fm01_say_tab
  textfield $sarg0, 30, 120, 770, 140, 10, 20, 0
  getret %ret
  ;if %ret == 1 goto *fm01_end  ;Tab
  if %ret == 1 goto *fm01_menu  ;Tab
  if $sarg0 == "" goto *fm01
textclear
  if $sarg0 == "__ex_test__" gosub *ex_test_start : goto *fm01
  if $sarg0 == "__lisp_test__" gosub *lisp_test_start : goto *fm01
  gosub *fm01_say_calc
repaint
  gosub *check_lr_parenthesis
  if %ret != 0 gosub *fm01_say_parenthesis_error : goto *fm01
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %toplevel_env
  gosub *eval_form
  mov %arg0, %ret
  gosub *get_tag : if %ret == TAG_ERROR mov %adv_error, 1
  gosub *lobject_to_string
  textclear
  gosub *fm01_say_result
  inc %adv_tmp    ;;;?
  goto *fm01

*fm01_end
  gosub *pop
  mov %eval_limit, DEFAULT_EVAL_LIMIT
  saveon
  mov %save_flag, 1  ;セーブ可能
  textclear
  gosub *fm01_say_goodbye
stop
  csp SP_R
  print E_FAST
  goto *title


*fm01_menu
if %adv_clear == 0 csel "戻る", *fm01, "ＢＧＭ　ＯＮ／ＯＦＦ", *fm01_menu_bgm, "立ち絵　ＯＮ／ＯＦＦ", *fm01_menu_char, "終了", *fm01_end
csel "戻る", *fm01, "ＢＧＭ　ＯＮ／ＯＦＦ", *fm01_menu_bgm, "立ち絵", *fm01_menu_char_change, "終了", *fm01_end


*fm01_menu_bgm
  if %adv_bgm == 1 mov %adv_bgm, 0 : stop : goto *fm01
bgm ms_ex
  mov %adv_bgm, 1
  goto *fm01

*fm01_menu_char
  if %adv_char == 1 mov %adv_char, 0 : csp SP_R : print E_FAST : goto *fm01
  r_show ari_n
  mov %adv_char, 1
  goto *fm01

*fm01_menu_char_change
if %adv_clear <= 3 csel "立ち絵なし", *fm01_char_non, "アリサ", *fm01_char_arisa, "すずか", *fm01_char_suzuka
if %adv_clear <= 8 csel "立ち絵なし", *fm01_char_non, "アリサ", *fm01_char_arisa, "すずか", *fm01_char_suzuka, "鮫島", *fm01_char_samejima, "時空管理局局員Ａ", *fm01_char_jiku
if %adv_clear <= 11 csel "立ち絵なし", *fm01_char_non, "アリサ", *fm01_char_arisa, "すずか", *fm01_char_suzuka, "鮫島", *fm01_char_samejima, "時空管理局局員Ａ", *fm01_char_jiku, "時空管理局局員Ｂ", *fm01_char_jiku2
csel "立ち絵なし", *fm01_char_non, "アリサ", *fm01_char_arisa, "すずか", *fm01_char_suzuka, "鮫島", *fm01_char_samejima, "時空管理局局員Ａ", *fm01_char_jiku, "時空管理局局員Ｂ", *fm01_char_jiku2, "なのは", *fm01_char_nanoha




*fm01_char_non
  mov %adv_char, 0
  csp SP_R
  print E_FAST
  goto *fm01

*fm01_char_arisa
  mov %adv_char, 1
  r_show ari_n
アリサ「さあ、やるわよ！」\
  goto *fm01

*fm01_char_suzuka
  mov %adv_char, 2
  r_show suzur_nc
すずか「頑張ろうね」\
  goto *fm01

*fm01_char_samejima
  mov %adv_char, 3
  r_show ":l;img/same.bmp"
鮫島「お呼びでしょうか？」\
  goto *fm01

*fm01_char_jiku
  mov %adv_char, 4
  r_show ":l;img/jiku.bmp"
局員「は！　お呼びでしょうか」\
  goto *fm01

*fm01_char_jiku2
  mov %adv_char, 5
  r_show ":l;img/jiku2.bmp"
局員「あー、めんどくさ……」\
  goto *fm01

*fm01_char_nanoha
  mov %adv_char, 6
  r_show ":l;img/nano.bmp"
なのは「なのっ！」\
  goto *fm01


*fm01_say_goodbye
  if %adv_char == 0 puttext "お疲れ様でした\"
  if %adv_char == 1 puttext "アリサ「おつかれさま」\"
  if %adv_char == 2 puttext "すずか「ばいば～い」\"
  if %adv_char == 3 puttext "鮫島「ありがとうございました」\"
  if %adv_char == 4 puttext "局員「了解しました！」\"
  if %adv_char == 5 puttext "局員「ひっ、ひぃぃぃーーー！」\"
  if %adv_char == 6 puttext "なのは「おわりなの」\"
  mov %adv_rmode, 1
  return

*fm01_say_tab
  if %adv_char == 0 puttext "Ｔａｂキーでメニューが開けます"
  if %adv_char == 1 puttext "アリサ「Ｔａｂキーでメニューが開けるわよ」"
  if %adv_char == 2 puttext "すずか「Ｔａｂキーでメニューが開けるよ」"
  if %adv_char == 3 puttext "鮫島「Ｔａｂキーでメニューが開けます」"
  if %adv_char == 4 puttext "局員「Ｔａｂキーでメニューが開けます！」"
  if %adv_char == 5 puttext "局員「Ｔａｂキーでメニューが開けるぞ！」"
  if %adv_char == 6 puttext "なのは「Ｔａｂキーでメニューが開けるの」"
  return

*fm01_say_calc
  if %adv_char == 0 puttext "!s0計算中……!sd"
  if %adv_char == 1 puttext "!s0アリサ「計算中……」!sd"
  if %adv_char == 2 puttext "!s0すずか「計算中だよ……」!sd"
  if %adv_char == 3 puttext "!s0鮫島「計算中です……」!sd"
  if %adv_char == 4 puttext "!s0局員「計算中です！」!sd"
  if %adv_char == 5 puttext "!s0局員「計算中だ！」!sd"
  if %adv_char == 6 puttext "!s0なのは「計算中なの」!sd"
  return

*fm01_say_result
  if %adv_char == 0 goto *fm01_say_result0
  if %adv_char == 1 goto *fm01_say_result1
  if %adv_char == 2 goto *fm01_say_result2
  if %adv_char == 3 goto *fm01_say_result3
  if %adv_char == 4 goto *fm01_say_result4
  if %adv_char == 5 goto *fm01_say_result5
  if %adv_char == 6 goto *fm01_say_result6

*fm01_say_result0
  if %adv_error == 1 goto *fm01_say_result0_error
『$sret』@
  return
*fm01_say_result0_error
#33FF33$sret#FFFFFF@
  return
*fm01_say_result1
  if %adv_error == 1 goto *fm01_say_result1_error
アリサ「結果は『$sret』ね」@
  return
*fm01_say_result1_error
アリサ「プログラムに誤りがあるわ」
#33FF33$sret#FFFFFF@
  return
*fm01_say_result2
  if %adv_error == 1 goto *fm01_say_result2_error
すずか「結果は『$sret』だよ」@
  return
*fm01_say_result2_error
すずか「プログラムに誤りがあるよ」
#33FF33$sret#FFFFFF@
  return
*fm01_say_result3
  if %adv_error == 1 goto *fm01_say_result3_error
鮫島「結果は『$sret』でございます」@
  return
*fm01_say_result3_error
鮫島「プログラムに誤りがございます」
#33FF33$sret#FFFFFF@
  return
*fm01_say_result4
  if %adv_error == 1 goto *fm01_say_result4_error
局員「結果は『$sret』です！」@
  return
*fm01_say_result4_error
局員「プログラムに誤りがあります！」
#33FF33$sret#FFFFFF@
  return
*fm01_say_result5
  if %adv_error == 1 goto *fm01_say_result5_error
局員「結果は『$sret』だ！」@
  return
*fm01_say_result5_error
局員「プログラムに誤りがあるぞ！」
#33FF33$sret#FFFFFF@
  return
*fm01_say_result6
  if %adv_error == 1 goto *fm01_say_result6_error
なのは「結果は『$sret』なの」@
  return
*fm01_say_result6_error
なのは「プログラムに誤りがあるの」
#33FF33$sret#FFFFFF@
  return

*fm01_say_parenthesis_error
  textclear
  if %adv_char == 0 puttext "括弧の開く数と、閉じる数が一致していません\"
  if %adv_char == 1 goto *fm01_say_parenthesis_error_arisa
  if %adv_char == 2 goto *fm01_say_parenthesis_error_suzuka
  if %adv_char == 3 puttext "鮫島「括弧の開く数と、閉じる数が一致しておりません」\"
  if %adv_char == 4 puttext "局員「括弧の開く数と、閉じる数が一致していません！」\"
  if %adv_char == 5 puttext "局員「括弧の開く数と、閉じる数が一致していない！」\"
  if %adv_char == 6 puttext "なのは「括弧の開く数と、閉じる数が一致していないの」\"
  return


*fm01_say_parenthesis_error_arisa
  r_show ari_die
アリサ「括弧の開く数と、閉じる数が一致していないわよ」\
  r_show ari_n
  return

*fm01_say_parenthesis_error_suzuka
  r_show suzur_ase
すずか「括弧の開く数と、閉じる数が一致していないよ」\
  r_show suzur_n
  return


;;;*lisp_test_eval($form, $description)
*lisp_test_eval
!s0$sarg1!sd
!s0ｓｐ：%sp!sd
!s0ｓｓｐ：%ssp!sd
  len %arg0, $sarg0
  gosub *push         ; S(length)
  gosub *spush        ; SS(form)
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  mov %arg0, %ret     ; %arg0 = result
  if %ret == %sharp_f goto *lisp_test_eval_fail
!s0【#00FF00ｐａｓｓ#FFFFFF】!sd
*lisp_test_eval_stack_check
  gosub *spop         ; form < SS()
  len %tmp, $sret
  gosub *pop          ; length < S()
!s0ｓｐ：%sp!sd
!s0ｓｓｐ：%ssp!sd
  if %tmp != %ret gosub *lisp_test_eval_stack_error
  textclear
  return
*lisp_test_eval_fail
!s0【#FF0000ｆａｉｌ#FFFFFF】!sd@
  goto *lisp_test_eval_stack_check
*lisp_test_eval_stack_error
!s0#FF0000！！！ｓｔａｃｋ　ｗａｓ　ｂｒｏｋｅｎ！！！#FFFFFF!sd@
  return

*lisp_test_start
  ;; Basic tests
  mov $sarg0, "(eq? 'test 'test)"
  mov $sarg1, "ｅｑ？"
  gosub *lisp_test_eval
  mov $sarg0, "(= 1 1)"
  mov $sarg1, "＝"
  gosub *lisp_test_eval
  mov $sarg0, "(not #f)"
  mov $sarg1, "ｎｏｔ"
  gosub *lisp_test_eval

  ;; Type tests
  mov $sarg0, "(boolean? #t)"
  mov $sarg1, "ｂｏｏｌｅａｎ？　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(not (boolean? '()))"
  mov $sarg1, "ｂｏｏｌｅａｎ？　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(symbol? 'test)"
  mov $sarg1, "ｓｙｍｂｏｌ？　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(not (symbol? 1))"
  mov $sarg1, "ｓｙｍｂｏｌ？　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(number? 1)"
  mov $sarg1, "ｎｕｍｂｅｒ？　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(not (number? 'test))"
  mov $sarg1, "ｎｕｍｂｅｒ？　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(pair? (cons 1 2))"
  mov $sarg1, "ｐａｉｒ？　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(not (pair? '()))"
  mov $sarg1, "ｐａｉｒ？　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(procedure? car)"
  mov $sarg1, "ｐｒｏｃｅｄｕｒｅ？　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(not (procedure? 'car))"
  mov $sarg1, "ｐｒｏｃｅｄｕｒｅ？　＃２"
  gosub *lisp_test_eval

  ;; Numeric tests
  mov $sarg0, "(= (+ 1 2 3) (+ 1 (+ 2 3)))"
  mov $sarg1, "＋"
  gosub *lisp_test_eval
  mov $sarg0, "(= (- 1 100) -99)"
  mov $sarg1, "－"
  gosub *lisp_test_eval
  mov $sarg0, "(= (* 2 3 4) (* (* 2 3) 4))"
  mov $sarg1, "＊"
  gosub *lisp_test_eval
  mov $sarg0, "(= (/ 99 33) 3)"
  mov $sarg1, "／"
  gosub *lisp_test_eval
  mov $sarg0, "(= (mod 13 7) 6)"
  mov $sarg1, "ｍｏｄ"
  gosub *lisp_test_eval
  mov $sarg0, "(< 99 100)"
  mov $sarg1, "＜　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(not (< 100 100))"
  mov $sarg1, "＜　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(<= 99 100)"
  mov $sarg1, "＜＝　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(<= 100 100)"
  mov $sarg1, "＜＝　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(not (<= 101 100))"
  mov $sarg1, "＜＝　＃３"
  gosub *lisp_test_eval
  mov $sarg0, "(> 100 99)"
  mov $sarg1, "＞　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(not (> 100 100))"
  mov $sarg1, "＞　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(not (>= 99 100))"
  mov $sarg1, "＞＝　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(>= 100 100)"
  mov $sarg1, "＞＝　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(>= 101 100)"
  mov $sarg1, "＞＝　＃３"
  gosub *lisp_test_eval

  ;; List tests
  mov $sarg0, "(null? '())"
  mov $sarg1, "ｎｕｌｌ？　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(not (null? #f))"
  mov $sarg1, "ｎｕｌｌ？　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(list? '())"
  mov $sarg1, "ｌｉｓｔ？　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(not (list? (cons 1 2)))"
  mov $sarg1, "ｌｉｓｔ？　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(list? (cons 'a '()))"
  mov $sarg1, "ｌｉｓｔ？　＃３"
  gosub *lisp_test_eval
  mov $sarg0, "(equal? '() '())"
  mov $sarg1, "ｅｑｕａｌ？　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(equal? (cons 1 2) (cons 1 2))"
  mov $sarg1, "ｅｑｕａｌ？　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(not (equal? (cons 1 2) (cons 3 4)))"
  mov $sarg1, "ｅｑｕａｌ？　＃３"
  gosub *lisp_test_eval
  mov $sarg0, "(eq? (car (cons 'a 'b)) 'a)"
  mov $sarg1, "ｃａｒ"
  gosub *lisp_test_eval
  mov $sarg0, "(eq? (cdr (cons 'a 'b)) 'b)"
  mov $sarg1, "ｃｄｒ"
  gosub *lisp_test_eval
  mov $sarg0, "(equal? (list 1 2) (cons 1 (cons 2 '())))"
  mov $sarg1, "ｌｉｓｔ"
  gosub *lisp_test_eval
  mov $sarg0, "(= (length '(a b c)) 3)"
  mov $sarg1, "ｌｅｎｇｔｈ"
  gosub *lisp_test_eval
  mov $sarg0, "(eq? (list-ref '(a b c) 1) 'b)"
  mov $sarg1, "ｌｉｓｔ－ｒｅｆ"
  gosub *lisp_test_eval
  mov $sarg0, "(equal? (list-tail '(a b c) 1) '(b c))"
  mov $sarg1, "ｌｉｓｔ－ｔａｉｌ"
  gosub *lisp_test_eval
  mov $sarg0, "(equal? (append '(a) '(b c)) '(a b c))"
  mov $sarg1, "ａｐｐｅｎｄ"
  gosub *lisp_test_eval
  mov $sarg0, "(equal? (assoc 'c '((a b) (c d))) '(c d))"
  mov $sarg1, "ａｓｓｏｃ"
  gosub *lisp_test_eval
  mov $sarg0, "(equal? (member 'b '(a b c)) '(b c))"
  mov $sarg1, "ｍｅｍｂｅｒ"
  gosub *lisp_test_eval
  mov $sarg0, "(equal? (map list '(a b c)) '((a) (b) (c)))"
  mov $sarg1, "ｍａｐ"
  gosub *lisp_test_eval

  ;; Special form tests
  mov $sarg0, "(= (begin 1 2 3) 3)"
  mov $sarg1, "ｂｅｇｉｎ"
  gosub *lisp_test_eval
  mov $sarg0, "(and)"
  mov $sarg1, "ａｎｄ　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(and 1 2)"
  mov $sarg1, "ａｎｄ　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(not (and 1 2 #f))"
  mov $sarg1, "ａｎｄ　＃３"
  gosub *lisp_test_eval
  mov $sarg0, "(not (or))"
  mov $sarg1, "ｏｒ　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(not (or  #f))"
  mov $sarg1, "ｏｒ　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(or #f 1 2))"
  mov $sarg1, "ｏｒ　＃３"
  gosub *lisp_test_eval
  mov $sarg0, "(= (if '() 1 2) 1)"
  mov $sarg1, "ｉｆ　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(= (if #f 1 2) 2)"
  mov $sarg1, "ｉｆ　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(= (cond (#t 1 2) (else 3 4)) 2)"
  mov $sarg1, "ｃｏｎｄ　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(= (cond (#f 1 2) (else 3 4)) 4)"
  mov $sarg1, "ｃｏｎｄ　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(= ((lambda (x y) (+ x y)) 1 2) 3)"
  mov $sarg1, "ｌａｍｂｄａ"
  gosub *lisp_test_eval
  mov $sarg0, "(= ((let ((x 1)(y 2)) (let ((x 3) (y x)) (+ x y))) 4)"
  mov $sarg1, "ｌｅｔ"
  gosub *lisp_test_eval
  mov $sarg0, "(= ((let ((x 1)(y 2)) (let* ((x 3) (y x)) (+ x y))) 6)"
  mov $sarg1, "ｌｅｔ＊"
  gosub *lisp_test_eval
  mov $sarg0, "(= (letrec ((fact (lambda (x)(if (= x 0) 1 (* x (fact (- x 1))))))) (fact 5)) 120)"
  mov $sarg1, "ｌｅｔｒｅｃ"
  gosub *lisp_test_eval

  ;; Definition and mutation tests
  mov $sarg0, "(define _x 1)"
  mov $sarg1, "ｄｅｆｉｎｅ　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(= _x 1)"
  mov $sarg1, "ｄｅｆｉｎｅ　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(= (begin (set! _x 99) _x) 99)"
  mov $sarg1, "ｓｅｔ！　ｇｌｏｂａｌ"
  gosub *lisp_test_eval
  mov $sarg0, "(and (= (let ((_x 0)) (set! _x 551) _x) 551) (= _x 99))"
  mov $sarg1, "ｓｅｔ！　ｌｏｃａｌ"
  gosub *lisp_test_eval
  mov $sarg0, "(let ((x (cons 1 2))) (set-car! x 'a) (equal? x (cons 'a 2)))"
  mov $sarg1, "ｓｅｔ－ｃａｒ！"
  gosub *lisp_test_eval
  mov $sarg0, "(let ((x (cons 1 2))) (set-cdr! x 'a) (equal? x (cons 1 'a)))"
  mov $sarg1, "ｓｅｔ－ｃｄｒ！"
  gosub *lisp_test_eval

  ;; Error tests
  ;; HACK: (and X (not X)) => X iff X is a error object.
  mov $sarg0, "(let ((x (error 'test))) (and x (not x)))"
  mov $sarg1, "ｅｒｒｏｒ"
  gosub *lisp_test_eval
  mov $sarg0, "(let ((x (car))) (and x (not x)))"
  mov $sarg1, "ｔｏｏ　ｆｅｗ　ａｒｇｕｍｅｎｔｓ"
  gosub *lisp_test_eval
  mov $sarg0, "(let ((x (car 1 2))) (and x (not x)))"
  mov $sarg1, "ｔｏｏ　ｍａｎｙ　ａｒｇｕｍｅｎｔｓ"
  gosub *lisp_test_eval
  mov $sarg0, "(let ((x (car 1))) (and x (not x)))"
  mov $sarg1, "ｗｒｏｎｇ　ｔｙｐｅ"
  gosub *lisp_test_eval
  mov $sarg0, "(let ((x (if))) (and x (not x)))"
  mov $sarg1, "ｉｎｖａｌｉｄ　ｉｆ　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(let ((x (if 1 2 3 4))) (and x (not x)))"
  mov $sarg1, "ｉｎｖａｌｉｄ　ｉｆ　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(let ((x (cond))) (and x (not x)))"
  mov $sarg1, "ｉｎｖａｌｉｄ　ｃｏｎｄ　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(let ((x (cond 1))) (and x (not x)))"
  mov $sarg1, "ｉｎｖａｌｉｄ　ｃｏｎｄ　＃２"
  gosub *lisp_test_eval
  mov $sarg0, "(let ((x (lambda))) (and x (not x)))"
  mov $sarg1, "ｉｎｖａｌｉｄ　ｌａｍｂｄａ　＃１"
  gosub *lisp_test_eval
  mov $sarg0, "(let ((x (lambda 1 2))) (and x (not x)))"
  mov $sarg1, "ｉｎｖａｌｉｄ　ｌａｍｂｄａ　＃２"
  gosub *lisp_test_eval
  return