0.txt

;mode800,value4000

;;;;;;;;;;
;;; Variables and Stack:
;;;   There are some variables and the single stack.
;;;   The values in them are protected from GC.
;;;   Variables tmp, tmp1, tmp2, ... have a temporary value.
;;;   Variables arg0, arg1, ... are used for argument passing.
;;;   Primary subroutines set_gc, get_gc, set_tag, get_tag, set_data, and
;;;   get_data keep the value of argN, but they may change the value of tmpN.
;;;
;;; Lisp objects:
;;;   [MSB]                      [LSB]
;;;   0DDDDDDDDDDDDDDDDDDDDDDDDDTTTTTG
;;;     D: Data    (25 bits)
;;;     T: Tag     (5 bits)
;;;     G: GC Mark (1 bit)
;;;     (MSB must be 0 because we use arithmetic ops instead of binary ops.)
;;;   CAR of cons cells occupies the low 13 bits of Data part.
;;;   CDR of cons cells occupies the remaining bits of Data part.
;;;   Symbols are also partitioned into CAR and CDR.
;;;   CAR part of symbols points to the string which is the symbol name.
;;;   All symbols are chained by their CDR part.
;;;   EXPR is represented with lists such as (env arg . body).
;;;   Errors are represented with lists such as (message . location).
;;;
;;; ATTENTION:
;;;   Do not allocate new cons cell in for-loop.
;;;
;;; Memo:
;;;   ";value" must be written at the first line.
;;;   "Global variables" in NScripter are 0 if we do not call "globalon".
;;;   We should call "mem_init" after load (?)
;;;;;;;;;;




*define
nsa
  textgosub *text_cw

  ; Effect
  numalias E_FAST, 10
  numalias E_NORMAL, 11
  numalias E_SLOW, 12
  numalias E_RWIPE_SLOW, 13
  numalias E_VFAST, 14
  numalias E_RAIN, 15
  numalias E_BUBBLE, 16
  numalias E_WIPE2, 17
  numalias E_LWIPE_FAST, 18
  numalias E_CURCLE, 19
  effect E_VFAST, 10, 100
  effect E_FAST, 10, 200
  effect E_NORMAL, 10, 500
  effect E_SLOW, 10, 1000
  effect E_RWIPE_SLOW, 15, 1000, "img/wipe_r.bmp"
  effect E_LWIPE_FAST, 15, 200, "img/wipe_l.bmp"
  effect E_RAIN, 15, 200, "img/25e.bmp"
  effect E_BUBBLE, 15, 200, "img/17e.bmp"
  effect E_WIPE2, 15, 600, "img/wipe2.bmp"
  effect E_CURCLE, 15, 2000, "img/curcle.bmp"

  ; Sprites
  numalias SP_FILL, 0
  numalias SP_CLICK, 1
  numalias SP_CLICK_MINI, 2

  ; Temporary
  numalias SP_TMP, 10
  numalias SP_TMP1, 11
  numalias SP_TMP2, 12
  numalias SP_TMP3, 13

  ; Opening
  numalias SP_LOGO0, 20
  numalias SP_LOGO1, 21
  numalias SP_LOGO_LAMBDA, 23
  numalias SP_LOGO_KUMI, 24
  numalias SP_LOGO_SAKURA, 25
  numalias SP_LOGO_KARASU, 26
  numalias SP_TITLE_SEN, 30
  numalias SP_TITLE, 31
  numalias SP_TITLE_HOSHI, 32

  ; Ending
  numalias SP_SAME_HEAD, 40
  numalias SP_SAME_BODY, 41
  numalias SP_SAME_FOOT, 42
  numalias SP_INU01, 43
  numalias SP_INU02, 44
  numalias SP_INU01_R, 45
  numalias SP_INU02_R, 46
  numalias SP_FLOWER, 47
  numalias SP_S, 48
  numalias SP_ST, 49
  numalias SP_EFRAME, 50

  ; Baseball
  numalias SP_BALL, 100
  numalias SP_REIN01, 101
  numalias SP_REIN02, 102
  numalias SP_REIN03, 103
  numalias SP_VITA01, 111
  numalias SP_VITA02, 112
  numalias SP_ARROW, 119

  ;Right click
  numalias SP_RC_BACK, 210
  numalias SP_RC_1, 201
  numalias SP_RC_2, 202
  numalias SP_RC_3, 203
  numalias SP_RC_4, 204
  numalias SP_RC_5, 205

  ; Noroi-sama
  numalias SP_NOROI_HALF, 800
  numalias SP_NOROI, 801
  numalias SP_NOROI_D1, 802
  numalias SP_NOROI_D2, 803
  numalias SP_NOROI_HD2, 804
  numalias SP_NOROI_HD1, 805

  ; Character
  numalias SP_CRC, 809
  numalias SP_L, 810
  numalias SP_R, 811
  numalias SP_C, 812

  ; Stuffed rabbit
  numalias SP_USAGI, 816
  numalias SP_USAGI_R, 817

  ; Figure
  numalias SP_DGM0, 850
  numalias SP_DGM1, 851
  numalias SP_DGM2, 852
  numalias SP_DGM3, 853

  ; Other settings for pictures
  numalias SP_BACKGROUND, 900
  numalias SP_DUMMY, 999
  humanz 800  ; Sprites whose numbers <= 800 are drawn on front.
  windowback  ; Window is the same as above.
  usewheel

  ; Constants
  ;; Heap is used for any lisp objects (100 <= heap < 3000)
  numalias HEAP, 100
  numalias HEAP_LAST, 2999
  numalias HEAP_LIMIT, 3000
  ;; Stack is used for any lisp objects and integers (3000 <= stack < 4000)
  numalias STACK, 3000
  numalias STACK_SAFE_LIMIT, 3990
  numalias STACK_LIMIT, 4000
  ;; Symbol-set is used for symbol strings (100 <= from < 500 <= to < 900)
  numalias SYMBOL_SET, 100
  numalias SYMBOL_SET_HALF_SIZE, 400
  ;; SStack is used for any string (900 <= sstack < 1000)
  numalias SSTACK, 900
  numalias SSTACK_LIMIT, 1000
  numalias TAG_CONS, 0
  numalias TAG_SYMBOL, 1
  numalias TAG_NUM, 2
  numalias TAG_SUBR, 3
  numalias TAG_EXPR, 4
  numalias TAG_FREE, 5
  numalias TAG_ERROR, 6
  numalias TAG_VAR, 7
  numalias TAG_GVAR, 8
  numalias TAG_BOOL, 9
  numalias MAX_NUMBER, 16777215          ; 2^24 - 1
  numalias MIN_NUMBER, -16777216         ; - 2^24
  numalias UNSIGNED_MAX_PLUS1, 33554432  ; 2^25
  numalias MIN_INT32, -2147483648        ; - 2^31
  numalias NON_VALUE, -1  ; Every lisp object is different from this value.
  numalias DEFAULT_EVAL_LIMIT, 20000
  numalias UNBOUND, 4095

  ;;;
  ;;; Next variable number: 95
  ;;;

  ; Aliases for numerical variables
  ;; General variables
  numalias tmp, 50
  numalias ret, 51
  numalias arg0, 52
  numalias arg1, 53
  numalias arg2, 54
  numalias arg3, 55
  numalias tmp1, 56
  numalias tmp2, 57
  numalias tmp3, 58

  ;; Special variables
  numalias sp, 59
  numalias free_lst, 60
  numalias i, 61
  numalias gc_tmp ,62
  numalias eval_count, 63
  numalias symbol_used, 64
  numalias ssp, 65

  ;; Lisp object
  numalias nil, 66
  numalias quote, 67
  numalias global_env, 68
  numalias sharp_t, 69
  numalias sharp_f, 70
  numalias toplevel_env, 71

  ;; Garbage collection
  numalias gc_count, 72
  numalias symbol_lst, 73
  numalias symbol_offset, 74
  numalias gc_run, 75
  numalias eval_limit, 76
  numalias gc_silent, 77
  numalias gc_mark_color, 94

  ;; Debug
  ;; NOTE: current_proc and current_env are not protected from GC so far.
  ;;       We should protect them if GC moves objects.
  numalias current_proc, 78
  numalias current_env, 79
  numalias in_ex_test, 80

  ;; Syntax keyword symbol
  numalias sym_begin, 81
  numalias sym_cond, 82
  numalias sym_lambda, 83
  numalias sym_define, 84
  numalias sym_let, 85
  numalias sym_if, 86
  numalias sym_and, 87
  numalias sym_or, 88
  numalias sym_set, 89
  numalias sym_letrec, 90
  numalias sym_letstar, 91
  numalias sym_time, 92
  numalias sym_else, 93

  ;; Error messages
  stralias str_too_few_arguments, "Too-few-arguments"
  stralias str_too_many_arguments, "Too-many-arguments"
  stralias str_invalid_syntax, "Invalid-syntax"
  stralias str_stack_overflow, "Stack-overflow"

  ; Variables for the game
  numalias save_flag, 0
  numalias adv_tmp, 1
  numalias adv_tmp1, 2
  numalias adv_tmp2, 3
  numalias adv_tmp3, 4
  numalias adv_clear, 5
  numalias adv_additional, 6
  numalias adv_bgm, 7
  numalias adv_char, 8
  numalias adv_noroi, 9
  numalias adv_noroi_frame, 10
  numalias adv_noroi_my, 11
  numalias adv_noroi_mx, 12
  numalias adv_talkmode, 13
  numalias adv_noroi_kill, 14
  numalias adv_noroi_off, 15
  numalias adv_miss, 16
  numalias adv_same_level, 17
  numalias adv_hp, 18
  numalias adv_ehp, 19
  numalias adv_maxhp, 20
  numalias adv_sx, 21
  numalias adv_sy, 22
  numalias adv_sr, 23
  numalias adv_ix, 24
  numalias adv_id, 25
  numalias adv_ball_x, 26
  numalias adv_ball_y, 27
  numalias adv_ball_vx, 28
  numalias adv_vol, 29
  numalias adv_rmode, 30
  numalias adv_num_loss, 31
  numalias adv_error, 32

  ; Aliases for string variables
  numalias sarg0, 10
  numalias sarg1, 11
  numalias sarg2, 12
  numalias sarg3, 13
  numalias stmp, 14
  numalias stmp1, 15
  numalias stmp2, 16
  numalias stmp3, 17
  numalias sret, 18
  numalias sTAB, 20
  numalias sCR, 21
  numalias sLF, 22
  numalias problem_label, 23
  numalias tab_label, 24
  numalias ret_label, 25
  numalias suc_label, 26

  numalias sadv_label, 50
  numalias sadv_vol, 51

  ; Paths for image files
  stralias ari_n, ":l;img/arisa-01.bmp"
  stralias ari_tun, ":l;img/arisa-02.bmp"
  stralias ari_qes, ":l;img/arisa-03.bmp"
  stralias ari_exc, ":l;img/arisa-04.bmp"
  stralias ari_hrt, ":l;img/arisa-05.bmp"
  stralias ari_dere, ":l;img/arisa-06.bmp"
  stralias ari_die, ":l;img/arisa-07.bmp"
  stralias ari_ase, ":l;img/arisa-08.bmp"
  stralias ari_muka, ":l;img/arisa-09.bmp"
  stralias ari_do, ":l;img/arisa-0404.bmp"
  stralias suzu_n, ":l;img/suzuka-01.bmp"
  stralias suzu_nc, ":l;img/suzuka-02.bmp"
  stralias suzu_qes, ":l;img/suzuka-03.bmp"
  stralias suzu_exc, ":l;img/suzuka-04.bmp"
  stralias suzu_excc, ":l;img/suzuka-05.bmp"
  stralias suzu_hrt, ":l;img/suzuka-06.bmp"
  stralias suzu_dere, ":l;img/suzuka-07.bmp"
  stralias suzu_ase, ":l;img/suzuka-08.bmp"
  stralias suzu_T_T, ":l;img/suzuka-09.bmp"
  stralias suzu_dotc, ":l;img/suzuka-10.bmp"
  stralias suzu_dot, ":l;img/suzuka-11.bmp"
  stralias suzur_n, ":l;img/suzuka-01r.bmp"
  stralias suzur_nc, ":l;img/suzuka-02r.bmp"
  stralias suzur_qes, ":l;img/suzuka-03r.bmp"
  stralias suzur_exc, ":l;img/suzuka-04r.bmp"
  stralias suzur_excc, ":l;img/suzuka-05r.bmp"
  stralias suzur_hrt, ":l;img/suzuka-06r.bmp"
  stralias suzur_dere, ":l;img/suzuka-07r.bmp"
  stralias suzur_ase, ":l;img/suzuka-08r.bmp"
  stralias suzur_T_T, ":l;img/suzuka-09r.bmp"
  stralias suzur_dotc, ":l;img/suzuka-10r.bmp"
  stralias suzur_dot, ":l;img/suzuka-11r.bmp"

  ; Paths for sound files
  stralias ms_ex, "bgm/ex.mp3"
  stralias ms_narumi, "bgm/narumi.mp3"
  stralias ms_kyoto, "bgm/kyoto.mp3"
  stralias ms_setsume, "bgm/setsume.mp3"
  stralias ms_after, "bgm/after.mp3"
  stralias ms_jiku, "bgm/jiku.mp3"
  stralias ms_battle, "bgm/battle.mp3"
  stralias ms_battle2, "bgm/battle2.mp3"
  stralias ms_battlen, "bgm/battlen.mp3"
  stralias ms_nano, "bgm/nano.mp3"
  stralias ms_epilogue1, "bgm/epilogue1.mp3"
  stralias ms_epilogue2, "bgm/epilogue2.mp3"
  stralias ms_ending, "bgm/ending.mp3"
  stralias ms_ab2, "bgm/ab2.mp3"
  stralias ms_yakyu, "bgm/yakyu.mp3"
  stralias ms_omake, "bgm/omake.mp3"
  stralias ms_title, "bgm/title.mp3"

  ; SUBR
  numalias lf_car, 0
  numalias lf_cdr, 1
  numalias lf_cons, 2
  numalias lf_eq, 3
  numalias lf_atom, 4
  numalias lf_add, 5
  numalias lf_sub, 6
  numalias lf_mul, 7
  numalias lf_div, 8
  numalias lf_mod, 9
  numalias lf_gt, 10
  numalias lf_ge, 11
  numalias lf_ls, 12
  numalias lf_le, 13
  numalias lf_set_car, 14
  numalias lf_set_cdr, 15
  numalias lf_eval, 16
  numalias lf_apply, 17
  numalias lf_booleanp, 18
  numalias lf_pairp, 19
  numalias lf_symbolp, 20
  numalias lf_numberp, 21
  numalias lf_procedurep, 22
  numalias lf_null, 23
  numalias lf_read, 24
  numalias lf_write, 25
  numalias lf_error, 26

  defaultspeed 50,15,5
  caption "Magical Language Lyrical Lisp"
  versionstr "Magical Language Lyrical Lisp", "Open Source"
  resetmenu
  insertmenu "終了", END
  insertmenu "バージョン情報", VERSION
  insertmenu "選択肢まで進む", SKIP
  insertmenu "文字速度", SUB
  insertmenu "低速", TEXTSLOW, 1
  insertmenu "普通", TEXTMIDDLE, 1
  insertmenu "高速", TEXTFAST, 1
  insertmenu "フォント", FONT
  insertmenu "画面", SUB
  insertmenu "フルスクリーン", FULL, 1
  insertmenu "ウインドウ", WINDOW, 1

  ; Define subroutines for the game
  defsub r_in
  defsub r_out
  defsub l_in
  defsub l_out
  defsub l_rout
  defsub r_show
  defsub l_show
  defsub c_show
  defsub r_load
  defsub l_load
  defsub c_load
  defsub talk_mode
  defsub speak_mode
  defsub show_dgm
  defsub load_dgm
  defsub wait_dgm

  game


;;;;;;;;;;
;;;*push(val)
;;; modifies: %sp
;;;;;;;;;;
*push
  if %sp >= STACK_LIMIT mesbox "スタックオーバフロー", "Error" : end
  mov %%sp, %arg0
  inc %sp
  return


;;;;;;;;;;
;;;*pop()
;;; modifies: %ret, %sp
;;;;;;;;;;
*pop
  if %sp <= STACK mesbox "Popできません", "Error" : end
  dec %sp
  mov %ret, %%sp
  return


;;;;;;;;;;
;;;*spush(val)
;;; modifies: %ssp
;;;;;;;;;;
*spush
  if %ssp >= STACK_LIMIT mesbox "スタックオーバフロー", "Error" : end
  mov $%ssp, $sarg0
  inc %ssp
  return


;;;;;;;;;;
;;;*spop()
;;; modifies: $sret, %ssp
;;;;;;;;;;
*spop
  if %ssp <= SSTACK mesbox "Popできません" "Error" : end
  dec %ssp
  mov $sret, $%ssp
  return


;;;;;;;;;;
;;;*get_gc(obj)
;;; modifies: %ret
;;;;;;;;;;
*get_gc
  mov %ret, %%arg0 mod 2
  return


;;;;;;;;;;
;;;*set_gc(obj, flag)
;;; modifies: %tmp
;;;;;;;;;;
*set_gc
  mov %tmp, %%arg0
  div %tmp, 2
  mul %tmp, 2
  mov %%arg0, %tmp + %arg1
  return


;;;;;;;;;;
;;;*get_tag(obj)
;;; modifies: %tmp, %ret
;;;;;;;;;;
*get_tag
  mov %tmp, %%arg0
  mod %tmp, 64
  mov %ret, %tmp
  div %ret, 2
  return


;;;;;;;;;;
;;;*set_tag(obj, tag)
;;; modifies: %tmp, %tmp1, %tmp2, %tmp3
;;;;;;;;;;
*set_tag
  mov %tmp, %%arg0
  mov %tmp1, %tmp
  div %tmp1, 64
  mul %tmp1, 64  ; DATA
  mov %tmp2, %tmp mod 2  ; GC
  mov %tmp3, %arg1 * 2  ; TAG
  mov %%arg0, %tmp1 + %tmp2 + %tmp3
  return


;;;;;;;;;;
;;;*get_data(obj)
;;; modifies: %ret
;;;;;;;;;;
*get_data
  mov %ret, %%arg0
  div %ret, 64
  return

;;;;;;;;;;
;;;*get_num_data(num)
;;; modifies: %ret
;;;;;;;;;;
*get_num_data
  gosub *get_data
  if %ret <= MAX_NUMBER return
  mul %ret, 64
  add %ret, MIN_INT32
  div %ret, 64
  return


;;;;;;;;;;
;;;*set_data(obj, data)
;;; modifies: %tmp, %tmp1, %tmp2
;;;;;;;;;;
*set_data
  mov %tmp, %%arg0
  mov %tmp1, %tmp mod 64
  mov %tmp2, %arg1 * 64
  mov %%arg0, %tmp1 + %tmp2
  return


;;;;;;;;;;
;;;*car(obj)
;;; modifies: %ret
;;;  raw_car is used for extracting a content of symbol (maybe "nil").
;;;;;;;;;;
*car
  if %arg0 == %nil mov %ret, %nil : return
*raw_car
  gosub *get_data
  mov %ret, %ret mod 8192  ; 2^13
  return


;;;;;;;;;;
;;;*cdr(obj)
;;; modifies: %ret
;;;  raw_cdr is used for extracting a content of symbol (maybe "nil").
;;;;;;;;;;
*cdr
  if %arg0 == %nil mov %ret, %nil : return
*raw_cdr
  gosub *get_data
  div %ret, 8192  ; 2^13
  return


;;;;;;;;;;
;;;*set_car(obj0, obj1)
;;;  You should check the type of argument before calling this subroutine.
;;;  This subroutine modifies some variables but the value of %arg0 is kept.
;;;;;;;;;;
*set_car
  gosub *push             ; S(obj0)
  mov %tmp, %arg0
  mov %arg0, %arg1
  gosub *push             ; S(obj1, obj0)
  mov %arg0, %tmp
  gosub *get_data
  mov %tmp1, %ret
  div %tmp1, 8192
  mul %tmp1, 8192         ; %tmp1 = cdr
  gosub *pop              ; obj1 < S(obj0)
  add %tmp1, %ret         ; car + cdr (data)
  gosub *pop              ; obj0 < S()
  mov %arg0, %ret
  mov %arg1, %tmp1        ; car + cdr (data)
  gosub *set_data
  return


;;;;;;;;;;
;;;*set_cdr(obj0, obj1)
;;;  See *set_car.
;;;;;;;;;;
*set_cdr
  gosub *push               ; S(obj0)
  mov %tmp, %arg0
  mov %arg0, %arg1
  gosub *push               ; S(obj1, obj0)
  mov %arg0, %tmp
  gosub *get_data
  mov %tmp1, %ret mod 8192  ; %tmp1 = car
  gosub *pop                ; obj1 < S(obj0)
  mul %ret, 8192            ; %ret = cdr
  mov %tmp1, %tmp1 + %ret   ; %tmp1 = car + cdr (data)
  gosub *pop                ; obj0 < S()
  mov %arg0, %ret
  mov %arg1, %tmp1          ; car + cdr (data)
  gosub *set_data
  return


;;;;;;;;;;
;;;*mem_init()
;;;;;;;;;;
*mem_init
  ; Read special characters
  readfile $stmp, "same.jim"
  mid $sTAB, $stmp, 0, 1
  mid $sCR, $stmp, 1, 1
  mid $sLF, $stmp, 2, 1

  mov %gc_run, 0
  mov %gc_mark_color, 1
  mov %eval_limit, DEFAULT_EVAL_LIMIT
  mov %symbol_offset, 0
  mov %symbol_used, SYMBOL_SET
  mov %sp, STACK
  mov %ssp, SSTACK
  mov %free_lst, HEAP
  for %i=HEAP to HEAP_LAST  ; Create the free-list
    mov %arg0, %i
    mov %arg1, TAG_FREE
    gosub *set_tag
    mov %arg0, %i
    mov %arg1, %i + 1
    gosub *set_data
  next
  mov %arg0, 0
  gosub *create_bool
  mov %sharp_f, %ret
  mov %arg0, 1
  gosub *create_bool
  mov %sharp_t, %ret
  mov %symbol_lst, HEAP_LIMIT
  mov $sarg0, "nil"
  gosub *create_symbol
  mov %nil, %ret
  mov $sarg0, "quote"
  gosub *create_symbol
  mov %quote, %ret
  gosub *set_global_env
  mov %current_proc, %nil
  mov %current_env, %global_env
  return


;;;;;;;;;;
;;;*next_cell()
;;;;;;;;;;
*next_cell
  ; If there is no cell, then do GC.
  if %free_lst == HEAP_LIMIT gosub *gc
  ; If there is no cell after GC, then quit.
  if %free_lst == HEAP_LIMIT mesbox "メモリ不足", "Error" : end
  mov %arg0, %free_lst  ; %arg0 = current cell
  gosub *get_data       ; %ret = next cell
  mov %free_lst, %ret
  mov %arg1, 1 - %gc_mark_color
  gosub *set_gc         ; set_gc(current cell, unmarked color)
  mov %ret, %arg0
  return


;;;;;;;;;;
;;;*reuse_cell(obj, i)
;;;;;;;;;;
*reuse_cell
  gosub *set_data
  mov %arg1, TAG_FREE
  gosub *set_tag
  return


;;;;;;;;;;
;;;*gc()
;;;  This subroutine does not keep %ret because GC occurs in consing.
;;;  This subroutine does not keep %i because GC does not occurs in for-loop.
;;;;;;;;;;
*gc
  inc %gc_run
  gosub *push_registers
  mov %gc_count, 0
  textclear
if %gc_silent >= 1 goto *gc_sl1
  !s0ＧＣｉｎｇ・・・!sd
*gc_sl1
  gosub *gc_mark
  gosub *gc_sweep
if %gc_silent >= 1 goto *gc_sl2
  !s0Ｕｓｅｄ：%gc_count!sd
  mov %gc_count, HEAP_LIMIT - %gc_count
  mov %gc_count, %gc_count - HEAP
  !s0Ａｖａｉｌａｂｌｅ：%gc_count!sd
*gc_sl2
  gosub *pop_registers
  mov %gc_mark_color, 1 - %gc_mark_color  ; Flip the mark color.
  return


;;;;;;;;;;
;;;*gc_mark_lobject(obj)
;;;;;;;;;;
*gc_mark_lobject
  gosub *get_gc
  if %ret == %gc_mark_color return  ; Already marked
  mov %arg1, %gc_mark_color
  gosub *set_gc                     ; Mark the object
  inc %gc_count
  gosub *get_tag
  if %ret == TAG_CONS goto *gc_mark_lobject_cons
  if %ret == TAG_EXPR goto *gc_mark_lobject_cons
  if %ret == TAG_ERROR goto *gc_mark_lobject_cons
  if %ret == TAG_VAR goto *gc_mark_lobject_var
  if %ret == TAG_GVAR goto *gc_mark_lobject_cons
  return
*gc_mark_lobject_cons
  gosub *push     ; S(obj)
  gosub *car      ; CAR(obj)
  mov %arg0, %ret
  gosub *gc_mark_lobject
  gosub *pop      ; obj < S()
  mov %arg0, %ret
  gosub *cdr      ; CDR(obj)
  mov %arg0, %ret
  goto *gc_mark_lobject
*gc_mark_lobject_var
  gosub *cdr      ; CDR(obj)
  mov %arg0, %ret
  goto *gc_mark_lobject


;;;;;;;;;;
;;;*gc_mark_syntax_keyword()
;;;;;;;;;;
*gc_mark_syntax_keyword
  mov %arg0, %quote
  gosub *gc_mark_lobject
  mov %arg0, %sym_begin
  gosub *gc_mark_lobject
  mov %arg0, %sym_cond
  gosub *gc_mark_lobject
  mov %arg0, %sym_lambda
  gosub *gc_mark_lobject
  mov %arg0, %sym_define
  gosub *gc_mark_lobject
  mov %arg0, %sym_let
  gosub *gc_mark_lobject
  mov %arg0, %sym_if
  gosub *gc_mark_lobject
  mov %arg0, %sym_and
  gosub *gc_mark_lobject
  mov %arg0, %sym_or
  gosub *gc_mark_lobject
  mov %arg0, %sym_set
  gosub *gc_mark_lobject
  mov %arg0, %sym_letrec
  gosub *gc_mark_lobject
  mov %arg0, %sym_letstar
  gosub *gc_mark_lobject
  mov %arg0, %sym_time
  gosub *gc_mark_lobject
  mov %arg0, %sym_else
  gosub *gc_mark_lobject
  return


;;;;;;;;;;
;;;*gc_mark()
;;;;;;;;;;
*gc_mark
  mov %arg0, %global_env
  gosub *gc_mark_lobject
  gosub *gc_mark_syntax_keyword
  if %sp == STACK return  ; Stack is empty.
  for %i = STACK to %sp-1
    ; Stack may contain non-pointer values.
    ; Do conservative GC.
    if %%i < HEAP goto *gc_mark_l1
    if %%i > HEAP_LAST goto *gc_mark_l1
    mov %arg0, %%i
    gosub *gc_mark_lobject
  *gc_mark_l1
  next
  return


;;;;;;;;;;
;;;*gc_sweep()
;;;;;;;;;;
*gc_sweep
  mov %free_lst, HEAP_LIMIT
  mov %symbol_lst, HEAP_LIMIT
  for %i=HEAP to HEAP_LAST  ; Find the first unused cell.
    mov %arg0, %i
    gosub *get_gc
    if %ret != %gc_mark_color mov %free_lst, %i : break
    gosub *get_tag
    if %ret != TAG_SYMBOL goto *gc_sweep_next0
    mov %arg1, %symbol_lst
    gosub *set_cdr
    mov %symbol_lst, %i
  *gc_sweep_next0
  next
  if %free_lst == HEAP_LIMIT return  ; There is no unused cell.
  mov %gc_tmp, %free_lst  ; Keep the first unusd cell.
  for %i=%i+1 to HEAP_LAST
    mov %arg0, %i
    gosub *get_gc
    if %ret == %gc_mark_color goto *gc_sweep_marked
    ; Append the new unused cell to the free-list if GC-bit is unmarked.
    mov %arg0, %gc_tmp
    mov %arg1, %i
    gosub *reuse_cell
    mov %gc_tmp, %i
    goto *gc_sweep_next1
  *gc_sweep_marked
    mov %arg0, %i
    gosub *get_tag
    if %ret != TAG_SYMBOL goto *gc_sweep_next1
    mov %arg1, %symbol_lst
    gosub *set_cdr
    mov %symbol_lst, %i
  *gc_sweep_next1
  next
  mov %arg0, %gc_tmp
  mov %arg1, HEAP_LIMIT  ; The end of the free-list.
  gosub *reuse_cell
  return


*push_registers
  gosub *push       ; S(arg0)
  mov %arg0, %arg1
  gosub *push       ; S(arg1, arg0)
  mov %arg0, %arg2
  gosub *push       ; S(arg2, arg1, arg0)
  mov %arg0, %arg3
  gosub *push       ; S(arg3, arg2, arg1, arg0)
  mov %arg0, %tmp
  gosub *push       ; S(tmp, arg3, arg2, arg1, arg0)
  mov %arg0, %tmp1
  gosub *push       ; S(tmp1, tmp, arg3, arg2, arg1, arg0)
  mov %arg0, %tmp2
  gosub *push       ; S(tmp2, tmp1, tmp, arg3, arg2, arg1, arg0)
  mov %arg0, %tmp3
  gosub *push       ; S(tmp3, tmp2, tmp1, tmp, arg3, arg2, arg1, arg0)
  return


*pop_registers
  gosub *pop        ; tmp3 < S(tmp2, tmp1, tmp, arg3, arg2, arg1, arg0)
  mov %tmp3, %ret
  gosub *pop        ; tmp2 < S(tmp1, tmp, arg3, arg2, arg1, arg0)
  mov %tmp2, %ret
  gosub *pop        ; tmp1 < S(tmp, arg3, arg2, arg1, arg0)
  mov %tmp1, %ret
  gosub *pop        ; tmp < S(arg3, arg2, arg1, arg0)
  mov %tmp, %ret
  gosub *pop        ; arg3 < S(arg2, arg1, arg0)
  mov %arg3, %ret
  gosub *pop        ; arg2 < S(arg1, arg0)
  mov %arg2, %ret
  gosub *pop        ; arg1 < S(arg0)
  mov %arg1, %ret
  gosub *pop        ; arg0 < S()
  mov %arg0, %ret
  return


;;;;;;;;;;
;;;*symbol_gc()
;;;  This subroutine does not keep %ret.
;;;  This subroutine does not keep %i.
;;;;;;;;;;
*symbol_gc
  gosub *push_registers
  mov %gc_count, 0
  textclear
if %gc_silent >= 1 goto *symbol_gc_sl1
  Ｓｙｍｂｏｌ　ＧＣｉｎｇ・・・
*symbol_gc_sl1
  mov %tmp, SYMBOL_SET_HALF_SIZE
  add %symbol_offset, %tmp
  mul %tmp, 2
  mov %symbol_offset, %symbol_offset mod %tmp
  mov %symbol_used, SYMBOL_SET + %symbol_offset
  mov %i, %symbol_lst
*symbol_gc_l1
  if %i == HEAP_LIMIT goto *symbol_gc_l2
  mov %arg0, %i
  gosub *raw_car
  mov $%symbol_used, $%ret
  mov %arg0, %i
  mov %arg1, %symbol_used
  gosub *set_car
  inc %symbol_used
  mov %tmp, %symbol_used - SYMBOL_SET
  sub %tmp, %symbol_offset
  if %tmp >= SYMBOL_SET_HALF_SIZE mesbox "メモリ不足", "Error" : end
  mov %arg0, %i
  gosub *raw_cdr
  mov %i, %ret
  inc %gc_count
  goto *symbol_gc_l1
*symbol_gc_l2
if %gc_silent >= 1 goto *symbol_gc_sl2
  mov %tmp, SYMBOL_SET_HALF_SIZE
  Ｕｓｅｄ：%gc_count
  mov %gc_count, %tmp - %gc_count
  Ａｖａｉｌａｂｌｅ：%gc_count
*symbol_gc_sl2
  gosub *pop_registers
  return


;;;;;;;;;;
;;;*create_cons()
;;;;;;;;;;
*create_cons
  gosub *next_cell
  mov %arg0, %ret
  mov %arg1, TAG_CONS
  gosub *set_tag
  mov %ret, %arg0
  return


;;;;;;;;;;
;;;*create_num(n)
;;;;;;;;;;
*create_num
  if %arg0 < MIN_NUMBER mov %arg0, %arg0 + MIN_INT32
  if %arg0 > MAX_NUMBER mov %arg0, %arg0 mod UNSIGNED_MAX_PLUS1
  if %arg0 < 0 mov %arg0, %arg0 + UNSIGNED_MAX_PLUS1
  gosub *push       ; S(n)
  gosub *next_cell
  mov %arg0, %ret   ; new cell
  mov %arg1, TAG_NUM
  gosub *set_tag
  gosub *pop        ; n < S()
  mov %arg1, %ret
  gosub *set_data
  mov %ret, %arg0
  return


;;;;;;;;;;
;;;*create_symbol(str)
;;;;;;;;;;
*create_symbol
  mov %i, %symbol_lst
*create_symbol_l1
  if %i == HEAP_LIMIT goto *create_symbol_l2
  mov %arg0, %i
  gosub *raw_car
  if $sarg0 == $%ret mov %ret, %i : return
  mov %arg0, %i
  gosub *raw_cdr
  mov %i, %ret
  goto *create_symbol_l1
*create_symbol_l2
  mov $%symbol_used, $sarg0
  gosub *next_cell
  mov %arg0, %ret
  gosub *push
  mov %arg1, TAG_SYMBOL
  gosub *set_tag
  mov %arg1, %symbol_used
  gosub *set_car
  mov %tmp, %sp - 1
  mov %arg0, %%tmp
  mov %arg1, %symbol_lst
  gosub *set_cdr
  gosub *pop
  inc %symbol_used
  mov %symbol_lst, %ret
  mov %tmp, %symbol_used - SYMBOL_SET
  sub %tmp, %symbol_offset
  if %tmp >= SYMBOL_SET_HALF_SIZE  gosub *gc : gosub *symbol_gc
  return


;;;;;;;;;;
;;;*create_subr(n)
;;;;;;;;;;
*create_subr
  gosub *push       ; S(n)
  gosub *next_cell
  mov %arg0, %ret   ; new cell
  mov %arg1, TAG_SUBR
  gosub *set_tag
  gosub *pop        ; n < S()
  mov %arg1, %ret
  gosub *set_data
  mov %ret, %arg0
  return


;;;;;;;;;;
;;;*create_expr(form, arg, env)
;;;;;;;;;;
*create_expr
  gosub *push        ; S(form)
  mov %arg0, %arg1
  gosub *push        ; S(arg, form)
  mov %arg0, %arg2
  gosub *push        ; S(env, arg, form)
  gosub *create_cons
  mov %arg0, %ret    ; %arg0 = new cons
  mov %arg1, TAG_EXPR
  gosub *set_tag
  gosub *pop         ; env < S(arg, form)
  mov %arg1, %ret    ; %arg1 = env
  gosub *push        ; S(new cons, arg, form)
  gosub *set_car     ; new cons = (env . ?)
  gosub *create_cons
  mov %arg0, %ret    ; new cons2
  gosub *pop         ; new cons < S(arg, form)
  mov %tmp, %ret
  gosub *push        ; S(new cons2, arg, form)
  mov %arg1, %arg0
  mov %arg0, %tmp
  gosub *push        ; S(new cons, new cons2, arg, form)
  gosub *set_cdr     ; new cons = (env . new cons2)
  gosub *pop         ; new cons < S(new cons2, arg, form)
  mov %arg0, %ret    ; %arg0 = new cons
  gosub *pop         ; new cons2 < S(arg, form)
  mov %tmp1, %ret
  gosub *pop         ; arg < S(form)
  mov %tmp2, %ret
  gosub *pop         ; form < S()
  mov %tmp3, %ret
  gosub *push        ; S(new cons)
  mov %arg0, %tmp3
  gosub *push        ; S(form, new cons)
  mov %arg0, %tmp1   ; %arg0 = new cons2
  gosub *push        ; S(new cons2, form, new cons)
  mov %arg1, %tmp2   ; %arg1 = arg
  gosub *set_car     ; new cons = (env arg . ?)
  gosub *pop         ; new cons2 < S(form, new cons)
  mov %arg0, %ret
  gosub *pop         ; form < S(new cons)
  mov %arg1, %ret
  gosub *set_cdr     ; new cons = (env arg . form)
  gosub *pop         ; new cons < S()
  return             ; %ret = new cons


;;;;;;;;;;
;;;*create_error(str)
;;;;;;;;;;
*create_error
  gosub *create_symbol
  mov %arg0, %ret
  gosub *push       ; S(symbol)
  gosub *next_cell
  mov %arg0, %ret
  mov %arg1, TAG_ERROR
  gosub *set_tag
  gosub *pop        ; symbol < S()
  mov %arg1, %ret
  gosub *set_car
  mov %arg0, %ret
  gosub *push       ; S(error)
  if %current_proc == %nil goto *create_error_toplevel
  mov %arg0, %current_proc
  mov %arg1, %current_env
  gosub *find_val
  if %ret == %nil mov %arg1, %current_proc : goto *create_error_l1
  mov %arg0, %ret
  gosub *car
  mov %arg1, %ret
  goto *create_error_l1
*create_error_toplevel
  mov $sarg0, "top-level"
  gosub *create_symbol
  mov %arg1, %ret
*create_error_l1
  gosub *pop        ; error < S()
  mov %arg0, %ret
  gosub *set_cdr
  return

;;;;;;;;;;
;;;*create_var(sym, index, frame)
;;;;;;;;;;
*create_var
  gosub *push        ; S(sym)
  mov %arg0, %arg1
  if %arg0 > 64 goto *create_var_error1
  gosub *push        ; S(index, sym)
  mov %arg0, %arg2
  if %arg0 > 64 goto *create_var_error2
  gosub *push        ; S(frame, index, sym)
  gosub *create_cons
  mov %arg0, %ret    ; %arg0 = (? . ?)
  mov %arg1, TAG_VAR
  gosub *set_tag
  gosub *pop         ; frame < S(index, sym)
  mov %arg1, %ret    ; %arg1 = frame
  mul %arg1, 64      ; %arg1 = frame << 6
  gosub *pop         ; index < S(sym)
  add %arg1, %ret    ; %arg1 = (frame << 6) + index
  gosub *set_car     ; %arg0 = ((frame << 6) + index . ?)
  gosub *pop         ; sym < S()
  mov %arg1, %ret    ; %arg1 = sym
  gosub *set_cdr     ; %arg0 = ((frame << 6) + index . sym)
  mov %ret, %arg0
  return
*create_var_error2
  gosub *pop
*create_var_error1
  gosub *pop
  mov $sarg0, "Too-large-variable-index"
  gosub *create_error
  return

;;;;;;;;;;
;;;*create_gvar(sym, val)
;;;;;;;;;;
*create_gvar
  gosub *push         ; S(sym)
  mov %arg0, %arg1    ; %arg0 = val
  gosub *push         ; S(val, sym)
  gosub *create_cons
  mov %arg0, %ret
  mov %arg1, TAG_GVAR
  gosub *set_tag      ; %arg0 = gvar
  gosub *pop          ; val < S(sym)
  mov %arg1, %ret     ; %arg1 = val
  gosub *set_cdr      ; gvar = (? . val)
  gosub *pop          ; sym < S()
  mov %arg1, %ret     ; %arg1 = sym
  gosub *set_car      ; gvar = (sym . val)
  mov %ret, %arg0     ; %ret = gvar
  return

;;;;;;;;;;
;;;*create_bool(num)
;;;  num = 0 : #f
;;;  num = 1 : #t
;;;;;;;;;;
*create_bool
  gosub *push         ; S(num)
  gosub *next_cell
  mov %arg0, %ret     ; %arg0 = object
  mov %arg1, TAG_BOOL
  gosub *set_tag      ; %arg0 = boolean
  gosub *pop          ; num < S()
  mov %arg1, %ret     ; %arg1 = num
  gosub *set_data
  mov %ret, %arg0     ; %ret = boolean
  return

;;;;;;;;;;
;;;*popn_and_error(error, n)
;;;;;;;;;;
*popn_and_error
  if %arg1 > 0 gosub *pop : dec %arg1 : goto *popn_and_error
  mov %ret, %arg0
  return
*pop1_and_error
  mov %arg1, 1
  goto *popn_and_error
*pop2_and_error
  mov %arg1, 2
  goto *popn_and_error
*pop3_and_error
  mov %arg1, 3
  goto *popn_and_error
*popn_and_invstx
  mov %arg0, %arg1
  gosub *push         ; S(n)
  gosub *invalid_syntax
  gosub *pop          ; n < S()
  mov %arg1, %ret
  goto *popn_and_error
*pop2_and_invstx
  mov %arg1, 2
  goto *popn_and_invstx


;;;;;;;;;;
;;;*set_error_to_arg0(str)
;;;;;;;;;;
*set_error_to_arg0
  gosub *create_error
  mov %arg0, %ret
  return
*too_few_arg0
  mov $sarg0, str_too_few_arguments
  goto *set_error_to_arg0  ; tail call
*too_many_arg0
  mov $sarg0, str_too_many_arguments
  goto *set_error_to_arg0  ; tail call
*invalid_syntax
  mov $sarg0, str_invalid_syntax
  goto *set_error_to_arg0  ; tail call

;;;;;;;;;;
;;;*set_type_error_to_arg0(type_str, val)
;;;;;;;;;;
*set_type_error_to_arg0
  gosub *spush
  gosub *lobject_to_string
  mov $stmp, $sret
  gosub *spop
  mov $sarg0, $stmp + "は" + $sret + "ではありません"
  goto *set_error_to_arg0  ; tail call
*cons_required
  mov $sarg0, "コンス"
  goto *set_type_error_to_arg0
*number_required
  mov $sarg0, "数"
  goto *set_type_error_to_arg0
*list_required
  mov $sarg0, "リスト"
  goto *set_type_error_to_arg0


;;;;;;;;;;
;;;*next_token(str)
;;sret : Substring
;;ret  : The number of characters which were read
;;;;;;;;;;
*next_token
  mov %ret, 0
  mov $sret, ""
  mov %tmp1, 0
  len %tmp, $sarg0
  for %i=0 to %tmp-1
    mid $stmp, $sarg0, %i, 1
    if $stmp != " " && $stmp != "　" && $stmp != $sTAB goto *next_token_l1
    goto *next_token_l3
  *next_token_l1
    if $stmp != $sCR && $stmp != $sLF goto *next_token_l2
    goto *next_token_l3
  *next_token_l2
    mov %tmp1, 1
    break
  *next_token_l3
    mov %ret, %ret + 1
  next
  if $stmp == "("  mov $sret, "（" : mov %ret, %ret+1 : return
  if $stmp == ")"  mov $sret, "）" : mov %ret, %ret+1 : return
  if $stmp == "."  mov $sret, "．" : mov %ret, %ret+1 : return
  if $stmp == "'"  mov $sret, "’" : mov %ret, %ret+1 : return
  if %tmp1 == 0 return  ; Error
  for %i=%i to %tmp-1
    mid $stmp, $sarg0, %i, 1
    if $stmp == "(" break
    if $stmp == ")" break
    ;;if $stmp == "." break
    if $stmp == "'" break
    if $stmp == " " break
    if $stmp == "　" break
    if $stmp == $sTAB break
    if $stmp == $sCR break
    if $stmp == $sLF break
    if $stmp == "#" mov $stmp, "＃"
    if $stmp == "/" mov $stmp, "／"
    if $stmp == ">" mov $stmp, "＞"
    if $stmp == "<" mov $stmp, "＜"
    if $stmp == "=" mov $stmp, "＝"
    if $stmp == "!" mov $stmp, "！"
    if $stmp == "_" mov $stmp, "＿"
    mov $sret, $sret + $stmp
    mov %ret, %ret + 1
  next
  return


;;;;;;;;;;
;;;*skip_sarg0(str)
;;sarg0 : Substring
;;;;;;;;;;
*skip_sarg0
  gosub *push        ; %arg0
  mov %arg0, %tmp
  gosub *push        ; %tmp
  mov %arg0, %tmp1
  gosub *push        ; %tmp1
  gosub *next_token
  len %arg0, $sarg0
  mid $sarg0, $sarg0, %ret, %arg0-%ret
  gosub *pop         ; %tmp1
  mov %tmp1, %ret
  gosub *pop         ; %tmp
  mov %tmp, %ret
  gosub *pop         ; %arg0
  mov %arg0, %ret
  return


;;;;;;;;;;
;;;*is_number(str)
;;ret : number=0, otherwise=1
;;;;;;;;;;
*is_number
  gosub *push
  len %arg0, $sarg0
  mov %ret, 0
  mov %tmp, 0
  mid $stmp, $sarg0, 0, 1
  if $stmp != "-" goto *is_number_plus
  if %arg0 == 1 gosub *pop : mov %ret, 1 : return  ; Not number
  mov %tmp, 1
  *is_number_plus
  for %i=%tmp to %arg0-1
    mid $stmp, $sarg0, %i, 1
    if $stmp == "0" goto *is_number_l1
    if $stmp == "1" goto *is_number_l1
    if $stmp == "2" goto *is_number_l1
    if $stmp == "3" goto *is_number_l1
    if $stmp == "4" goto *is_number_l1
    if $stmp == "5" goto *is_number_l1
    if $stmp == "6" goto *is_number_l1
    if $stmp == "7" goto *is_number_l1
    if $stmp == "8" goto *is_number_l1
    if $stmp == "9" goto *is_number_l1
    gosub *pop : mov %arg0, %ret : mov %ret, 1 : break
*is_number_l1
  next
  if %ret == 0 goto *is_number_l2
  return  ; Not number
*is_number_l2  ; All characters are digits
  if %arg0 <= 8 goto *is_number_l3
  ; Greater than the 8-digit number
  gosub *pop
  mov %arg0, %ret
  mov $sarg0, "0"
  mov %ret, 0
  return
*is_number_l3
  atoi %arg0, $sarg0
  if %arg0 <= MAX_NUMBER goto *is_number_l4
  gosub *pop
  mov %arg0, %ret
  mov $sarg0, "0"
  mov %ret, 0
  return
*is_number_l4
  gosub *pop
  mov %arg0, %ret
  if %tmp == 1 mov %arg0, %arg0 * -1
  mov %ret, 0
  return


;;;;;;;;;;
;;;*translate_quote(str)
;;ret : Translated object
;;;;;;;;;;
*translate_quote
  gosub *create_cons
  mov %arg0, %ret
  gosub *push        ; S(new cons1)
  mov %arg1, %quote
  gosub *set_car     ; new cons1 = (quote ...)
  gosub *create_cons
  mov %tmp, %ret     ; %tmp = new cons2
  gosub *pop         ; new cons1 < S()
  mov %arg0, %ret
  gosub *push        ; S(new cons1)
  mov %tmp1, %arg0   ; %tmp1 = new cons1
  mov %arg0, %tmp
  gosub *push        ; S(new cons2, new cons1)
  mov %arg1, %arg0
  mov %arg0, %tmp1
  gosub *set_cdr     ; new cons1 = (quote . new cons2)
  gosub *input_to_lobject
  mov %arg1, %ret    ; new object
  gosub *pop         ; new cons2 < S(new cons1)
  mov %arg0, %ret
  gosub *push        ; S(new cons2, new cons1)
  gosub *set_car     ; new cons2 = (new object ...)
  gosub *pop         ; new cons2 < S(new cons1)
  mov %arg0, %ret
  mov %arg1, %nil
  gosub *set_cdr     ; new cons2 = (new objec . nil)
  gosub *pop
  return             ; %ret = new cons1

;;;;;;;;;;
;;;*check_lr_parenthesis(str)
;;ret : (#L==#R)=0 (#L>#R)=1 (#L<#R)=2
;;Expect HANKAKU character
;;;;;;;;;;
*check_lr_parenthesis
  len %tmp, $sarg0
  mov %ret, 0
  for %i=0 to %tmp-1
    mid $stmp, $sarg0, %i, 1
    if $stmp == "(" mov %ret, %ret+1
    if $stmp == ")" mov %ret, %ret-1
  next
  if %ret > 0 mov %ret, 1
  if %ret < 0 mov %ret, 2
  return

;;;;;;;;;;
;;;*input_to_lobject(str)
;;ret : Translated object
;;;;;;;;;;
*input_to_lobject
  gosub *next_token
  len %tmp1, $sarg0
  mid $sarg0, $sarg0, %ret, %tmp1-%ret
  if $sret == "（" gosub *input_to_list : return
  if $sret == "’" gosub *translate_quote : return
  if $sret == "）" mov %ret, %nil : return
  gosub *spush        ; SS(rest_str)
  mov $sarg0, $sret
  gosub *is_number
  if %ret != 0 goto *input_to_lobject_not_number
  atoi %arg0, $sarg0
  gosub *create_num
  goto *input_to_lobject_finish
*input_to_lobject_not_number
  if $sarg0 == "＃t" mov %ret, %sharp_t : goto *input_to_lobject_finish
  if $sarg0 == "＃f" mov %ret, %sharp_f : goto *input_to_lobject_finish
  gosub *create_symbol
*input_to_lobject_finish  ; %ret = object
  gosub *spop         ; rest_str < SS()
  mov $sarg0, $sret
  return


;;;;;;;;;;
;;;*input_to_list(str)
;;ret : Translated Object
;;Be careful with the value of $sarg0
;;;;;;;;;;
*input_to_list
  gosub *create_cons
  mov %arg0, %ret      ; %arg0 = 'root' cell
  mov %tmp, %ret       ; %tmp = 'current' cell
  gosub *push          ; S(root)
*input_to_list_l1
  mov %arg0, %tmp
  gosub *push          ; S(current, root)
  gosub *next_token    ; $sarg0 = next token and discard %ret
  gosub *pop           ; current < S(root)
  mov %tmp, %ret       ; %tmp = current
  if $sret == "）" goto *input_to_list_l2
  if $sret == "．" goto *input_to_list_l3
  goto *input_to_list_l4

*input_to_list_l2  ; ')'
  gosub *skip_sarg0    ; Skip ')'
  mov %arg0, %tmp
  mov %arg1, %nil
  gosub *set_cdr       ; current = (? . nil)
  gosub *pop           ; root < S()
  mov %arg0, %ret
  gosub *cdr
  return               ; %ret = CDR(root)

*input_to_list_l3  ; '.'
  gosub *skip_sarg0    ; Skip '.'
  mov %arg0, %tmp
  gosub *push          ; S(current, root)
  gosub *input_to_lobject
  mov %arg1, %ret      ; %arg1 = object
  gosub *pop           ; current < S(root)
  mov %arg0, %ret
  gosub *set_cdr       ; current = (? . new object)
  gosub *skip_sarg0    ; Skip ')'
  gosub *pop           ; root < S()
  mov %arg0, %ret
  gosub *cdr
  return               ; %ret = CDR(root)

*input_to_list_l4  ; Otherwose
  mov %arg0, %tmp
  gosub *push        ; S(current, root)
  gosub *input_to_lobject
  mov %arg0, %ret    ; %arg0 = object
  gosub *push        ; S(object, current, root)
  gosub *create_cons
  mov %arg0, %ret    ; %arg0 = new cons
  gosub *pop         ; object < S(current, root)
  gosub *push        ; S(new cons, current, root)
  mov %arg1, %ret    ; %arg1 = object
  gosub *set_car     ; new cons = (new object . ?)
  gosub *pop         ; new cons < S(current, root)
  mov %arg1, %ret    ; %arg1 = new cons
  gosub *pop         ; current < s(root)
  mov %arg0, %ret    ; %arg0 = current
  mov %tmp1, %arg0   ; %tmp1 = current
  mov %arg0, %arg1
  gosub *push        ; S(new cons, root)
  mov %arg0, %tmp1   ; %arg0 = current
  gosub *set_cdr     ; current = (? . new cons)
  gosub *pop         ; new cons < S()
  mov %tmp, %ret     ; current = new cons
  goto *input_to_list_l1
  return


;;;;;;;;;;
;;;*cons_to_string(obj)
;;sret : Translated string
;;;;;;;;;;
*cons_to_string
  mov $stmp3, "（"
*cons_to_string_l1
  gosub *push                  ; obj
  gosub *car
  mov %arg0, %ret
  mov $sarg0, $stmp3
  gosub *spush
  gosub *lobject_to_string
  mov $stmp2, $sret            ; car
  gosub *spop
  mov $stmp3, $sret
  mov $stmp3, $stmp3 + $stmp2
  gosub *pop                   ; obj
  mov %arg0, %ret
  gosub *cdr
  mov %arg0, %ret
  gosub *get_tag
  if %arg0 == %nil goto *cons_to_string_l2
  if %ret == TAG_CONS goto *cons_to_string_l11
  mov $sarg0, $stmp3
  gosub *spush
  gosub *lobject_to_string
  mov $stmp2, $sret
  gosub *spop
  mov $stmp3, $sret
  mov $stmp3, $stmp3 + "　．" + $stmp2
  goto *cons_to_string_l2
*cons_to_string_l11
  mov $stmp3, $stmp3 + "　"  ; ZENKAKU space
  goto *cons_to_string_l1
*cons_to_string_l2
  mov $stmp3, $stmp3 + "）"
  mov $sarg0, $stmp3
  gosub *print_string
  return


;;;;;;;;;;
;;;*lobject_to_string(obj)
;;sret : Translated string
;;;;;;;;;;
*lobject_to_string
  gosub *get_tag
  if %ret == TAG_SUBR goto *lobject_to_string_proc
  if %ret == TAG_EXPR goto *lobject_to_string_expr
  if %ret == TAG_NUM  goto *lobject_to_string_num
  if %ret == TAG_BOOL  goto *lobject_to_string_bool
  if %ret == TAG_SYMBOL goto *lobject_to_string_sym
  if %ret == TAG_ERROR goto *lobject_to_string_err
  if %ret == TAG_VAR goto *lobject_to_string_var
  if %ret == TAG_GVAR goto *lobject_to_string_gvar
  if %ret == TAG_CONS gosub *cons_to_string : return
  return
*lobject_to_string_proc
  mov $sarg0, "＃＜ｐｒｏｃｅｄｕｒｅ＞"
  gosub *print_string
  return
*lobject_to_string_expr
  gosub *cdr
  mov %arg0, %ret
  mov $stmp3, ""  ; Dirty hack for removing the first left parenthesis!
  gosub *car
  if %ret == %nil goto *lobject_to_string_expr_thunk
  gosub *cons_to_string_l1
  mov $sarg0, "＃＜ｐｒｏｃｅｄｕｒｅ（lambda" + $sret + "＞"
  gosub *print_string
  return
*lobject_to_string_expr_thunk
  gosub *cons_to_string_l1
  mov $sarg0, "＃＜ｐｒｏｃｅｄｕｒｅ（lambda　" + $sret + "＞"
  gosub *print_string
  return
*lobject_to_string_num
  gosub *get_num_data
  itoa $sarg0, %ret
  gosub *print_string
  return
*lobject_to_string_bool
  if %arg0 == %sharp_t mov $sarg0, "＃t"
  if %arg0 == %sharp_f mov $sarg0, "＃f"
  gosub *print_string
  return
*lobject_to_string_sym
  gosub *raw_car
  mov $sarg0, $%ret
  gosub *print_string
  return
*lobject_to_string_err
  gosub *push         ; S(obj)
  gosub *raw_cdr      ; error location
  mov %arg0, %ret
  gosub *lobject_to_string
  mov $sarg0, $sret
  gosub *spush        ; location
  gosub *pop          ; obj < S()
  mov %arg0, %ret
  gosub *raw_car      ; error message (symbol)
  mov %arg0, %ret
  gosub *raw_car      ; error message (string)
  mov $sarg0, $%ret
  if $sarg0 == str_too_few_arguments goto *lobject_to_string_err_few
  if $sarg0 == str_too_many_arguments goto *lobject_to_string_err_many
  if $sarg0 == str_invalid_syntax goto *lobject_to_string_err_inv
  if $sarg0 == str_stack_overflow goto *lobject_to_string_err_stack
  gosub *print_string
  mov $stmp, $sret    ; message
  gosub *spop         ; location
  mov $sret, "エラー：" + $sret + "において、" + $stmp
  return
*lobject_to_string_err_few
  gosub *spop         ; location
  mov $sret, "エラー：" + $sret + "に与える引数が少なすぎます"
  return
*lobject_to_string_err_many
  gosub *spop         ; location
  mov $sret, "エラー：" + $sret + "に与える引数が多すぎます"
  return
*lobject_to_string_err_inv
  gosub *spop         ; location
  mov $sret, "エラー：" + $sret + "の使い方が間違っています"
  return
*lobject_to_string_err_stack
  gosub *spop         ; location
  mov $sret, "エラー：スタックオーバフロー"
  return
*lobject_to_string_var
  gosub *push         ; S(var)
  gosub *cdr          ; symbol
  mov %arg0, %ret
  gosub *lobject_to_string_sym
  mov $sret, $sret + "＜"
  gosub *pop          ; var < S()
  mov %arg0, %ret     ; %arg0 = var
  gosub *car          ; (frame << 6) + index
  mov %tmp, %ret / 64 ; %tmp = frame
  itoa2 $sarg0, %tmp
  mov $sret, $sret + $sarg0 + "，"
  mov %tmp, %ret mod 64  ; %tmp = index
  itoa2 $sarg0, %tmp
  mov $sret, $sret + $sarg0 + "＞"
  return
*lobject_to_string_gvar
  gosub *car          ; symbol
  mov %arg0, %ret
  goto *lobject_to_string_sym  ; tail call

;;;;;;;;;;
;;;*print_string(str)
;;sret : String
;;;;;;;;;;
*print_string
  mov $sret, $sarg0
  len %tmp, $sret
  if %tmp mod 2 == 1 mov $sret, $sret + " "
  return


;;;;;;;;;;
;;;*assoc(key, lst)
;;;;;;;;;;
*assoc
  if %arg1 == %nil mov %ret, %nil : return
  gosub *push       ; key
  mov %arg0, %arg1
  gosub *push       ; lst
  gosub *car
  mov %arg0, %ret
  gosub *car
  mov %tmp, %ret    ; CAR(CAR(lst))
  gosub *pop        ; lst
  mov %arg1, %ret
  gosub *pop        ; key
  mov %arg0, %ret
  if %arg0 == %tmp mov %arg0, %arg1 : gosub *car : return
  gosub *push       ; key
  mov %arg0, %arg1
  gosub *cdr
  mov %arg1, %ret   ; CDR(lst)
  gosub *pop        ; key
  mov %arg0, %ret
  goto *assoc       ; tail recursion


;;;;;;;;;;
;;;*rassoc(key, lst)
;;;;;;;;;;
*rassoc
  if %arg1 == %nil mov %ret, %nil : return
  gosub *push       ; key
  mov %arg0, %arg1
  gosub *push       ; lst
  gosub *car
  mov %arg0, %ret
  gosub *cdr
  mov %tmp, %ret    ; CDR(CAR(lst))
  gosub *pop        ; lst
  mov %arg1, %ret
  gosub *pop        ; key
  mov %arg0, %ret
  if %arg0 == %tmp mov %arg0, %arg1 : gosub *car : return
  gosub *push       ; key
  mov %arg0, %arg1
  gosub *cdr
  mov %arg1, %ret   ; CDR(lst)
  gosub *pop        ; key
  mov %arg0, %ret
  goto *rassoc      ; tail recursion


;;;;;;;;;;
;;;*find_var(var, env)
;;;;;;;;;;
*find_var
  if %arg1 == %nil mov %ret, %nil : return
  mov %tmp, %arg0   ; %tmp = var
  mov %arg0, %arg1  ; %arg0 = env
  gosub *push       ; S(env)
  mov %arg0, %tmp   ; %arg0 = var
  gosub *push       ; S(var, env)
  mov %arg0, %arg1  ; %arg0 = env
  gosub *car        ; CAR(env)
  mov %arg1, %ret   ; %arg1 = CAR(env)
  gosub *pop        ; var < S(env)
  mov %arg0, %ret   ; %arg0 = var
  gosub *push       ; S(var, env)
  gosub *assoc      ; assoc(var, CAR(env))
  if %ret != %nil sub %sp, 2 : return
  gosub *pop        ; var < S(env)
  mov %arg0, %ret   ; %arg0 = var
  gosub *pop        ; env < S()
  mov %tmp, %ret    ; %tmp = env
  gosub *push       ; S(var)
  mov %arg0, %tmp   ; %arg0 = env
  gosub *cdr        ; CDR(env)
  mov %arg1, %ret   ; %ret1 = CDR(env)
  gosub *pop        ; var < S()
  mov %arg0, %ret   ; %ret0 = var
  goto *find_var


;;;;;;;;;;
;;;*find_val(val, env)
;;;;;;;;;;
*find_val
  if %arg1 == %nil mov %ret, %nil : return
  mov %tmp, %arg0   ; %tmp = val
  mov %arg0, %arg1  ; %arg0 = env
  gosub *push       ; S(env)
  mov %arg0, %tmp   ; %arg0 = val
  gosub *push       ; S(val, env)
  mov %arg0, %arg1  ; %arg0 = env
  gosub *car        ; CAR(env)
  mov %arg1, %ret   ; %arg1 = CAR(env)
  gosub *pop        ; val < S(env)
  mov %arg0, %ret   ; %arg0 = val
  gosub *push       ; S(val, env)
  gosub *rassoc     ; rassoc(val, CAR(env))
  if %ret != %nil sub %sp, 2 : return
  gosub *pop        ; val < S(env)
  mov %arg0, %ret   ; %arg0 = val
  gosub *pop        ; env < S()
  mov %tmp, %ret    ; %tmp = env
  gosub *push       ; S(val)
  mov %arg0, %tmp   ; %arg0 = env
  gosub *cdr        ; CDR(env)
  mov %arg1, %ret   ; %ret1 = CDR(env)
  gosub *pop        ; var < S()
  mov %arg0, %ret   ; %ret0 = val
  goto *find_val


;;;;;;;;;;
;;;*find_local_var_cell(env, frame, index)
;;;;;;;;;;
*find_local_var_cell
  if %arg0 == %nil goto *find_local_var_error
  if %arg1 == 0 gosub *car : mov %arg0, %ret : goto *find_local_var_index
  gosub *cdr
  mov %arg0, %ret
  dec %arg1
  goto *find_local_var_cell
*find_local_var_index
  if %arg0 == %nil find_local_var_error
  if %arg2 == 0 mov %ret, %arg0 : return
  gosub *cdr
  mov %arg0, %ret
  dec %arg2
  goto *find_local_var_index
*find_local_var_error
  mov $sarg0, "Invalid-variable-index"
  goto *create_error

;;;;;;;;;;
;;;*find_local_var(env, frame, index)
;;;;;;;;;;
*find_local_var
  gosub *find_local_var_cell
  mov %arg0, %ret
  gosub *get_tag
  if %ret == TAG_CONS gosub *car : return
  mov %ret, %arg0
  return


;;;;;;;;;;
;;;*nconc(lst, obj)
;;;;;;;;;;
*nconc
  gosub *push      ; S(lst) = root
*nconc_l1
  mov %tmp, %arg0
  mov %arg0, %arg1
  gosub *push      ; S(obj)
  mov %arg0, %tmp
  gosub *push      ; S(lst, obj)
  gosub *cdr       ; CDR(lst)
  if %ret == %nil goto *nconc_l2
  mov %arg0, %ret  ; lst = CDR(lst)
  gosub *pop       ; lst < S(obj)
  gosub *pop       ; obj < S()
  mov %arg1, %ret
  goto *nconc_l1
*nconc_l2
  gosub *pop       ; lst < S(obj)
  mov %arg0, %ret
  gosub *pop       ; obj < S()
  mov %arg1, %ret
  gosub *set_cdr
  gosub *pop       ; root
  return


;;;;;;;;;;
;;;*eval(obj, env)
;;;;;;;;;;
*eval
  inc %eval_count
  if %eval_limit > 0 && %eval_count >= %eval_limit goto *eval_maybe_abort
  if %sp >= STACK_SAFE_LIMIT goto *eval_stack_overflow
  if %arg0 == %nil mov %ret, %arg0 : return
  gosub *get_tag
  if %ret == TAG_NUM mov %ret, %arg0 : return
  if %ret == TAG_ERROR mov %ret, %arg0 : return
  if %ret == TAG_BOOL mov %ret, %arg0 : return
  if %ret == TAG_SYMBOL goto *eval_symbol
  if %ret == TAG_VAR goto *eval_local_var
  if %ret == TAG_GVAR goto *eval_global_var
  goto *eval_compound  ; Assume obj is a cons
*eval_symbol
  gosub *member_syntax
  if %ret == %sharp_t goto *eval_unbound
  ;; When a symbol is evaluated, the symbol must be a syntax symbol.
  ;; Therefore, following code shouldn't be run.
  gosub *lobject_to_string
  mov $sarg0, "E " + $sret  ; Internal error
  return
*eval_unbound
  gosub *lobject_to_string
  mov $sarg0, $sret + "は未束縛です"
  goto *create_error; tail call
*eval_local_var
  gosub *car              ; (frame << 6) + index
  mov %arg0, %arg1        ; %arg0 = env
  mov %arg1, %ret / 64    ; %arg1 = frame
  mov %arg2, %ret mod 64  ; %arg2 = index
  goto *find_local_var
*eval_global_var
  gosub *cdr
  if %ret == UNBOUND goto *eval_global_var_unbound
  return
*eval_global_var_unbound  ; %arg0 = gvar
  gosub *car
  mov %arg0, %ret
  goto *eval_unbound  ; tail call
*eval_compound      ; %arg0 = obj, %arg1 = env
  mov %tmp, %arg0   ; %tmp = obj
  mov %arg0, %arg1  ; %arg1 = env
  gosub *push       ; S(env)
  mov %arg0, %tmp   ; %arg0 = obj
  gosub *car        ; CAR(obj)
  mov %tmp, %ret    ; %tmp = CAR(obj)
  gosub *cdr        ; CDR(obj)
  mov %arg0, %tmp   ; %arg0 = CAR(obj)
  mov %arg1, %ret   ; %arg1 = CDR(obj)
  gosub *pop        ; env < S()
  mov %arg2, %ret   ; %arg2 = env
  gosub *syntax_fn  ; $sret = syntax function, if %arg0 is syntax keyword
  if %ret == %sharp_f goto *eval_compound_not_syntax
  goto $sret  ; tail call
*eval_compound_not_syntax
  mov %tmp, %arg0   ; %tmp = CAR(obj)
  mov %arg0, %arg1  ; %arg0 = CDR(obj)
  gosub *push       ; S(CDR(obj)
  mov %arg0, %arg2  ; %arg0 = env
  gosub *push       ; S(env, CDR(obj)
  mov %arg0, %current_proc
  gosub *push       ; S(proc, env, CDR(obj)
  mov %arg0, %tmp   ; %arg0 = CAR(obj)
  mov %arg1, %arg2  ; %arg1 = env
  gosub *eval       ; Eval(CAR(obj, env)
  mov %arg0, %ret   ; %arg0 = fn
  gosub *pop        ; proc < S(env, CDR(obj)
  mov %current_proc, %ret
  gosub *pop        ; env < S(CDR(obj)
  mov %arg2, %ret   ; %arg2 = env
  mov %current_env, %ret
  gosub *pop        ; CDR(obj) < S()
  mov %arg1, %ret   ; %arg1 = CDR(obj)
  goto *apply       ; Apply(fn, CDR(obj), env)
*eval_maybe_abort
  gosub *confirm_abort
  if %eval_count == 0 goto *eval_resume
  mov $sarg0, "計算を中断しました"
  goto *create_error  ; taill call
*eval_resume
  計算を再開します
  goto *eval
*eval_stack_overflow
  mov $sarg0, str_stack_overflow
  goto *create_error  ; tail call


;;;;;;;;;;
;;;*apply(fn, arg, env)
;;;;;;;;;;
*apply
  gosub *get_tag
  if %ret == TAG_SUBR goto *apply_eval_arg
  if %ret == TAG_EXPR goto *apply_eval_arg
  goto *apply_not_function
*apply_eval_arg  ; Evaluate arguments and push to stack
  gosub *push        ; S(fn)
  mov %arg0, %arg2
  gosub *push        ; S(env, fn)
  mov %arg0, %arg1
  mov %arg1, %arg2
  gosub *evstack     ; Evstack(arg, env) => side effect: S(len, ..., env, fn)
  mov %arg0, %ret
  gosub *get_tag
  if %ret == TAG_ERROR sub %sp, 2 : mov %ret, %arg0 : return
*apply_using_stack  ; S(len, ..., env, fn)
  mov %tmp, %sp - 1
  mov %tmp, %tmp - %%tmp
  dec %tmp
  mov %arg1, %%tmp   ; %arg1 = env
  dec %tmp
  mov %arg0, %%tmp   ; %arg0 = fn
  gosub *get_tag
  if %ret == TAG_SUBR goto *subr_func
  if %ret == TAG_EXPR goto *expr_call
  gosub *pop         ; len < S(..., env, fn)
  sub %sp, %ret      ; S(env, fn)
  gosub *pop         ; env < S(fn)
  gosub *pop         ; fn < S()
  mov %arg0, %ret    ; %arg0 = fn
*apply_not_function  ; %arg0 = fn, S()
  gosub *get_tag
  if %ret == TAG_ERROR mov %ret, %arg0 : return
  gosub *lobject_to_string
  mov $sarg0, $sret + "は関数ではありません"
  goto *create_error  ; tail call


;;;;;;;;;;
;;;*expr_call(fn, env)
;;;;;;;;;;
*expr_call  ; S(len, Args, ..., env, fn)
  mov %current_proc, %arg0
  mov %current_env, %arg1
  gosub *create_expr_env_using_stack  ; side effect: S(env, fn)
  mov %arg0, %ret      ; %arg0 = new env
  gosub *get_tag : if %ret == TAG_ERROR mov %arg1, 2 : goto *popn_and_error
  gosub *pop           ; env < S(fn)
  gosub *pop           ; fn < S()
  mov %tmp, %ret       ; %tmp = fn
  gosub *push          ; S(new env)
  mov %arg0, %tmp      ; %arg0 = fn
  gosub *cdr           ; CDR(fn)
  mov %arg0, %ret      ; %arg0 = CDR(fn)
  gosub *cdr           ; CDDR(fn) => form
  mov %arg1, %ret      ; %arg1 = form
  gosub *pop           ; new env < S()
  mov %arg2, %ret      ; %arg2 = new env
  goto *syntax_fn_begin  ; tail call


;;;;;;;;;;
;;;*evstack(arg, env)
;;;  Evaluate elements of a list and push these values and the size of list.
;;;  Stack will become S(N, ArgN-1, ArgN-2, ..., Arg0).
;;;  No value is pushed if an error occurs during evaluation.
;;;;;;;;;;
*evstack
  mov %arg2, 0
*evstack_l1        ; (%arg0=arg, %arg1=env, %arg2=len)
  if %arg0 == %nil goto *evstack_exit
  gosub *push      ; S(arg, ...)
  mov %tmp1, %arg0
  mov %arg0, %arg1
  gosub *push      ; S(env, arg, ...)
  mov %arg0, %arg2
  gosub *push      ; S(len, env, arg, ...)
  mov %arg0, %current_proc
  gosub *push      ; S(proc, len, env, arg, ...)
  mov %arg0, %tmp1 ; %arg0 = arg
  gosub *car       ; CAR(arg)
  mov %arg0, %ret  ; %arg0 = CAR(arg)
  gosub *eval      ; Eval(CAR(arg), env) => object
  mov %arg0, %ret
  gosub *get_tag : if %ret == TAG_ERROR goto *evstack_error
  mov %tmp, %arg0  ; %tmp = object
  gosub *pop       ; proc < S(len, env, arg, ...)
  mov %current_proc, %ret
  gosub *pop       ; len < S(env, arg, ...)
  mov %arg2, %ret  ; %arg2 = len
  gosub *pop       ; env < S(arg, ...)
  mov %arg1, %ret  ; %arg1 = env
  gosub *pop       ; arg < S(...)
  mov %arg0, %tmp  ; %arg0 = object
  gosub *push      ; S(object, ...)
  mov %arg0, %ret  ; %arg0 = arg
  gosub *cdr       ; CDR(arg)
  mov %arg0, %ret  ; %arg0 = CDR(arg)
  inc %arg2        ; %arg2++
  goto *evstack_l1
*evstack_error     ; %arg0 = error, S(proc, len, env, arg, ...)
  gosub *pop       ; proc < S(len, env, arg, ...)
  gosub *pop       ; len < S(env, arg, ...)
  mov %arg1, %ret + 2
  goto *popn_and_error
*evstack_exit      ; %arg2 = len
  mov %arg0, %arg2
  gosub *push      ; S(len, ...)
  mov %ret, %sharp_t
  return


;;;;;;;;;;
;;;*create_new_env()
;;;;;;;;;;
*create_new_env
  gosub *create_cons
  mov %arg0, %ret
  gosub *push     ; S(new cons)
  mov %arg1, %nil
  gosub *set_car  ; new cons = (nil . ?)
  gosub *pop      ; new cons < S()
  mov %arg0, %ret
  gosub *push     ; S(new cons)
  mov %arg1, %nil
  gosub *set_cdr  ; new cons = (nil . nil)
  gosub *pop      ; new cons < S()
  return


;;;;;;;;;;
;;;*create_expr_env_using_stack(fn)
;;;;;;;;;;
*create_expr_env_using_stack  ; S(len, Args, ...)
  mov %arg1, %arg0       ; %arg1 = fn
  gosub *pop             ; len < S(Args, ...)
  mov %arg0, %ret        ; %arg0 = len
  gosub *push            ; S(len, Args)
  mov %arg2, %arg0       ; %arg2 = len
  mov %arg0, %arg1       ; %arg0 = fn
  gosub *push            ; S(fn, len, Args, ...)
  mov %arg0, %arg2       ; %arg0 = len
  gosub *push            ; S(len, fn, len, Args, ...)
  mov %arg0, %arg1       ; %arg0 = fn
  gosub *cdr             ; CDR(fn)
  mov %arg0, %ret
  gosub *car             ; CADR(fn) => farg
  mov %arg0, %ret
  gosub *push            ; S(farg, len, fn, len, Args, ...)
  gosub *create_new_env
  mov %arg0, %ret        ; %arg0 = env
  gosub *pop             ; farg < S(len, fn, len, Args, ...)
  mov %tmp1, %ret        ; %tmp1 = farg
  gosub *pop             ; len < S(fn, len, Args, ...)
  mov %tmp2, %ret        ; %tmp2 = len
  gosub *push            ; S(env, fn, len, Args, ...)
  mov %arg0, %tmp2       ; %arg0 = len
  gosub *push            ; S(len, env, fn, len, Args, ...)
*create_expr_env_using_stack_l1  ; %tmp1 = farg, S(idx, env, fn, len, Args)
  if %tmp1 == %nil goto *create_expr_env_using_stack_nil
  mov %arg0, %tmp1       ; %arg0 = farg
  gosub *push            ; S(farg, idx, env, fn, len, Args, ...)
  gosub *get_tag         ; TAG(farg)
  if %ret == TAG_SYMBOL goto *create_expr_env_using_stack_rest
  gosub *car             ; CAR(farg)
  mov %tmp, %ret         ; %tmp = CAR(farg)
  gosub *pop             ; farg < S(idx, env, fn, len, Args, ...)
  mov %tmp1, %ret        ; %tmp1 = farg
  gosub *pop             ; idx < S(env, fn, len, Args, ...)
  if %ret == 0 goto *create_expr_env_using_stack_few
  mov %tmp2, %ret        ; %tmp2 = idx
  mov %arg0, %tmp1       ; %arg0 = farg
  gosub *push            ; S(farg, env, fn, len, Args, ...)
  mov %arg0, %tmp        ; %arg0 = CAR(farg)
  gosub *push            ; S(CAR(farg), farg, env, fn, len, Args, ...)
  mov %tmp1, %tmp2       ; %tmp1 = idx
  mov %tmp2, %sp - 5
  mov %tmp2, %tmp2 - %tmp1
  mov %arg2, %%tmp2      ; %arg2 = Arg
  gosub *pop             ; CAR(farg) < S(farg, env, fn, len, Args, ...)
  mov %arg1, %ret        ; %arg1 = CAR(farg)
  gosub *pop             ; farg < S(env, fn, len, Args, ...)
  mov %tmp2, %ret        ; %tmp2 = farg
  gosub *pop             ; env < S(fn, len, Args, ...)
  mov %arg0, %ret        ; %arg0 = env
  gosub *push            ; S(env, fn, len, Args, ...)
  mov %tmp3, %arg0       ; %tmp3 = env
  mov %arg0, %tmp1       ; %arg0 = idx
  gosub *push            ; S(idx, env, fn)
  mov %arg0, %tmp2       ; %arg0 = farg
  gosub *push            ; S(farg, idx, env, fn, len, Args, ...)
  mov %arg0, %tmp3       ; %arg0 = env
  gosub *add_bind_v2     ; (env, CAR(farg), Arg)
  gosub *pop             ; farg < S(idx, env, fn, len, Args, ...)
  mov %arg0, %ret        ; %arg0 = farg
  gosub *cdr             ; CDR(farg)
  mov %tmp1, %ret        ; %tmp1 = CDR(farg)
  gosub *pop             ; idx < S(env, fn, len, Args, ...)
  mov %arg0, %ret        ; %arg0 = idx
  dec %arg0              ; idx--
  gosub *push            ; S(idx, env, fn, len, Args, ...)
  goto *create_expr_env_using_stack_l1
*create_expr_env_using_stack_nil  ; %tmp1 = farg, S(idx, env, fn, len, Args)
  gosub *pop             ; idx < S(env, fn, len, Args, ...)
  if %ret != 0 goto *create_expr_env_using_stack_many
  gosub *pop             ; env < S(fn, len, Args, ...)
  mov %arg0, %ret        ; %arg0 = env
  gosub *finish_env_v2
  mov %arg0, %ret        ; %arg0 = env
  gosub *pop             ; fn < S(len, Args, ...)
  mov %tmp, %ret         ; %tmp = fn
  gosub *push            ; S(env, len, Args, ...)
  mov %arg0, %tmp        ; %arg0 = fn
  gosub *car             ; CAR(fn) => cls_env
  mov %arg1, %ret        ; %arg1 = cls_env
  gosub *pop             ; env < S(len, Args, ...)
  mov %arg0, %ret        ; %arg0 = env
  gosub *push            ; S(env, len, Args, ...)
  gosub *nconc           ; Nconc(env, cls_env)
  gosub *pop             ; env < S(len, Args, ...)
  mov %arg0, %ret        ; %arg0 = env
  gosub *pop             ; len < S(Args, ...)
  sub %sp, %ret          ; S()
  mov %ret, %arg0        ; %ret = env
  return
*create_expr_env_using_stack_rest  ; S(farg, idx, env, fn, len, Args, ...)
  gosub *pop             ; farg < S(idx, env, fn, len, Args, ...)
  mov %arg0, %ret        ; %arg0 = farg
  gosub *pop             ; idx < S(env, fn, len, Args, ...)
  mov %arg2, %ret        ; %arg2 = idx
  gosub *push            ; S(farg, env, fn, len, Args, ...)
  mov %arg0, %nil
  gosub *push            ; S(nil, farg, env, fn, len, Args, ...)
  mov %arg3, 0           ; %arg3 = count = 0
*create_expr_env_using_stack_rest_l1  ; %arg2 = idx, %arg3 = count
  if %arg2 == %arg3 goto *create_expr_env_using_stack_rest_l2
  inc %arg3              ; count++
  gosub *create_cons
  mov %arg0, %ret        ; %arg0 = cons
  gosub *push            ; S(cons, head, farg, env, fn, len, Args, ...)
  mov %tmp2, %sp - 6
  mov %tmp2, %tmp2 - %arg3
  mov %arg1, %%tmp2      ; %arg1 = Arg
  gosub *set_car         ; cons = (Arg . ?)
  gosub *pop             ; cons < S(head, farg, env, fn, len, Args, ...)
  mov %arg0, %ret        ; %arg0 = cons
  gosub *pop             ; head < S(farg, env, fn, len, Args, ...)
  mov %arg1, %ret        ; %arg1 = head
  gosub *push            ; S(cons, farg, env, fn, len, Args, ...)
  gosub *set_cdr         ; cons = (Arg . head)
  goto *create_expr_env_using_stack_rest_l1
*create_expr_env_using_stack_rest_l2
  gosub *pop             ; cons < S(farg, env, fn, len, Args, ...)
  mov %arg2, %ret        ; %arg2 = cons
  gosub *pop             ; farg < S(env, fn, len, Args, ...)
  mov %arg1, %ret        ; %arg1 = farg
  gosub *pop             ; env < S(fn, len, Args, ...)
  mov %arg0, %ret        ; %arg0 = env
  gosub *push            ; S(env, fn, len, Args, ...)
  gosub *add_bind_v2     ; (env, farg, cons)
  mov %arg0, 0           ; %arg0 = 0
  gosub *push            ; S(0, env, fn, len, Args, ...)
  goto *create_expr_env_using_stack_nil
*create_expr_env_using_stack_few  ; S(env, fn, len, Args, ...)
  gosub *pop             ; env < S(fn, len, Args, ...)
  gosub *pop             ; fn < S(len, Args, ...)
  gosub *too_few_arg0    ; %arg0 = error
  gosub *pop             ; len < S(Args, ...)
  mov %arg1, %ret        ; %arg1 = len
  goto *popn_and_error  ; tail call
*create_expr_env_using_stack_many  ; S(env, fn, len, Args, ...)
  gosub *pop             ; env < S(fn, len, Args, ...)
  gosub *pop             ; fn < S(len, Args, ...)
  gosub *too_many_arg0   ; %arg0 = error
  gosub *pop             ; len < S(Args, ...)
  mov %arg1, %ret        ; %arg1 = len
  goto *popn_and_error  ; tail call

;;;;;;;;;;
;;;*add_bind_v2(env, sym, val)
;;;  Add bind to environment and return the environment.
;;;  This subroutine is for local environment. Local environment is list of
;;;  just list, not a-list. For example ((1 2 3) (4 5)).
;;;  You MUST call *finish_env_v2 before use the environment.
;;;;;;;;;;
*add_bind_v2
  gosub *push         ; S(env)
  gosub *car          ; CAR(env) => frame
  mov %arg0, %ret     ; %arg0 = frame
  gosub *push         ; S(frame, env)
  mov %arg0, %arg2    ; %arg0 = val
  gosub *push         ; S(val, frame, env)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; val < S(frame, env)
  mov %arg1, %ret     ; %arg1 = val
  gosub *set_car      ; cons1 = (val . ?)
  gosub *pop          ; frame < S(env)
  mov %arg1, %ret     ; %arg1 = frame
  gosub *set_cdr      ; cons1 = (val . frame)
  mov %arg1, %arg0    ; %arg1 = cons1
  gosub *pop          ; env < S()
  mov %arg0, %ret     ; %arg0 = env
  gosub *set_car      ; env = (cons1 . rest-frame)
  return


;;;;;;;;;;
;;;*finish_env_v2(env)
;;;  Correct first frame of local environment and return the environment.
;;;  You MUST NOT call this subroutine twice for the same frame.
;;;;;;;;;;
*finish_env_v2
  gosub *push         ; S(env)
  gosub *car          ; CAR(env) => frame_r
  mov %arg0, %ret     ; %arg0 = frame_r
  gosub *nreverse     ; nreverse(frame_r)
  mov %arg1, %ret     ; %arg1 = frame
  gosub *pop          ; env < S()
  mov %arg0, %ret     ; %arg0 = env
  gosub *set_car      ; env = (frame ...)
  return

;;;;;;;;;;
;;;*check_arguments_length(arg, n)
;;;;;;;;;;
*check_arguments_length
  gosub *push           ; S(arg)
*check_arguments_length_l1
  if %arg1 == 0 goto *check_arguments_length_end
  if %arg0 == %nil goto *check_arguments_length_few
  gosub *cdr
  mov %arg0, %ret
  dec %arg1
  goto *check_arguments_length_l1
*check_arguments_length_few
  gosub *pop            ; arg < S()
  goto *too_few_arg0    ; tail call
*check_arguments_length_end
  gosub *pop            ; arg < S()
  if %arg0 == %nil mov %arg0, %ret : return
  goto *too_many_arg0   ; tail call


;;;;;;;;;;
;;;*wrong_stack_arguments(farg, aarg)
;;;;;;;;;;
*wrong_stack_arguments
  sub %sp, %arg1        ; S()
  if %arg0 > %arg1 goto *wrong_stack_arguments_few
  gosub *too_many_arg0
  goto *wrong_stack_arguments_exit
*wrong_stack_arguments_few
  gosub *too_few_arg0
*wrong_stack_arguments_exit
  mov %ret, %arg0
  return


;;;;;;;;;;
;;;*subr_func(fn, env)
;;;;;;;;;;
*subr_func  ; S(env, fn)
  mov %current_proc, %arg0
  mov %current_env, %arg1
  gosub *get_data
  if %ret == lf_car gosub *subr_func_car : goto *subr_func_exit
  if %ret == lf_cdr gosub *subr_func_cdr : goto *subr_func_exit
  if %ret == lf_cons gosub *subr_func_cons : goto *subr_func_exit
  if %ret == lf_eq gosub *subr_func_eq : goto *subr_func_exit
  if %ret == lf_atom gosub *subr_func_atom : goto *subr_func_exit
  if %ret == lf_add gosub *subr_func_add : goto *subr_func_exit
  if %ret == lf_sub gosub *subr_func_sub : goto *subr_func_exit
  if %ret == lf_mul gosub *subr_func_mul : goto *subr_func_exit
  if %ret == lf_div gosub *subr_func_div : goto *subr_func_exit
  if %ret == lf_mod gosub *subr_func_mod : goto *subr_func_exit
  if %ret == lf_gt gosub *subr_func_gt : goto *subr_func_exit
  if %ret == lf_ge gosub *subr_func_ge : goto *subr_func_exit
  if %ret == lf_ls gosub *subr_func_ls : goto *subr_func_exit
  if %ret == lf_le gosub *subr_func_le : goto *subr_func_exit
  if %ret == lf_set_car gosub *subr_func_set_car : goto *subr_func_exit
  if %ret == lf_set_cdr gosub *subr_func_set_cdr : goto *subr_func_exit
  if %ret == lf_eval gosub *subr_func_eval : goto *subr_func_exit
  if %ret == lf_apply goto *subr_func_apply  ; Use GOTO
  if %ret == lf_booleanp gosub *subr_func_booleanp : goto *subr_func_exit
  if %ret == lf_pairp gosub *subr_func_pairp : goto *subr_func_exit
  if %ret == lf_symbolp gosub *subr_func_symbolp : goto *subr_func_exit
  if %ret == lf_numberp gosub *subr_func_numberp : goto *subr_func_exit
  if %ret == lf_procedurep gosub *subr_func_procedurep : goto *subr_func_exit
  if %ret == lf_null gosub *subr_func_null : goto *subr_func_exit
  if %ret == lf_read gosub *subr_func_read : goto *subr_func_exit
  if %ret == lf_write gosub *subr_func_write : goto *subr_func_exit
  if %ret == lf_error gosub *subr_func_error : goto *subr_func_exit
  mov $sarg0, "Invalid-SUBR"
  gosub *create_error
*subr_func_exit
  sub %sp, 2         ; S()
  return

*subr_func_car
  gosub *pop        ; len < S(Args, ...)
  if %ret != 1 : mov %arg0, 1 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg0 < S()
  if %ret == %nil return
  mov %arg0, %ret
  gosub *get_tag
  if %ret != TAG_CONS gosub *cons_required : mov %ret, %arg0 : return
  gosub *car        ; CAR(Arg0)
  return

*subr_func_cdr
  gosub *pop        ; len < S(Args, ...)
  if %ret != 1 : mov %arg0, 1 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; arg0 < S()
  if %ret == %nil return
  mov %arg0, %ret
  gosub *get_tag
  if %ret != TAG_CONS gosub *cons_required : mov %ret, %arg0 : return
  gosub *cdr        ; CDR(Arg0)
  return

*subr_func_cons
  gosub *pop        ; len < S(Args, ...)
  if %ret != 2 : mov %arg0, 2 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *create_cons
  mov %arg0, %ret    ; %arg0 = new cons
  gosub *pop         ; Arg1 < S(Arg0)
  mov %arg1, %ret    ; %arg1 = Arg1
  gosub *push        ; S(new cons, Arg0)
  gosub *set_cdr     ; new cons = (? . Arg1)
  gosub *pop         ; new cons < S(Arg0)
  mov %arg0, %ret    ; %arg0 = new cons
  gosub *pop         ; Arg0 < S()
  mov %arg1, %ret    ; %arg1 = Arg0
  gosub *push        ; S(new cons)
  gosub *set_car     ; new cons = (Arg0 . Arg1)
  gosub *pop
  return

*subr_func_eq
  gosub *pop        ; len < S(Args, ...)
  if %ret != 2 : mov %arg0, 2 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg1 < S(Arg0)
  mov %arg1, %ret   ; %arg1 = Arg1
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  if %arg0 == %arg1 mov %ret, %sharp_t : return
  gosub *get_tag
  if %ret != TAG_NUM mov %ret, %sharp_f : return
  mov %arg2, %arg0  ; %arg2 = Arg0
  mov %arg0, %arg1  ; %arg0 = Arg1
  gosub *get_tag
  if %ret != TAG_NUM mov %ret, %sharp_f : return
  mov %arg0, %arg2  ; %arg0 = Arg0
  if %%arg0 == %%arg1 mov %ret, %sharp_t : return
  mov %ret, %sharp_f
  return

*subr_func_atom
  gosub *pop        ; len < S(Args, ...)
  if %ret != 1 : mov %arg0, 1 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret
  gosub *get_tag
  if %ret != TAG_CONS mov %ret, %sharp_t : return
  mov %ret, %sharp_f
  return

*subr_func_add
  mov %arg2, 0    ; result
  gosub *pop      ; len < S(Args, ...)
  mov %arg1, %ret ; %arg1 = len
*subr_func_add_l1 ; (arg1 = len, arg2 = result)
  if %arg1 == 0 goto *subr_func_add_exit
  gosub *pop
  dec %arg1
  mov %arg0, %ret
  gosub *get_tag
  if %ret != TAG_NUM goto *subr_func_add_error
  gosub *get_num_data
  add %arg2, %ret
  goto *subr_func_add_l1
*subr_func_add_error
  sub %sp, %arg1    ; S()
  gosub *number_required
  mov %ret, %arg0
  return
*subr_func_add_exit
  mov %arg0, %arg2
  goto *create_num  ; tail call

*subr_func_sub
  gosub *pop        ; len < S(Args, ...)
  if %ret != 2 : mov %arg0, 2 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg1 < S(Arg0)
  mov %arg1, %ret   ; %arg1 = Arg1
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %arg2, %ret   ; %arg2 = NUM0
  mov %arg0, %arg1  ; %arg0 = Arg1
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %arg0, %arg2 - %ret
  goto *create_num  ; tail call

*subr_func_mul
  mov %arg2, 1    ; result
  gosub *pop      ; len < S(Args, ...)
  mov %arg1, %ret ; %arg1 = len
*subr_func_mul_l1 ; (arg1 = len, arg2 = result)
  if %arg1 == 0 goto *subr_func_mul_exit
  gosub *pop
  dec %arg1
  mov %arg0, %ret
  gosub *get_tag
  if %ret != TAG_NUM goto *subr_func_mul_error
  gosub *get_num_data
  mul %arg2, %ret
  goto *subr_func_mul_l1
*subr_func_mul_error
  sub %sp, %arg1    ; S()
  gosub *number_required
  mov %ret, %arg0
  return
*subr_func_mul_exit
  mov %arg0, %arg2
  goto *create_num  ; tail call

*subr_func_div
  gosub *pop        ; len < S(Args, ...)
  if %ret != 2 : mov %arg0, 2 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg1 < S(Arg0)
  mov %arg1, %ret   ; %arg1 = Arg1
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %arg2, %ret   ; %arg2 = NUM0
  mov %arg0, %arg1  ; %arg0 = Arg1
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %arg0, %arg2 / %ret
  goto *create_num  ; tail call

*subr_func_mod
  gosub *pop        ; len < S(Args, ...)
  if %ret != 2 : mov %arg0, 2 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg1 < S(Arg0)
  mov %arg1, %ret   ; %arg1 = Arg1
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %arg2, %ret   ; %arg2 = NUM0
  mov %arg0, %arg1  ; %arg0 = Arg1
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %arg0, %arg2 mod %ret
  goto *create_num  ; tail call

*subr_func_gt
  gosub *pop        ; len < S(Args, ...)
  if %ret != 2 : mov %arg0, 2 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg1 < S(Arg0)
  mov %arg1, %ret   ; %arg1 = Arg1
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %arg2, %ret   ; %arg2 = NUM0
  mov %arg0, %arg1  ; %arg0 = Arg1
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %tmp, %ret    ; %tmp = NUM1
  mov %ret, %sharp_f
  if %arg2 > %tmp mov %ret, %sharp_t
  return

*subr_func_ge
  gosub *pop        ; len < S(Args, ...)
  if %ret != 2 : mov %arg0, 2 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg1 < S(Arg0)
  mov %arg1, %ret   ; %arg1 = Arg1
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %arg2, %ret   ; %arg2 = NUM0
  mov %arg0, %arg1  ; %arg0 = Arg1
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %tmp, %ret    ; %tmp = NUM1
  mov %ret, %sharp_f
  if %arg2 >= %tmp mov %ret, %sharp_t
  return

*subr_func_ls
  gosub *pop        ; len < S(Args, ...)
  if %ret != 2 : mov %arg0, 2 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg1 < S(Arg0)
  mov %arg1, %ret   ; %arg1 = Arg1
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %arg2, %ret   ; %arg2 = NUM0
  mov %arg0, %arg1  ; %arg0 = Arg1
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %tmp, %ret    ; %tmp = NUM1
  mov %ret, %sharp_f
  if %arg2 < %tmp mov %ret, %sharp_t
  return

*subr_func_le
  gosub *pop        ; len < S(Args, ...)
  if %ret != 2 : mov %arg0, 2 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg1 < S(Arg0)
  mov %arg1, %ret   ; %arg1 = Arg1
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %arg2, %ret   ; %arg2 = NUM0
  mov %arg0, %arg1  ; %arg0 = Arg1
  gosub *get_tag
  if %ret != TAG_NUM gosub *number_required : mov %ret, %arg0 : return
  gosub *get_num_data
  mov %tmp, %ret    ; %tmp = NUM1
  mov %ret, %sharp_f
  if %arg2 <= %tmp mov %ret, %sharp_t
  return

*subr_func_set_car
  gosub *pop        ; len < S(Args, ...)
  if %ret != 2 : mov %arg0, 2 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg1 < S(Arg0)
  mov %arg1, %ret   ; %arg1 = Arg1
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret != TAG_CONS gosub *cons_required : mov %ret, %arg0 : return
  gosub *push       ; S(Arg0)
  gosub *set_car
  gosub *pop        ; Arg0 < S()
  return

*subr_func_set_cdr
  gosub *pop        ; len < S(Args, ...)
  if %ret != 2 : mov %arg0, 2 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg1 < S(Arg0)
  mov %arg1, %ret   ; %arg1 = Arg1
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret != TAG_CONS gosub *cons_required : mov %ret, %arg0 : return
  gosub *push       ; S(Arg0)
  gosub *set_cdr
  gosub *pop        ; Arg0 < S()
  return

*subr_func_eval
  gosub *pop          ; len < S(Args, ...)
  if %ret != 1 : mov %arg0, 1 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop          ; Arg0 < S()
  mov %arg0, %ret
  mov %arg1, %global_env
  goto *eval_form  ; tail call

*subr_func_apply  ; S(len, ArgN-1, ..., Arg0, env, fn)
  gosub *pop          ; len < S(ArgN-1, ..., Arg0, env, fn)
  if %ret < 2 : mov %arg0, 2 : mov %arg1, %ret : goto *wrong_stack_arguments
  mov %arg1, %ret     ; %arg1 = len (= N)
  ; Replace fn with Arg0
  mov %tmp, %sp       ; %tmp = %sp
  sub %tmp, %arg1     ; %tmp -> Arg0
  mov %tmp1, %tmp - 2 ; %tmp1 -> fn
  mov %%tmp1, %%tmp   ; fn = Arg0
  ; Shift Arguments
  for %i=0 to %arg1-2
    mov %tmp1, %tmp+%i ; %tmp1 -> ArgI
    mov %tmp2, %tmp1+1; %tmp1 -> ArgI+1
    mov %%tmp1, %%tmp2; ArgI = ArgI+1
  next
  dec %sp             ; S(ArgN-1, ..., Arg1, env, Arg0)
  dec %arg1           ; %arg1 = N-1
  gosub *pop          ; ArgN-1 < S(ArgN-2, ..., Arg1, env, Arg0)
  mov %arg0, %ret     ; %arg0 = ArgN-1
*subr_func_apply_loop  ; %arg0 = list, %arg1 = N-1
  if %arg0 == %nil goto *subr_func_apply_call
  gosub *get_tag
  if %ret != TAG_CONS goto *subr_func_apply_not_list
  gosub *cdr          ; CDR(list)
  mov %tmp, %ret      ; %tmp = rest
  gosub *car          ; CAR(list)
  mov %arg0, %ret     ; %arg0 = head
  gosub *push         ; S(head, ArgN-2, ..., Arg1, env, Arg0)
  inc %arg1           ; %arg1 = (N+1)-1, S(Arg(N+1)-2, ..., Arg1, env, Arg0)
  mov %arg0, %tmp     ; %arg0 = rest
  goto *subr_func_apply_loop
*subr_func_apply_call  ; %arg1 = N-1
  mov %arg0, %arg1 - 1
  gosub *push         ; S(N-2, ArgN-2, ..., Arg1, env, Arg0)
  goto *apply_using_stack  ; taill call
*subr_func_apply_not_list  ; %arg1 = N-1, S(ArgN-2, ..., Arg1, env, Arg0)
  mov %tmp, %arg1 + 1 ; %tmp = N
  sub %sp, %tmp       ; S()
  gosub *list_required
  mov %ret, %arg0
  return

*subr_func_booleanp
  gosub *pop        ; len < S(Args, ...)
  if %ret != 1 : mov %arg0, 1 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  if %ret != %sharp_t && %ret != %sharp_f : mov %ret, %sharp_f : return
  mov %ret, %sharp_t
  return

*subr_func_pairp
  gosub *pop        ; len < S(Args, ...)
  if %ret != 1 : mov %arg0, 1 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret == TAG_CONS mov %ret, %sharp_t : return
  mov %ret, %sharp_f
  return

*subr_func_symbolp
  gosub *pop        ; len < S(Args, ...)
  if %ret != 1 : mov %arg0, 1 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret == TAG_SYMBOL mov %ret, %sharp_t : return
  mov %ret, %sharp_f
  return

*subr_func_numberp
  gosub *pop        ; len < S(Args, ...)
  if %ret != 1 : mov %arg0, 1 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret == TAG_NUM mov %ret, %sharp_t : return
  mov %ret, %sharp_f
  return

*subr_func_procedurep
  gosub *pop        ; len < S(Args, ...)
  if %ret != 1 : mov %arg0, 1 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *get_tag
  if %ret != TAG_EXPR goto *subr_func_procedurep_l1
  goto *subr_func_procedurep_l2
*subr_func_procedurep_l1
  if %ret != TAG_SUBR mov %ret, %sharp_f : return
*subr_func_procedurep_l2
  mov %ret, %sharp_t
  return

*subr_func_null
  gosub *pop        ; len < S(Args, ...)
  if %ret != 1 : mov %arg0, 1 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  mov %ret, %sharp_f
  if %arg0 == %nil mov %ret, %sharp_t
  return

*subr_func_read
  gosub *pop        ; len < S(Args, ...)
  if %ret != 0 : mov %arg0, 0 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *read_from_console
  mov $sarg0, $sret
  gosub *input_to_lobject
  return

*subr_func_write
  gosub *pop        ; len < S(Args, ...)
  if %ret != 1 : mov %arg0, 1 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *push
  gosub *lobject_to_string
  $sret　\
  gosub *pop
  return

*subr_func_error
  gosub *pop        ; len < S(Args, ...)
  if %ret != 1 : mov %arg0, 1 : mov %arg1, %ret : goto *wrong_stack_arguments
  gosub *pop        ; Arg0 < S()
  mov %arg0, %ret   ; %arg0 = Arg0
  gosub *lobject_to_string
  mov $sarg0, $sret
  goto *create_error  ; tail call


;;;;;;;;;;
;;;*syntax_fn(fn, arg, env)
;;;  Returns syntax function label and #t if fn is keyword.
;;;  Returns #f if fn isn't keyword.
;;;;;;;;;;
*syntax_fn
  if %arg0 == %quote mov $sret, "*syntax_fn_quote" : goto *syntax_fn1
  if %arg0 == %sym_begin mov $sret, "*syntax_fn_begin" : goto *syntax_fn2
  if %arg0 == %sym_lambda mov $sret, "*syntax_fn_lambda" : goto *syntax_fn1
  if %arg0 == %sym_define mov $sret, "*syntax_fn_define" : goto *syntax_fn1
  if %arg0 == %sym_if mov $sret, "*syntax_fn_if" : goto *syntax_fn1
  if %arg0 == %sym_and mov $sret, "*syntax_fn_and" : goto *syntax_fn1
  if %arg0 == %sym_or mov $sret, "*syntax_fn_or" : goto *syntax_fn1
  if %arg0 == %sym_set mov $sret, "*syntax_fn_set" : goto *syntax_fn1
  if %arg0 == %sym_time mov $sret, "*syntax_fn_time" : goto *syntax_fn1
  mov %ret, %sharp_f
  return
*syntax_fn1
  mov %current_proc, %arg0
*syntax_fn2
  mov %ret, %sharp_t
  return

*syntax_fn_quote
  mov %arg0, %arg1
  mov %arg1, 1 : gosub *check_arguments_length
  gosub *get_tag : if %ret == TAG_ERROR mov %ret, %arg0 : return
  gosub *car  ; CAR(arg)
  return

*syntax_fn_begin
  mov %arg0, %arg1     ; %arg0 = arg
  mov %arg1, %arg2     ; %arg1 = env
  mov %ret, %nil
*syntax_fn_begin_l1  ;(arg0 = arg, arg1 = env)
  if %arg0 == %nil return
  gosub *push          ; S(arg)
  mov %tmp, %arg0
  mov %arg0, %arg1
  gosub *push          ; S(env, arg)
  mov %arg0, %tmp
  gosub *push          ; S(arg, env, arg)
  gosub *cdr           ; CDR(arg)
  if %ret == %nil goto *syntax_fn_begin_tail
  gosub *pop           ; arg < S(env, arg)
  mov %arg0, %ret
  gosub *car           ; CAR(arg)
  mov %tmp, %ret
*syntax_fn_begin_l2
  gosub *pop           ; env < S(arg)
  mov %arg0, %ret
  gosub *push          ; S(env, arg)
  mov %arg1, %arg0
  mov %arg0, %current_proc
  gosub *push          ; S(proc, env, arg)
  mov %arg0, %tmp
  gosub *eval          ; Eval(CAR(arg), env) => object
  mov %arg0, %ret
  gosub *get_tag : if %ret == TAG_ERROR goto *pop3_and_error
  gosub *pop           ; proc < S(env, arg)
  mov %current_proc, %ret
  gosub *pop           ; env < S(arg)
  mov %current_env, %ret
  mov %tmp, %ret
  gosub *pop           ; arg < S()
  mov %tmp1, %ret
  gosub *push          ; S(object)
  mov %arg0, %tmp
  gosub *push          ; S(env, object)
  mov %arg0, %tmp1
  gosub *cdr           ; CDR(arg)
  mov %arg0, %ret      ; arg = CDR(arg)
  gosub *pop           ; env < S(object)
  mov %arg1, %ret
  gosub *pop           ; object < S()
  ;mov %ret, %ret
  goto *syntax_fn_begin_l1
*syntax_fn_begin_tail  ; S(arg, env, arg)
  gosub *pop           ; arg < S(env, arg)
  mov %arg0, %ret
  gosub *car           ; CAR(arg)
  mov %arg0, %ret
  gosub *get_tag
  if %ret != TAG_CONS mov %tmp, %arg0 : goto *syntax_fn_begin_l2
  gosub *pop          ; env < S(arg)
  mov %arg1, %ret
  gosub *pop          ; arg < S()
  goto *eval  ; tail call

*syntax_fn_lambda
  if %arg1 == %nil gosub *too_few_arg0 : mov %ret, %arg0 : return
  mov %arg0, %arg2
  gosub *push        ; S(env)
  mov %arg0, %arg1
  gosub *push        ; S(arg, env)
  gosub *car         ; CAR(arg) => argument
  mov %arg0, %ret
  gosub *get_tag
  if %ret != TAG_CONS && %ret != TAG_SYMBOL goto *pop2_and_invstx
  gosub *pop         ; arg < S(env)
  mov %tmp, %ret
  gosub *push        ; S(argument, env)
  mov %arg0, %tmp
  gosub *cdr         ; CDR(arg) =>form
  mov %arg0, %ret    ; arg0 = form
  gosub *pop         ; argument < S(env)
  mov %arg1, %ret    ; arg1 = argument
  gosub *pop         ; env < S()
  mov %arg2, %ret    ; arg2 = env
  goto *create_expr  ; tail call (form, arg, env)

*syntax_fn_define
  mov %arg2, %toplevel_env
  mov %arg0, %arg2
  gosub *push         ; S(env)
  mov %arg0, %arg1
  gosub *push         ; S(arg, env)
  gosub *car          ; CAR(arg) => sym
  mov %arg0, %ret
  gosub *pop          ; arg < S(env)
  mov %tmp1, %ret
  gosub *push         ; S(sym, env)
  mov %arg0, %tmp1
  mov %arg1, 2 : gosub *check_arguments_length
  gosub *get_tag : if %ret == TAG_ERROR goto *pop2_and_error
  gosub *cdr          ; CDR(arg)
  mov %arg0, %ret
  gosub *car          ; CADR(arg) => val
  mov %tmp, %ret
  gosub *pop          ; sym < S(env)
  mov %tmp1, %ret
  gosub *pop          ; env < S()
  mov %arg0, %ret
  gosub *push         ; S(env)
  mov %arg1, %arg0
  mov %arg0, %tmp1
  gosub *push         ; S(sym, env)
  mov %arg0, %tmp
  gosub *eval         ; (val, env)
  mov %arg0, %ret
  gosub *get_tag : if %ret == TAG_ERROR goto *pop2_and_error
  mov %arg2, %arg0
*syntax_fn_define_l1
  gosub *pop          ; sym < S(env)
  mov %arg0, %ret
  gosub *pop          ; env < S()
  mov %tmp, %ret
  gosub *push         ; S(sym)
  mov %arg1, %arg0
  mov %arg0, %tmp
  ; TODO: We should protect built-in functions/variables from user.
  if %arg1 == %quote gosub *pop : mov %ret, %nil : return
  gosub *add_global_bind
  gosub *pop
  return


*syntax_fn_set
  mov %arg0, %arg2
  gosub *push         ; S(env)
  mov %arg0, %arg1
  mov %arg1, 2 : gosub *check_arguments_length
  gosub *get_tag : if %ret == TAG_ERROR gosub *pop : mov %ret, %arg0 : return
  gosub *push         ; S(arg, env)
  gosub *car          ; CAR(arg) => sym
  mov %arg0, %ret
  gosub *pop          ; arg < S(env)
  mov %tmp1, %ret
  gosub *push         ; S(sym, env)
  mov %arg0, %tmp1
  gosub *cdr          ; CDR(arg)
  mov %arg0, %ret
  gosub *car          ; CADR(arg) => val
  mov %tmp, %ret
  gosub *pop          ; sym < S(env)
  mov %tmp1, %ret
  gosub *pop          ; env < S()
  mov %arg0, %ret
  gosub *push         ; S(env)
  mov %arg1, %arg0
  mov %arg0, %tmp1
  gosub *push         ; S(sym, env)
  mov %arg0, %tmp
  gosub *eval         ; (val, env) => object
  mov %arg0, %ret
  gosub *get_tag : if %ret == TAG_ERROR goto *pop2_and_error
  mov %tmp, %arg0
  gosub *pop          ; sym < S(env)
  mov %tmp1, %ret
  gosub *pop          ; env < S()
  mov %arg1, %ret
  mov %arg0, %tmp
  gosub *push         ; S(object)
  mov %arg0, %tmp1
  gosub *get_tag
  if %ret == TAG_VAR goto *syntax_fn_set_local
  if %ret == TAG_GVAR goto *syntax_fn_set_found
  gosub *member_syntax
  if %ret == %sharp_t goto *syntax_fn_set_error
  ;; When a symbol occurs here, the symbol must be a syntax symbol.
  ;; Therefore, following code shouldn't be run.
  gosub *pop          ; object < S()
  gosub *lobject_to_string
  mov $sarg0, "E " + $sret  ; Internal error
  gosub *create_error
  return
*syntax_fn_set_found
  gosub *pop          ; object < S()
  mov %arg1, %ret
  gosub *set_cdr      ; SetCdr(pair, object)
  mov %ret, %sharp_t
  return
*syntax_fn_set_error  ;S(object)
  gosub *pop          ; object < S()
  mov %ret, %sharp_f
  return
*syntax_fn_set_local  ; %arg0 = var, %arg1 = env, S(object)
  gosub *car              ; (frame << 6) + index
  mov %arg0, %arg1        ; %arg0 = env
  mov %arg1, %ret / 64    ; %arg1 = frame
  mov %arg2, %ret mod 64  ; %arg2 = index
  gosub *find_local_var_cell
  mov %arg0, %ret         ; %arg0 = cell
  gosub *pop              ; object < S()
  mov %arg1, %ret         ; %arg1 = object
  gosub *set_car          ; Update variable
  mov %ret, %sharp_t
  return

*syntax_fn_if
  mov %arg0, %arg1
  mov %arg1, %arg2
  gosub *push         ; S(arg)
  mov %tmp, %arg0
  mov %arg0, %arg1
  gosub *push         ; S(env, arg)
  mov %arg0, %tmp
  gosub *car          ; CAR(arg) => cnd
  mov %tmp, %ret
  gosub *pop          ; env < S(arg)
  mov %arg0, %ret
  gosub *push         ; S(env, arg)
  mov %arg1, %arg0
  mov %arg0, %current_proc
  gosub *push         ; S(proc, env, arg)
  mov %arg0, %tmp
  gosub *eval
  mov %arg0, %ret
  gosub *get_tag : if %ret == TAG_ERROR goto *pop3_and_error
  gosub *pop          ; proc < S(env, arg)
  mov %current_proc, %ret
  if %arg0 != %sharp_f goto *syntax_fn_if_l1
  gosub *pop          ; env < S(arg)
  mov %current_env, %ret
  mov %arg0, %ret
  gosub *pop          ; arg < S()
  mov %tmp, %ret
  gosub *push         ; S(env)
  mov %arg0, %tmp
  gosub *cdr          ; CDR(arg)
  if %ret == %nil gosub *pop : gosub *too_few_arg0 : mov %ret, %arg0 : return
  mov %arg0, %ret
  gosub *cdr          ; CDDR(arg)
  mov %arg0, %ret
  gosub *car          ; CADDR(arg)
  mov %arg0, %ret
  gosub *pop          ; env < S()
  mov %arg1, %ret
  goto *eval  ; tail call
*syntax_fn_if_l1
  gosub *pop          ; env < S(arg)
  mov %arg0, %ret
  gosub *pop          ; arg < S()
  mov %tmp, %ret
  gosub *push         ; S(env)
  mov %arg0, %tmp
  gosub *cdr          ; CDR(arg)
  if %ret == %nil gosub *pop : gosub *too_few_arg0 : mov %ret, %arg0 : return
  mov %arg0, %ret
  gosub *car          ; CADR(arg)
  mov %arg0, %ret
  gosub *pop          ; env < S()
  mov %arg1, %ret
  goto *eval  ; tail call

*syntax_fn_and
  mov %ret, %sharp_t
*syntax_fn_and_l1  ;(arg1 = arg, arg2 = env, ret = result)
  if %arg1 == %nil goto *syntax_fn_and_l3
  mov %arg0, %arg1
  gosub *push         ; S(arg)
  mov %arg0, %arg2
  gosub *push         ; S(env, arg)
  mov %arg0, %arg1
  gosub *car          ; CAR(arg) => expr
  mov %tmp, %ret
  gosub *pop          ; env < S(arg)
  mov %arg0, %ret
  gosub *push         ; S(env, arg)
  mov %arg1, %arg0
  mov %arg0, %current_proc
  gosub *push         ; S(proc, env, arg)
  mov %arg0, %tmp
  gosub *eval         ; Eval(expr, env) => object
  mov %arg0, %ret
  gosub *get_tag : if %ret == TAG_ERROR goto *pop3_and_error
  gosub *pop          ; proc < S(env, arg)
  mov %current_proc, %ret
  gosub *pop          ; env < S(arg)
  mov %current_env, %ret
  if %arg0 == %sharp_f goto *syntax_fn_and_l2
  mov %tmp, %ret      ; tmp = env
  gosub *pop          ; arg < S()
  mov %tmp1, %ret
  gosub *push         ; S(object)
  mov %arg0, %tmp
  gosub *push         ; S(env, object)
  mov %arg0, %tmp1
  gosub *cdr          ; arg = CDR(arg)
  mov %arg1, %ret
  gosub *pop          ; env < S(object)
  mov %arg2, %ret
  gosub *pop          ; object < S()
  goto *syntax_fn_and_l1
*syntax_fn_and_l2
  gosub *pop          ; arg < S()
  mov %ret, %sharp_f
  return
*syntax_fn_and_l3
  return

*syntax_fn_or
  mov %ret, %sharp_f
*syntax_fn_or_l1  ; (%arg1 = arg, %arg2 = env, %ret = result)
  if %arg1 == %nil goto *syntax_fn_or_l3
  mov %arg0, %arg1
  gosub *push         ; S(arg)
  mov %arg0, %arg2
  gosub *push         ; S(env, arg)
  mov %arg0, %arg1
  gosub *car          ; CAR(arg) => expr
  mov %tmp, %ret
  gosub *pop          ; env < S(arg)
  mov %arg0, %ret
  gosub *push         ; S(env, arg)
  mov %arg1, %arg0
  mov %arg0, %current_proc
  gosub *push         ; S(proc, env, arg)
  mov %arg0, %tmp
  gosub *eval         ; Eval(expr, env) => object
  mov %arg0, %ret
  gosub *get_tag : if %ret == TAG_ERROR goto *pop3_and_error
  gosub *pop          ; proc < S(env, arg)
  mov %current_proc, %ret
  gosub *pop          ; env < S(arg)
  mov %current_env, %ret
  if %arg0 != %sharp_f goto *syntax_fn_or_l2
  mov %tmp, %ret      ; tmp = env
  gosub *pop          ; arg < S()
  mov %tmp1, %ret
  gosub *push         ; S(object)
  mov %arg0, %tmp
  gosub *push         ; S(env, object)
  mov %arg0, %tmp1
  gosub *cdr          ; arg = CDR(arg)
  mov %arg1, %ret
  gosub *pop          ; env < S(object)
  mov %arg2, %ret
  gosub *pop          ; object < S()
  goto *syntax_fn_or_l1
*syntax_fn_or_l2     ; (arg0 = object, S(env, arg))
  mov %tmp, %arg0
  gosub *pop          ; arg < S()
  mov %ret, %tmp
  return
*syntax_fn_or_l3
  mov %ret, %sharp_f
  return

*syntax_fn_time
  inc %gc_silent
  mov %arg0, %gc_run
  gosub *push
  gettimer %arg0
  gosub *push
  mov %arg0, %arg1
  gosub *car  ; CAR(arg) => expr
  mov %arg0, %ret
  mov %arg1, %arg2
  gosub *eval
  mov %tmp, %ret
  gettimer %tmp1
  gosub *pop
  sub %tmp1, %ret
  mov %tmp2, %gc_run
  gosub *pop
  sub %tmp2, %ret
ｔｉｍｅ：%tmp1ｍｓ
ＧＣ：%tmp2\
  mov %ret, %tmp
  dec %gc_silent
  return


;;;;;;;;;;
;;;*nreverse(list)
;;;  Reverse a list destructively.
;;;  Returns a head of the reversed list.
;;;  Returns NIL if list is invalid.
;;;;;;;;;;
*nreverse
  mov %arg1, %nil
*nreconc  ; %arg0 = list, %arg1 = tail
  gosub *get_tag
  if %ret != TAG_CONS mov %ret, %arg1 : return
  gosub *cdr          ; CDR(list)
  mov %tmp, %arg0     ; %tmp = list
  mov %arg0, %ret     ; %arg0 = CDR(list)
  gosub *push         ; S(CDR(list))
  mov %arg0, %tmp     ; %arg0 = list
  gosub *push         ; S(list, CDR(list))
  gosub *set_cdr      ; list = (head . tail)
  gosub *pop          ; list < S(CDR(list))
  mov %arg1, %ret     ; %arg1 = list
  gosub *pop          ; CDR(list) < S()
  mov %arg0, %ret     ; %arg0 = CDR(list)
  goto *nreconc


;;;;;;;;;;
;;;*reverse(list)
;;;  Reverse a list.
;;;  Returns a head of the reversed list.
;;;  Returns NIL if list is invalid.
;;;;;;;;;;
*reverse
  mov %tmp, %arg0     ; %tmp = list
  mov %arg0, %nil
  gosub *push         ; S(nil)
  mov %arg0, %tmp     ; %arg0 = list
*revappend  ; %arg0 = list, S(acc)
  gosub *get_tag
  if %ret != TAG_CONS gosub *pop : return
  gosub *car          ; CAR(list)
  mov %tmp, %ret      ; %tmp = head
  gosub *cdr          ; CDR(list)
  mov %arg0, %ret     ; %arg0 = rest
  gosub *push         ; S(rest, acc)
  mov %arg0, %tmp     ; %arg0 = head
  gosub *push         ; S(head, rest, acc)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; head < S(rest, acc)
  mov %arg1, %ret     ; %arg1 = head
  gosub *push         ; S(cons1, rest, acc)
  gosub *set_car      ; cons1 = (head . ?)
  mov %tmp, %sp - 1   ; %tmp -> cons1
  mov %arg0, %%tmp    ; %arg0 = cons1
  mov %tmp, %sp - 3   ; %tmp -> acc
  mov %arg1, %%tmp    ; %arg1 = acc
  gosub *set_cdr      ; cons1 = (head . acc)
  gosub *pop          ; cons1 < S(rest, acc)
  mov %tmp, %sp - 2   ; %tmp -> acc
  mov %%tmp, %ret     ; acc = cons1
  gosub *pop          ; rest < S(acc)
  mov %arg0, %ret
  goto *revappend


;;;;;;;;;;
;;;*eval_form(form, env)
;;;  Translate form and evaluate it. The env is ignored.
;;;;;;;;;;
*eval_form
  mov %eval_count, 0
  mov %arg1, %sym_begin
  gosub *check_syntax
  if %ret == %sharp_t goto *eval_form_begin
  gosub *translate_form
*eval_form_after_translation
  mov %arg0, %ret     ; %arg0 = form
  mov %arg1, %nil
  gosub *debruijn
  mov %arg0, %ret     ; %arg0 = form
  mov %arg1, %nil     ; %arg1 = env
  goto *eval  ; tail call
*eval_form_begin
  gosub *push         ; S(form)
  mov $sarg0, "*translate_begin"
  gosub *translate1   ; S()
  goto *eval_form_after_translation


;;;;;;;;;;
;;;*translate_form(form)
;;;  Translate complex special form into simple special form.
;;;  For example, let form is translated to lambda form.
;;;;;;;;;;
*translate_form
  gosub *get_tag
  if %ret != TAG_CONS : mov %ret, %arg0 : return
  gosub *push         ; S(form)
  gosub *car
  if %ret == %quote : gosub *pop : return
  if %ret == %sym_let mov $sarg0, "*translate_let" : goto *translate1
  if %ret == %sym_letrec mov $sarg0, "*translate_letrec" : goto *translate1
  if %ret == %sym_letstar mov $sarg0, "*translate_letstar" : goto *translate1
  if %ret == %sym_cond mov $sarg0, "*translate_cond" : goto *translate1
  if %ret == %sym_begin mov $sarg0, "*translate_list" : goto *translate1
  if %ret == %sym_and mov $sarg0, "*translate_list" : goto *translate1
  if %ret == %sym_or mov $sarg0, "*translate_list" : goto *translate1
  if %ret == %sym_time mov $sarg0, "*translate_list" : goto *translate1
  if %ret == %sym_if mov $sarg0, "*translate_if" : goto *translate1
  if %ret == %sym_lambda mov $sarg0, "*translate_lambda" : goto *translate1
  if %ret == %sym_define mov $sarg0, "*translate_define" : goto *translate1
  if %ret == %sym_set mov $sarg0, "*translate_list_s1" : goto *translate1
  gosub *pop          ; form < S()
  mov %arg1, %ret     ; %arg1 = form
  mov %arg0, %nil
  gosub *translate_list
  mov %arg0, %ret     ; %arg0 = (nil . form)
  gosub *cdr          ; CDR[(nil . form)]
  return
*translate1  ; $sarg0 = translation function,  S(form)
  gosub *pop          ; form < S()
  mov %arg0, %ret     ; %arg0 = form
  gosub *cdr          ; CDR(form)
  mov %arg1, %ret     ; %arg1 = args
  gosub *car          ; CAR(form)
  mov %arg0, %ret     ; %arg0 = operator
  goto $sarg0  ; tail call

;;; Use for checking invalid inner-define, like (form1 (define ...) form2).
;;; This subroutine just checks if (car form) is define.
;;; If so returns error object, otherwise returns NIL.
;;; This subroutine keeps %arg0
*check_invalid_define
  gosub *push         ; S(form)
  gosub *car          ; CAR(form)
  if %ret == %sym_define goto *check_invalid_define_invalid
  gosub *pop
  mov %arg0, %ret
  mov %ret, %nil
  return
*check_invalid_define_invalid
  mov %current_proc, %sym_define
  mov %arg1, 1
  goto *popn_and_invstx  ; tail call

;;; Always returns NIL.
*check_nothing
  mov %ret, %nil
  return

;;; Translate (begin args) to (begin translated-args).
;;; This is similar to tanrslate_list but it doesn't treat occurrences of
;;; define as an error.
*translate_begin
  mov $sarg0, "*check_nothing"
  gosub *spush        ; SS(check_function)
  goto *translate_list_internal

;;; Translate (op args) to (op translated-args).
;;; This subroutine treats occurences of define as an error because define
;;; forms must be translated to letrec.
*translate_list
  mov $sarg0, "*check_invalid_define"
  gosub *spush        ; SS(check_function)
*translate_list_internal  ; (op, args, toplevel?), SS(check_function)
  gosub *push         ; S(op)
  mov %arg0, %nil
  gosub *push         ; S(nil, op)
  mov %arg0, %arg1    ; %arg0 = list
*translate_list_loop  ; %arg0 = list, S(form_r, op)
  if %arg0 == %nil goto *translate_list_reverse
  gosub *car          ; CAR(list) => head
  mov %tmp, %ret      ; %tmp = head
  gosub *cdr          ; CDR(list) => rest
  mov %arg0, %ret     ; %arg0 = rest
  gosub *push         ; S(rest, form_r, op)
  mov %arg0, %tmp     ; %arg0 = head
  mov %tmp, %ssp - 1 ; %tmp -> check_function
  gosub $%tmp  ; *check_invalid_define or *check_nothing
  if %ret != %nil goto *translate_list_error
  gosub *translate_form
  mov %arg0, %ret     ; %arg0 = head
  gosub *push         ; S(head, rest, form_r, op)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; head < S(rest, form_r, op)
  gosub *push         ; S(cons1, rest, form_r, op)
  mov %arg1, %ret     ; %arg1 = head
  gosub *set_car      ; cons1 = (head . ?)
  mov %tmp, %sp - 1   ; %tmp -> cons1
  mov %arg0, %%tmp    ; %arg0 = cons1
  mov %tmp, %sp - 3   ; %tmp -> form_r
  mov %arg1, %%tmp    ; %arg1 = form_r
  gosub *set_cdr      ; cons1 = (head . form_r)
  gosub *pop          ; cons1 < S(rest, form_r, op)
  mov %arg0, %ret     ; %arg0 = cons1
  mov %tmp, %sp - 2   ; %tmp -> form_r
  mov %%tmp, %arg0    ; form_r = cons1
  gosub *pop          ; rest < S(form_r)
  mov %arg0, %ret     ; %arg0 = rest
  goto *translate_list_loop
*translate_list_reverse  ; S(form_r, op), SS(check_function)
  gosub *pop          ; form_r < S(op)
  mov %arg0, %ret     ; %arg0 = form_r
  gosub *nreverse
  mov %arg0, %ret     ; %arg0 = form
  gosub *push         ; S(form, op)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; form < S(op)
  mov %arg1, %ret     ; %arg1 = form
  gosub *push         ; S(cons1, op)
  gosub *set_cdr      ; cons1 = (? . form)
  mov %tmp, %sp - 1   ; %tmp -> cons1
  mov %arg0, %%tmp    ; %arg0 = cons1
  mov %tmp, %sp - 2   ; %tmp -> op
  mov %arg1, %%tmp    ; %arg1 = op
  gosub *set_car      ; cons1 = (op . form)
  gosub *pop          ; cons1 < S(op)
  sub %sp, 1          ; S()
  sub %ssp, 1         ; SS()
  return
*translate_list_error  ; %ret = error, S(rest, form_r, op), SS(check_function)
  gosub *enclose
  mov %arg0, %ret     ; %arg0 = (error)
  gosub *pop          ; rest < S(form_r, op)
  gosub *pop          ; form_r < S(op)
  gosub *push         ; S((error), op)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; (error) < S(op)
  mov %arg1, %ret     ; %arg1 = (error)
  gosub *set_cdr      ; cons1 = (? error)
  gosub *pop          ; op < S()
  mov %arg1, %ret     ; %arg1 = op
  gosub *set_car      ; cons1 = (op error)
  mov %ret, %arg0     ; %ret = cons1
  sub %ssp, 1         ; SS()
  return

;;; Translate (op skip args) to (op skip translated-args).
*translate_list_s1
  mov %current_proc, %arg0
  gosub *push         ; S(op)
  mov %arg0, %arg1    ; %arg0 = (skip . form)
  gosub *get_tag : if %ret != TAG_CONS mov %arg1, 1 : goto *popn_and_invstx
  gosub *cdr          ; CDR[(skip . form)]
  mov %arg1, %ret     ; %arg1 = form
  gosub *car          ; CAR[(skip . form)]
  mov %arg0, %ret     ; %arg0 = skip
  gosub *translate_list
  mov %arg0, %ret     ; %arg0 = args
  gosub *push         ; S(args, op)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; args < S(op)
  mov %arg1, %ret     ; %arg1 = args
  gosub *push         ; S(cons1, op)
  gosub *set_cdr      ; cons1 = (? . args)
  mov %tmp, %sp - 1   ; %tmp -> cons1
  mov %arg0, %%tmp    ; %arg0 = cons1
  mov %tmp, %sp - 2   ; %tmp -> op
  mov %arg1, %%tmp    ; %arg1 = op
  gosub *set_car      ; cons1 = (op . form)
  gosub *pop          ; cons1 < S(op)
  sub %sp, 1          ; S()
  return

;;; Translate (define (name .  args) . body) into (define name (lambda ...)).
*translate_define
  mov %arg0, %arg1    ; %arg0 = (name0 . body) = rest
  gosub *push         ; S(rest)
  gosub *car          ; CAR[(name0 . body)] => name0
  mov %arg0, %ret     ; %arg0 = name0
  gosub *get_tag
  if %ret != TAG_CONS goto *translate_define_var
  gosub *cdr          ; CDR[(name . args)] => args
  mov %tmp, %ret      ; %tmp = args
  gosub *car          ; CAR[(name . args)] => name
  mov %arg0, %ret     ; %arg0 = name
  gosub *push         ; S(name, rest)
  mov %arg0, %tmp     ; %arg0 = args
  gosub *push         ; S(args, name, rest)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; args < S(name, rest)
  mov %arg1, %ret     ; %arg1 = rest
  gosub *set_car      ; cons1 = (args . ?)
  mov %tmp1, %arg0    ; %tmp1 = cons1
  mov %tmp, %sp - 2   ; %tmp -> rest
  mov %arg0, %%tmp    ; %arg0 = rest
  gosub *cdr          ; CDR[(name0 . body)] => body
  mov %arg1, %ret     ; %arg1 = body
  mov %arg0, %tmp1    ; %arg0 = cons1
  gosub *set_cdr      ; cons1 = (args . body)
  mov %arg1, %arg0    ; %arg1 = cons1
  mov %arg0, %sym_lambda
  gosub *translate_lambda
  mov %arg0, %ret     ; arg0 = lambda-form
  gosub *push         ; S(lambda-form, name, rest)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons2
  gosub *pop          ; lambda-form < S(name, rest)
  mov %arg1, %ret     ; %arg1 = lambda-form
  gosub *set_car      ; cons2 = (lambda-form . ?)
  mov %arg1, %nil
  gosub *set_cdr      ; cons2 = (lambda-form)
  gosub *push         ; S(cons2, name, rest)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons3
  gosub *pop          ; cons2 < S(name, rest)
  mov %arg1, %ret     ; %arg1 = cons2
  gosub *set_cdr      ; cons3 = (? . (lambda-form))
  gosub *pop          ; name < S(rest)
  mov %arg1, %ret     ; %arg1 = name
  gosub *set_car      ; cons3 = (name lambda-form)
  gosub *push         ; S(cons3, rest)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons4
  gosub *pop          ; cons3 < S(rest)
  mov %arg1, %ret     ; %arg1 = cons3
  gosub *set_cdr      ; cons4 = (? . (name lambda-form))
  mov %arg1, %sym_define
  gosub *set_car      ; cons4 = (define name lambda-form)
  sub %sp, 1          ; S()
  return
*translate_define_var
  gosub *pop          ; rest < S()
  mov %arg1, %ret     ; %arg1 = (name0 . body)
  mov %arg0, %sym_define
  goto *translate_list_s1  ; tail call

;;; Translate (lambda args . body).
*translate_lambda
  mov %current_proc, %sym_lambda
  mov %arg0, %arg1    ; %arg0 = (args . body)
  gosub *get_tag : if %ret != TAG_CONS mov %arg1, 0 : goto *popn_and_invstx
  gosub *cdr          ; CDR[(args . body)]
  mov %arg1, %ret     ; %arg1 = body
  gosub *car          ; CAR[(args . body)]
  mov %arg0, %ret     ; %arg0 = args
  gosub *push         ; S(args)
  mov %arg0, %arg1    ; %arg0 = body
  gosub *translate_body
  mov %arg0, %ret     ; %arg0 = body
  gosub *push         ; S(body, args)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; body < S(args)
  mov %arg1, %ret     ; %arg1 = body
  gosub *set_cdr      ; cons1 = (? . body)
  gosub *pop          ; args < S()
  mov %arg1, %ret     ; %arg1 = args
  gosub *set_car      ; cons1 = (args . body)
  gosub *push         ; S(cons1)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons2
  gosub *pop          ; cons1 < S()
  mov %arg1, %ret     ; %arg1 = cons1
  gosub *set_cdr      ; cons2 = (? . (args . body))
  mov %arg1, %sym_lambda
  gosub *set_car      ; cons2 = (lambda args . body)
  mov %ret, %arg0
  return

;;; *check_syntax(form, syntax)
;;; Returns #t if form is (syntax ...).
;;; This subroutine doesn't modify %arg0.
*check_syntax
  gosub *get_tag
  if %ret != TAG_CONS mov %ret, %sharp_f : return
  gosub *car          ; CAR(form)
  if %ret != %arg1 mov %ret, %sharp_f : return
  mov %ret, %sharp_t
  return

;;;*have_begin_in_body(body)
;;; Returns #t if body has begin.
;;; This subroutine is used for inner-define, so it ignores begins which don't
;;; affect inner-define.
*have_begin_in_body
  gosub *get_tag
  if %ret != TAG_CONS mov %ret, %sharp_f : return
  gosub *push         ; S(body)
  gosub *car          ; CAR(body) => head
  mov %arg0, %ret     ; %arg0 = head
  mov %arg1, %sym_begin
  gosub *check_syntax ; Checks if head is (begin ...)
  if %ret == %sharp_t gosub *pop : mov %ret, %sharp_t : return
  mov %arg1, %sym_define
  gosub *check_syntax ; Checks if head is (define ...)
  if %ret == %sharp_f gosub *pop : mov %ret, %sharp_f : return
  gosub *pop          ; body < S()
  mov %arg0, %ret     ; %arg0 = body
  gosub *cdr          ; CDR(body) => rest
  mov %arg0, %ret     ; %arg0 = rest
  goto *have_begin_in_body

;;;*expand_begin_in_body(body)
;;; Expands ((begin A) B (begin C) ...) => (A B C ...).
;;; This subroutine is used for inner-define, so it may ignore begins which
;;; don't affect inner-define.
*expand_begin_in_body
  gosub *push         ; S(body)
  gosub *have_begin_in_body
  if %ret == %sharp_f gosub *pop : return
  gosub *pop          ; body < S()
  mov %arg0, %ret     ; %arg0 = body
  mov %arg1, %nil     ; %arg1 = nil
*expand_begin_in_body_loop  ; %arg0 = body, %arg1 = acc
  if %arg0 == %nil goto *expand_begin_in_body_finish
  gosub *push         ; S(body)
  gosub *car          ; CAR(body) => head
  mov %arg0, %arg1    ; %arg0 = acc
  gosub *push         ; S(acc, body)
  mov %arg0, %ret     ; %arg0 = head
  gosub *push         ; S(head, acc, body)
  mov %arg1, %sym_begin
  gosub *check_syntax ; Check if head is (begin ...)
  if %ret == %sharp_t goto *expand_begin_in_body_begin
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; head < S(acc, body)
  mov %arg1, %ret     ; %arg1 = head
  gosub *set_car      ; cons1 = (head . ?)
  gosub *pop          ; acc < S(body)
  mov %arg1, %ret     ; %arg1 = acc
  gosub *set_cdr      ; cons1 = (head . acc)
  mov %arg1, %arg0    ; %arg1 = cons1
*expand_begin_in_body_next  ; %arg1 = acc, S(body)
  gosub *pop          ; body < S()
  mov %arg0, %ret     ; %arg0 = body
  gosub *cdr          ; CDR(body) => rest
  mov %arg0, %ret     ; %arg0 = rest
  goto *expand_begin_in_body_loop
*expand_begin_in_body_begin  ; S(head, acc, body)
  gosub *pop          ; head < S(acc, body)
  mov %arg0, %ret     ; %arg0 = head = (begin A B ...)
  gosub *cdr          ; CDR(head) => (A B ...)
  mov %arg0, %ret     ; %arg0 = (A B ...)
  gosub *expand_begin_in_body  ; expands (A B ...) recursively.
  mov %arg0, %ret     ; %arg0 = expanded (A B ...)
  gosub *revappend ; %ret = (... B A . acc), S(body)
  mov %arg1, %ret     ; %arg1 = new acc
  goto *expand_begin_in_body_next
*expand_begin_in_body_finish  ; %arg1 = acc
  mov %arg0, %arg1    ; %arg0 = acc
  goto *nreverse  ; tail call

;;; %ret = form
;;; form -> (form)
*enclose
  mov %arg0, %ret
  gosub *push
  gosub *create_cons
  mov %arg0, %ret
  mov %arg1, %nil
  gosub *set_cdr
  gosub *pop
  mov %arg1, %ret
  gosub *set_car
  mov %ret, %arg0
  return

;;;*translate_body(form)
;;; Translate (form1 form2 ...).
;;; Return an error object with %current_proc if %arg0 isn't list.
*translate_body
  if %arg0 == %nil mov %ret, %nil : return
  gosub *get_tag
  if %ret != TAG_CONS mov %arg1, 0 : gosub *popn_and_invstx : goto *enclose
  gosub *expand_begin_in_body
  mov %arg0, %ret
  gosub *car          ; CAR(body) => form1
  gosub *push         ; S(body)
  mov %arg0, %ret     ; %arg0 = form1
  mov %arg1, %sym_define
  gosub *check_syntax
  if %ret != %sharp_t goto *translate_body_normally
  gosub *pop          ; body < S()
  mov %arg0, %ret     ; %arg0 = body
  gosub *translate_inner_define
  goto *enclose  ; tail call
*translate_body_normally  ; S(body)
  gosub *pop          ; body < S()
  mov %arg1, %ret     ; %arg1 = body
  mov %arg0, %nil
  gosub *translate_list
  mov %arg0, %ret
  gosub *cdr
  return

;;;*translate_inner_define(form)
;;; Translate ((define ...) ... . body) to (letrec binds ...).
;;; Form has at least one define form.
;;; Order of binds are reversed but letrec ignores that.
*translate_inner_define
  gosub *push         ; S(form)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  mov %arg1, %sym_letrec
  gosub *set_car      ; cons1 = (letrec . ?)
  gosub *push         ; S(cons1, form)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons2
  mov %arg1, %nil
  gosub *set_car      ; cons2 = (nil . ?)
  gosub *push         ; S(cons2, cons1, form)
  mov %arg1, %arg0    ; %arg1 = cons2
  mov %tmp, %sp - 2   ; %tmp -> cons1
  mov %arg0, %%tmp    ; %arg0 = cons1
  gosub *set_cdr      ; cons1 = (letrec . form2)
  mov %tmp, %sp - 3   ; %tmp -> form
  mov %arg0, %%tmp    ; %arg0 = form
*translate_inner_define_loop  ; %arg0 = form, S(cons2, cons1, form)
  if %arg0 == %nil goto *translate_inner_define_finish
  gosub *get_tag
  if %ret != TAG_CONS mov %arg1, 3 : goto *popn_and_invstx
  gosub *car          ; CAR(form)
  mov %tmp, %arg0     ; %tmp = form
  mov %arg0, %ret     ; %arg0 = form1
  gosub *get_tag
  if %ret != TAG_CONS goto *translate_inner_define_finish
  gosub *car
  if %ret != %sym_define goto *translate_inner_define_finish
  gosub *cdr          ; CDR[(define name1 . body1)]
  mov %arg0, %ret     ; %arg0 = (name1 . body1)
  gosub *car          ; CAR[(name1 . body1)]
  mov %tmp, %ret      ; %tmp = name1
  gosub *cdr          ; CDR[(name1 . body1)]
  mov %arg0, %ret     ; %arg0 = body1
  gosub *push         ; S(body1, cons2, cons1, form)
  mov %arg0, %tmp     ; %arg0 = name1
  gosub *push         ; S(name1, body1, cons2, cons1, form)
  gosub *get_tag
  if %ret == TAG_CONS goto *translate_inner_define_lambda
  mov %tmp, %sp - 2   ; %tmp -> body1
  mov %arg0, %%tmp    ; %arg0 = body1
  gosub *car          ; CAR(body1)
  mov %%tmp, %ret     ; S(name1, val1, cons2, cons1, form)
*translate_inner_define_add  ; S(name1, val1, cons2, cons1, form)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons3
  gosub *pop          ; name1 < S(val1, cons2, cons1, form)
  mov %arg1, %ret     ; %arg1 = name1
  gosub *set_car      ; cons3 = (name1 . ?)
  gosub *push         ; S(cons3, val1, cons2, cons1, form)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons4
  mov %arg1, %nil
  gosub *set_cdr      ; cons4 = (? . nil)
  mov %tmp, %sp - 2   ; %tmp -> val1
  mov %arg1, %%tmp    ; %arg1 = val1
  gosub *set_car      ; cons4 = (val1)
  mov %arg1, %arg0    ; %arg1 = cons4
  gosub *pop          ; cons3 < S(val1, cons2, cons1, form)
  mov %arg0, %ret     ; %arg0 = cons3
  gosub *set_cdr      ; cons3 = (name1 val1)
  gosub *pop          ; val1 < S(cons2, cons1, form)
  gosub *push         ; S(cons3, cons2, cons1, form)
  gosub *create_cons
  mov %tmp1, %ret     ; %tmp1 = cons5
  mov %tmp, %sp - 2   ; %tmp -> cons2
  mov %arg0, %%tmp    ; %arg0 = cons2
  gosub *car          ; CAR(cons2)
  mov %arg1, %ret     ; %arg1 = binds
  mov %arg0, %tmp1    ; %arg0 = cons5
  gosub *set_cdr      ; cons5 = (? . binds)
  gosub *pop          ; cons3 < S(cons2, cons1, form)
  mov %arg1, %ret     ; %arg1 = cons3
  gosub *set_car      ; cons5 = ((name1 val1) . binds)
  mov %arg1, %arg0    ; %arg1 = cons5
  mov %tmp, %sp - 1   ; %tmp -> cons2
  mov %arg0, %%tmp    ; %arg0 = cons2
  gosub *set_car      ; Update binds
  mov %tmp, %sp - 3   ; %tmp -> form
  mov %arg0, %%tmp    ; %arg0 = form
  gosub *cdr          ; CDR(form)
  mov %tmp1, %ret     ; %tmp1 = CDR(form)
  mov %%tmp, %tmp1    ; form = CDR(form)
  mov %arg0, %%tmp    ; %arg0 = form
  goto *translate_inner_define_loop
*translate_inner_define_finish  ; S(cons2, cons1, form)
  gosub *pop          ; cons2 < S(cons1, form)
  mov %arg0, %ret     ; %arg0 = cons2
  mov %tmp, %sp - 2   ; %tmp -> form
  mov %arg1, %%tmp    ; %arg1 = form
  gosub *set_cdr      ; cons2 = (binds . form)
  gosub *pop          ; cons1 < S(form)
  mov %arg0, %ret     ; %tmp = (letrec binds . form)
  gosub *pop          ; form < S()
  gosub *cdr
  mov %arg1, %ret     ; %arg1 = (binds . form)
  gosub *car
  mov %arg0, %ret     ; %arg0 = letrec
  goto *translate_letrec  ; tail call

*translate_inner_define_lambda  ; S(name1, body1, cons2, cons1, form)
  gosub *pop          ; name1 < S(body1, cons2, cons1, form)
  mov %arg0, %ret     ; %arg0 = name1
  gosub *cdr          ; CDR(name1) => args
  mov %tmp, %ret      ; %tmp = args
  gosub *car          ; CAR(name1) => sym1
  mov %arg0, %ret     ; %arg0 = sym1
  gosub *push         ; S(sym1, body1, cons2, cons1, form)
  mov %arg0, %tmp     ; %arg0 = args
  gosub *push         ; S(args, sym1, body1, cons2, cons1, form)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons3
  gosub *pop          ; args < S(sym1, body1, cons2, cons1, form)
  mov %arg1, %ret     ; %arg1 = args
  gosub *set_car      ; cons3 = (args . ?)
  mov %tmp, %sp - 2   ; %tmp -> body1
  mov %arg1, %%tmp    ; %arg1 = body1
  gosub *set_cdr      ; cons3 = (args . body1)
  gosub *push         ; S(cons3, sym1, body1, cons2, cons1, form)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons4
  gosub *pop          ; cons3 < S(sym1, body1, cons2, cons1, form)
  mov %arg1, %ret     ; %arg1 = cons3
  gosub *set_cdr      ; cons4 = (? . (args . body))
  mov %arg1, %sym_lambda
  gosub *set_car      ; cons4 = (lambda args . body)
  mov %tmp, %sp - 2   ; %tmp -> body1
  mov %%tmp, %arg0    ; body1 = (lambda arg . body)
  goto *translate_inner_define_add

;;; Translate (exp1 ...) to (begin exp1 ...) and (exp) to exp.
*translate_to_1exp
  gosub *cdr          ; CDR(form)
  if %ret == %nil goto *translate_to_1exp_1exp
  mov %arg1, %arg0    ; %arg1 = form
  mov %arg0, %sym_begin
  goto *translate_list  ; tail call
*translate_to_1exp_1exp
  gosub *car          ; CAR[(exp)] => exp
  mov %arg0, %ret     ; %arg0 = exp
  goto *translate_form  ; tail call

;;; Checks syntax.
*translate_if
  mov %current_proc, %sym_if
  mov %arg0, %arg1    ; %arg0 = args
  if %arg0 == %nil goto *translate_if_invalid
  gosub *cdr          ; CDR(args)
  mov %arg0, %ret     ; %arg0 = CDR(args)
  if %arg0 == %nil goto *translate_if_invalid
  gosub *cdr          ; CDDR(args)
  mov %arg0, %ret     ; %arg0 = CDDR(args)
  if %arg0 == %nil goto *translate_if_valid
  gosub *cdr          ; CDDDR(args)
  mov %arg0, %ret     ; %arg0 = CDDDR(args)
  if %arg0 == %nil goto *translate_if_valid
*translate_if_invalid
  mov %arg1, 0
  goto *popn_and_invstx  ; tail call
*translate_if_valid
  mov %arg0, %sym_if
  goto *translate_list  ; tail call

;;; Translate (cond (test . body) ...) to (if test (begin . body) ...).
*translate_cond
  mov %current_proc, %sym_cond
  mov %arg0, %nil
  gosub *push         ; S(nil)
  mov %arg0, %arg1    ; %arg0 = clauses
  gosub *get_tag
  if %ret != TAG_CONS mov %arg1, 1 : goto *popn_and_invstx
  gosub *reverse
  mov %arg0, %ret     ; %arg0 = clauses
  gosub *translate_cond_else
*translate_cond_loop  ; %arg0 = clauses, S(form)
  if %arg0 == %nil gosub *pop : return
  gosub *car          ; CAR(clauses)
  mov %tmp, %ret      ; %tmp = caluse
  gosub *cdr          ; CDR(clauses)
  mov %arg0, %ret     ; %arg0 = rest
  gosub *push         ; S(clauses, form)
  mov %arg0, %tmp     ; %arg0 = clause
  gosub *get_tag : if %ret != TAG_CONS mov %arg1, 2 : goto *popn_and_invstx
  gosub *cdr          ; CDR(clause)
  mov %tmp, %ret      ; %tmp = body
  gosub *car          ; CAR(clause)
  mov %arg0, %ret     ; %arg0 = test
  gosub *push         ; S(test, clauses, form)
  mov %arg0, %tmp     ; %arg0 = body
  gosub *translate_to_1exp
  mov %arg0, %ret     ; %arg0 = exp
  gosub *push         ; S(exp, test, clauses, form)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; exp < S(test, clauses, form)
  gosub *push         ; S(cons1, test, clauses, form)
  mov %arg1, %ret     ; %arg1 = exp
  gosub *set_car      ; cons1 = (exp . ?)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons2
  gosub *push         ; S(cons2, cons1, test, clauses, form)
  mov %tmp, %sp - 5   ; %tmp -> form
  mov %arg1, %%tmp    ; %arg1 = form
  gosub *set_car      ; cons2 = (form . ?)
  mov %tmp, %sp - 1   ; %tmp -> cons2
  mov %arg0, %%tmp    ; %arg0 = cons2
  mov %arg1, %nil
  gosub *set_cdr      ; cons2 = (form)
  gosub *pop          ; cons2 < S(cons1, test, clauses, form)
  mov %arg1, %ret     ; %arg1 = cons2
  mov %tmp, %sp - 1   ; %tmp -> cons1
  mov %arg0, %%tmp    ; %arg0 = cons1
  gosub *set_cdr      ; cons1 = (exp form)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons3
  gosub *pop          ; cons1 < S(test, clauses, form)
  mov %arg1, %ret     ; %arg1 = cons1
  gosub *push         ; S(cons3, test, clauses, form)
  gosub *set_cdr      ; cons3 = (? . (exp form)
  mov %tmp, %sp - 2   ; %tmp -> test
  mov %arg0, %%tmp    ; %arg0 = test
  gosub *translate_form
  mov %arg1, %ret     ; %arg1 = test
  mov %tmp, %sp - 1   ; %tmp -> cons3
  mov %arg0, %%tmp    ; %arg0 = cons3
  gosub *set_car      ; cons3 = (test exp form)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons4
  gosub *pop          ; cons3 < S(test, clauses, form)
  mov %arg1, %ret     ; %arg1 = cons3
  gosub *pop          ; test < S(clauses, form)
  gosub *push         ; S(cons4, clauses, form)
  gosub *set_cdr      ; cons4 = (? . (test exp form))
  mov %tmp, %sp - 1   ; %tmp -> cons4
  mov %arg0, %%tmp    ; %arg0 = cons4
  mov %arg1, %sym_if
  gosub *set_car      ; cons4 = (if test exp form)
  gosub *pop          ; cons4 < S(claues, form)
  mov %tmp, %sp - 2   ; %tmp -> form
  mov %%tmp, %ret     ; form = (if test exp form)
  gosub *pop          ; clauses < S(form)
  mov %arg0, %ret     ; %arg0 = clauses
  goto *translate_cond_loop
*translate_cond_else  ; %arg0 = clauses, S(nil)
  gosub *car          ; CAR(clauses) => clause
  gosub *push         ; S(clauses, nil)
  mov %arg0, %ret     ; %arg0 = clause
  gosub *get_tag
  if %ret != TAG_CONS gosub *pop : mov %arg0, %ret : return
  gosub *car          ; CAR[(test . body)] => test
  if %ret != %sym_else gosub *pop : mov %arg0, %ret : return
  gosub *cdr          ; CDR[(test . body)] => body
  mov %arg0, %ret     ; %arg0 = body
  gosub *translate_to_1exp
  mov %arg0, %ret     ; %arg0 = exp
  gosub *pop          ; clauses < S(nil)
  mov %tmp, %ret      ; %tmp = clauses
  gosub *pop          ; nil < S()
  gosub *push         ; S(exp)
  mov %arg0, %tmp     ; %arg0 = clauses
  gosub *cdr          ; CDR(clauses)
  mov %arg0, %ret     ; %arg0 = CDR(clauses)
  return

;;; Translate (let binds body) to ((lambda ...) ...).
*translate_let
  mov %current_proc, %sym_let
  mov %arg0, %arg1    ; %arg0 = (binds . body)
  if %arg0 == %nil gosub *too_few_arg0 : mov %ret, %arg0 : return
  gosub *cdr          ; CDR[(binds . body)]
  mov %tmp, %ret      ; %tmp = body
  gosub *car          ; CAR[(binds . body)]
  mov %arg0, %ret     ; %arg0 = binds
  gosub *push         ; S(binds)
  mov %arg0, %tmp     ; %arg0 = body
  gosub *translate_body
  mov %arg0, %ret     ; %arg0 = body
  gosub *pop          ; binds < S()
  mov %tmp, %ret      ; %tmp = binds
  gosub *push         ; S(body)
  mov %arg0, %tmp     ; %arg0 = binds
  gosub *split_let_binds  ; S(fargs, aargs, body)
  mov %arg0, %ret     ; %arg0 = split result (error or not)
  gosub *get_tag : if %ret == TAG_ERROR : mov %ret, %arg0 : return
*translate_let_create_lambda_form
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *push         ; S(cons1, fargs, aargs, body)
  mov %arg1, %sym_lambda
  gosub *set_car      ; cons1 = (lambda . ?)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons2
  gosub *push         ; S(cons2, cons1, fargs, aargs, body)
  mov %tmp, %sp - 3   ; %tmp -> fargs
  mov %arg1, %%tmp    ; %arg1 = fargs
  gosub *set_car      ; cons2 = (fargs . ?)
  mov %tmp, %sp - 1   ; %tmp -> cons2
  mov %arg0, %%tmp    ; %arg0 = cons2
  mov %tmp, %sp - 5   ; %tmp -> body
  mov %arg1, %%tmp    ; %arg1 = body
  gosub *set_cdr      ; cons2 = (fargs . body)
  mov %tmp, %sp - 2   ; %tmp -> cons1
  mov %arg0, %%tmp    ; %arg0 = cons1
  gosub *pop          ; cons2 < S(cons1, fargs, aargs, body)
  mov %arg1, %ret     ; %arg1 = cons2
  gosub *set_cdr      ; cons1 = (lambda fargs . body)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons3
  gosub *push         ; S(cons3, cons1, fargs, aargs, body)
  mov %tmp, %sp - 2   ; %tmp -> cons1
  mov %arg1, %%tmp    ; %arg1 = cons1
  gosub *set_car      ; cons3 = ((lambda ...) . ?)
  mov %tmp, %sp - 1   ; %tmp -> cons3
  mov %arg0, %%tmp    ; %arg0 = cons3
  mov %tmp, %sp - 4   ; %tmp -> aargs
  mov %arg1, %%tmp    ; %arg1 = aargs
  gosub *set_cdr      ; cons3 = ((lambda ...) . args)
  gosub *pop          ; cons3 < S(cons1, fargs, aargs, body)
  sub %sp, 4          ; S()
  return

;;; Translate (let* binds body) to (let bind (let bind ...))
*translate_letstar
  mov %current_proc, %sym_letstar
  mov %arg0, %arg1    ; %arg0 = (binds . body)
  if %arg0 == %nil gosub *too_few_arg0 : mov %ret, %arg0 : return
  gosub *car          ; CAR[(binds . body)]
  mov %tmp, %ret      ; %tmp = binds
  if %tmp == %nil goto *translate_let  ; tail call
  gosub *cdr          ; CDR[(binds . body)]
  mov %arg0, %ret     ; %arg0 = body
  gosub *push         ; S(body)
  mov %arg0, %tmp     ; %arg0 = binds
  gosub *reverse
  mov %arg0, %ret     ; %arg0 = binds
*translate_letstar_loop  ; S(body)
  gosub *get_tag : if %ret != TAG_CONS mov %arg1, 1 : goto *popn_and_invstx
  gosub *car          ; CAR(binds)
  mov %tmp, %ret      ; %tmp = bind
  gosub *cdr          ; CDR(binds)
  mov %arg0, %ret     ; %arg0 = CDR(binds)
  gosub *push         ; S(binds, body)
  mov %arg0, %tmp     ; %arg0 = bind
  gosub *push         ; S(bind, binds, body)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; bind < S(binds, body)
  mov %arg1, %ret     ; %arg1 = bind
  gosub *push         ; S(cons1, binds, body)
  gosub *set_car      ; cons1 = (bind . ?)
  mov %tmp, %sp - 1   ; %tmp -> cons1
  mov %arg0, %%tmp    ; %arg0 = cons1
  mov %arg1, %nil
  gosub *set_cdr      ; cons1 = (bind)
  gosub *create_cons
  mov %arg0, %ret     ; cons2
  gosub *pop          ; cons1 < S(binds, body)
  mov %arg1, %ret     ; %arg1 = cons1
  gosub *push         ; S(cons2, binds, body)
  gosub *set_car      ; cons2 = ((bind))
  mov %tmp, %sp - 1   ; %tmp -> cons2
  mov %arg0, %%tmp    ; %arg0 = cons2
  mov %tmp, %sp - 3   ; %tmp -> body
  mov %arg1, %%tmp    ; %arg1 = body
  gosub *set_cdr      ; cons2 = ((bind) . body)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons3
  gosub *pop          ; cons2 < S(binds, body)
  mov %arg1, %ret     ; %arg1 = cons2
  gosub *push         ; S(cons3, binds, body)
  gosub *set_cdr      ; cons3 = (? (bind) . body)
  mov %tmp, %sp - 1   ; %tmp -> cons3
  mov %arg0, %%tmp    ; %arg0 = cons3
  mov %arg1, %sym_let
  gosub *set_car      ; cons3 = (let (bind) . body)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons4
  gosub *pop          ; cons3 < S(binds, body)
  mov %arg1, %ret     ; %arg1 = cons3
  gosub *push         ; S(cons4, binds, body)
  gosub *set_car      ; cons4 = (cons3 . ?)
  mov %tmp, %sp - 1   ; %tmp -> cons4
  mov %arg0, %%tmp    ; %arg0 = cons4
  mov %arg1, %nil
  gosub *set_cdr      ; cons4 = (cons3)
  gosub *pop          ; cons4 < S(binds, body)
  mov %tmp, %sp - 2   ; %tmp -> body
  mov %%tmp, %ret     ; body = cons4
  gosub *pop          ; binds < S(body)
  mov %arg0, %ret
  if %arg0 == %nil goto *translate_letstar_finish
  goto *translate_letstar_loop
*translate_letstar_finish
  gosub *pop          ; body < S()
  mov %arg0, %ret
  gosub *car  ; body is enclosed with a cons
  mov %arg0, %ret     ; %arg0 = (let . args)
  gosub *cdr
  mov %arg1, %ret     ; %arg1 = args
  gosub *car
  mov %arg0, %ret     ; %arg0 = let
  goto *translate_let

;;; Translate (letrec binds body) to ((lambda (...) (set! ...) ...) ...).
*translate_letrec
  mov %current_proc, %sym_letrec
  mov %arg0, %arg1    ; %arg0 = (binds . body)
  if %arg0 == %nil gosub *too_few_arg0 : mov %ret, %arg0 : return
  gosub *cdr          ; CDR[(binds . body)]
  mov %tmp, %ret      ; %tmp = body
  gosub *car          ; CAR[(binds . body)]
  mov %arg0, %ret     ; %arg0 = binds
  gosub *push         ; S(binds)
  mov %arg0, %tmp     ; %arg0 = body
  gosub *translate_body
  mov %arg0, %ret     ; %arg0 = body
  gosub *pop          ; binds < S()
  mov %tmp, %ret      ; %tmp = binds
  gosub *push         ; S(body)
  mov %arg0, %tmp     ; %arg0 = binds
  gosub *split_let_binds  ; S(fargs, aargs, body)
  mov %arg0, %ret     ; %arg0 = split result (error or not)
  gosub *get_tag : if %ret == TAG_ERROR : mov %ret, %arg0 : return
  gosub *translate_letrec_push_set
  mov %tmp, %sp - 2   ; %tmp -> aargs
  mov %arg0, %%tmp    ; %arg0 = aargs
  gosub *translate_letrec_gennil
  mov %tmp, %sp - 2   ; %tmp -> aargs
  mov %%tmp, %ret     ; %aargs = nil-list
  goto *translate_let_create_lambda_form
*translate_letrec_push_set  ; S(fargs, aargs, body)
  mov %tmp, %sp - 2   ; %tmp -> aargs
  mov %arg0, %%tmp    ; %arg0 = aargs
  gosub *push         ; S(aargs1, fargs, aargs, body)
  mov %tmp, %sp - 2   ; %tmp -> fargs
  mov %arg0, %%tmp    ; %arg0 = fargs
  gosub *push         ; S(fargs1, aargs1, fargs, aargs, body)
*translate_letrec_push_set_loop
  mov %tmp, %sp - 2   ; %tmp -> aargs1
  mov %arg0, %%tmp    ; %arg0 = aargs1
  if %arg0 == %nil goto *translate_letrec_push_set_finish
  gosub *cdr          ; CDR(aargs1)
  mov %tmp, %sp - 2   ; %tmp -> aargs1
  mov %%tmp, %ret     ; aargs1 = CDR(aargs1)
  gosub *car          ; CAR(aargs1)
  mov %arg0, %ret     ; %arg0 = aarg
  gosub *push         ; S(aarg, fargs1, aargs1, fargs, aargs, body)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; aarg < S(fargs1, aargs1, fargs, aargs, body)
  mov %arg1, %ret     ; %arg1 = aarg
  gosub *push         ; S(cons1, fargs1, aargs1, fargs, aargs, body)
  gosub *set_car      ; cons1 = (aarg . ?)
  mov %tmp, %sp - 1   ; %tmp -> cons1
  mov %arg0, %%tmp    ; %arg0 = cons1
  mov %arg1, %nil
  gosub *set_cdr      ; cons1 = (aarg)
  mov %tmp, %sp - 2   ; %tmp -> fargs1
  mov %arg0, %%tmp    ; %arg0 = fargs1
  gosub *cdr          ; CDR(fargs1)
  mov %tmp, %sp - 2   ; %tmp -> fargs1
  mov %%tmp, %ret     ; fargs1 = CDR(fargs1)
  gosub *car          ; CAR(fargs1)
  mov %arg0, %ret     ; %arg0 = farg
  gosub *push         ; S(farg, cons1, fargs1, aargs1, fargs, aargs, body)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons2
  gosub *pop          ; farg < S(cons1, fargs1, aargs1, fargs, aargs, body)
  mov %arg1, %ret     ; %arg1 = farg
  gosub *push         ; S(cons2, cons1, fargs1, aargs1, fargs, aargs, body)
  gosub *set_car      ; cons2 = (farg . ?)
  gosub *pop          ; cons2 < S(cons1, fargs1, aargs1, fargs, aargs, body)
  mov %arg0, %ret     ; %arg0 = cons2
  gosub *pop          ; cons1 < S(fargs1, aargs1, fargs, aargs, body)
  mov %arg1, %ret     ; %arg1 = cons1
  gosub *push         ; S(cons2, fargs1, aargs1, fargs, aargs, body)
  gosub *set_cdr      ; cons2 = (farg aarg)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons3
  gosub *pop          ; cons2 < S(fargs1, aargs1, fargs, aargs, body)
  mov %arg1, %ret     ; %arg1 = cons2
  gosub *push         ; S(cons3, fargs1, aargs1, fargs, aargs, body)
  gosub *set_cdr      ; cons3 = (? . (farg aarg))
  mov %tmp, %sp - 1   ; %tmp -> cons3
  mov %arg0, %%tmp    ; %arg0 = cons3
  mov %arg1, %sym_set
  gosub *set_car      ; cons3 = (set! farg aarg)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons4
  gosub *pop          ; cons3 < S(fargs1, aargs1, fargs, aargs, body)
  mov %arg1, %ret     ; %arg1 = cons3
  gosub *push         ; S(cons4, fargs1, aargs1, fargs, aargs, body)
  gosub *set_car      ; cons4 = ((set! ...) . ?)
  mov %tmp, %sp - 1   ; %tmp -> cons4
  mov %arg0, %%tmp    ; %arg0 = cons4
  mov %tmp, %sp - 6   ; %tmp -> body
  mov %arg1, %%tmp    ; %arg1 = body
  gosub *set_cdr      ; cons4 = (set! ...) . body)
  gosub *pop          ; cons4 < S(fargs1, aargs1, fargs, aargs, body)
  mov %tmp, %sp - 5   ; %tmp -> body
  mov %%tmp, %ret     ; body = cons4
  goto *translate_letrec_push_set_loop
*translate_letrec_push_set_finish
  sub %sp, 2          ; S(fargs, aargs, body)
  return

*translate_letrec_gennil  ; %arg0 = list
  mov %tmp, %arg0     ; %tmp = list
  mov %arg0, %nil
  gosub *push         ; S(nil)
  mov %arg0, %tmp     ; %arg0 = list
*translate_letrec_gennil_loop  ; S(acc)
  if %arg0 == %nil gosub *pop : return
  gosub *cdr          ; CDR(list)
  mov %arg0, %ret     ; %arg0 = rest
  gosub *push         ; S(rest, acc)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  mov %arg1, %nil
  gosub *push         ; S(cons1, rest, acc)
  gosub *set_car      ; cons1 = (nil . ?)
  mov %tmp, %sp - 1   ; %tmp -> cons1
  mov %arg0, %%tmp    ; %arg0 = cons1
  mov %tmp, %sp - 3   ; %tmp -> acc
  mov %arg1, %%tmp    ; %arg1 = acc
  gosub *set_cdr      ; cons1 = (nil . acc)
  gosub *pop          ; cons1 < S(rest, acc)
  mov %tmp, %sp - 2   ; %tmp -> acc
  mov %%tmp, %ret     ; acc = cons1
  gosub *pop          ; rest < S(acc)
  mov %arg0, %ret     ; %arg0 = rest
  goto *translate_letrec_gennil_loop


;;;;;;;;;;
;;;*split_let_binds(binds)
;;;  Split a let-style binds list into formal arguments and actual arguments.
;;;  Actual arguments are translated.
;;;  Two arguments lists are put on stack like S(fargs, aargs).
;;;  Return an error object if binds list is invalid. The error message is
;;;  generated using %current_proc.
;;;  Example: ((a 1)(b 2)) -> (a b), (1 2)
;;;;;;;;;;
*split_let_binds
  mov %tmp, %arg0     ; %tmp = binds
  mov %arg0, %nil
  gosub *push         ; S(nil)
  gosub *push         ; S(nil, nil)
  mov %arg0, %tmp     ; %arg0 = binds
*split_let_binds_loop  ; S(fargs_r, aargs_r)
  if %arg0 == %nil goto *split_let_binds_reverse
  gosub *get_tag : if %ret != TAG_CONS goto *pop2_and_invstx
  gosub *car          ; CAR[(bind . binds)]
  mov %tmp, %ret      ; %tmp = bind
  gosub *push         ; S(binds, fargs_r, aargs_r)
  mov %arg0, %tmp     ; %arg0 = bind
  gosub *get_tag : if %ret != TAG_CONS mov %arg1, 3 goto *popn_and_invstx
  gosub *car          ; CAR[(farg aarg)]
  mov %tmp, %ret      ; %tmp = farg
  gosub *cdr          ; CDR[(farg aarg)]
  mov %arg0, %ret     ; %arg0 = (aarg)
  gosub *car          ; CAR[(aarg)]
  mov %tmp1, %ret     ; %tmp1 = aarg
  mov %arg0, %tmp     ; %arg0 = farg
  gosub *push         ; S(farg, binds, fargs_r, aargs_r)
  mov %arg0, %tmp1    ; %arg0 = aarg
  gosub *translate_form
  mov %arg0, %ret     ; %arg0 = aarg
  gosub *pop          ; farg < S(binds, fargs_r, aargs_r)
  mov %tmp, %ret      ; %tmp = farg
  gosub *push         ; S(aarg, binds, fargs_r, aargs_r)
  mov %arg0, %tmp     ; %arg0 = farg
  gosub *push         ; S(farg, aarg, binds, fargs_r, aargs_r)
  ;; Push farg to fargs_r
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; farg < S(aarg, binds, fargs_r, aargs_r)
  mov %arg1, %ret     ; %arg1 = farg
  gosub *push         ; S(cons1, aarg, binds, fargs_r, aargs_r)
  gosub *set_car      ; cons1 = (farg . ?)
  mov %tmp, %sp - 1   ; %tmp -> cons1
  mov %arg0, %%tmp    ; %arg0 = cons1
  mov %tmp, %sp - 4   ; %tmp -> fargs_r
  mov %arg1, %%tmp    ; %arg1 = fargs_r
  gosub *set_cdr      ; cons1 = (farg . fargs_r)
  gosub *pop          ; cons1 < S(aarg, binds, fargs_r, aargs_r)
  mov %tmp, %sp - 3   ; %tmp -> fargs_r
  mov %%tmp, %ret     ; fargs_r = cons1
  ;; Push farg to aargs_r
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons2
  gosub *pop          ; aarg < S(binds, fargs_r, aargs_r)
  mov %arg1, %ret     ; %arg1 = aarg
  gosub *push         ; S(cons2, binds, aargs_r, aargs_r)
  gosub *set_car      ; cons2 = (aarg . ?)
  mov %tmp, %sp - 1   ; %tmp -> cons2
  mov %arg0, %%tmp    ; %arg0 = cons2
  mov %tmp, %sp - 4   ; %tmp -> aargs_r
  mov %arg1, %%tmp    ; %arg1 = aargs_r
  gosub *set_cdr      ; cons2 = (aarg . aargs_r)
  gosub *pop          ; cons2 < S(binds, fargs_r, aargs_r)
  mov %tmp, %sp - 3   ; %tmp -> aargs_r
  mov %%tmp, %ret     ; aargs_r = cons2
  gosub *pop          ; binds < S(fargs_r, aargs_r)
  mov %arg0, %ret     ; %arg0 = binds
  gosub *cdr          ; CDR(binds)
  mov %arg0, %ret     ; %arg0 = CDR(binds)
  goto *split_let_binds_loop
*split_let_binds_reverse  ; S(fargs_r, aargs_r)
  mov %tmp, %sp - 1   ; %tmp -> fargs_r
  mov %arg0, %%tmp    ; %arg0 = fargs_r
  gosub *nreverse     ; nreverse(fargs_r)
  mov %tmp, %sp - 1   ; %tmp -> fargs_r
  mov %%tmp, %ret     ; S(fargs, aargs_rev)
  mov %tmp, %sp - 2   ; %tmp -> aargs_r
  mov %arg0, %%tmp    ; %arg0 = aargs_r
  gosub *nreverse     ; nreverse(aargs_r)
  mov %tmp, %sp - 2   ; %tmp -> aargs_r
  mov %%tmp, %ret     ; S(fargs, aargs)
  mov %ret, %sharp_t
  return


;;;;;;;;;;
;;;*debruijn(form, env)
;;;  Translate symbol which represents local variable into de Bruijn index.
;;;  For example, (lambda (x) x) is translated into (lambda (x) <0,0>)
;;;  env is a list of formal arguments list, like ((a b) c (d . e)).
;;;  This subroutine modify form destructively.
;;;;;;;;;;
*debruijn
  ;; We don't support the variable whose name is NIL so far.
  ;; Maybe we will support it in the future.
  if %arg0 == %nil mov %ret, %nil : return
  gosub *get_tag
  if %ret == TAG_SYMBOL goto *debruijn_symbol
  if %ret != TAG_CONS : mov %ret, %arg0 : return
  gosub *car
  if %ret == %quote : mov %ret, %arg0 : return
  if %ret == %sym_lambda goto *debruijn_lambda
  if %ret == %sym_define goto *debruijn_skip2
*debruijn_start  ; %arg0 = form, %arg1 = env
  gosub *push         ; S(form0)
*debruijn_loop  ; %arg0 = form, %arg1 = env, S(form0)
  if %arg0 == %nil goto *debruijn_finish
  mov %tmp, %arg0     ; %tmp = form
  mov %arg0, %arg1    ; %arg0 = env
  gosub *push         ; S(env, form0)
  mov %arg0, %tmp     ; %arg0 = form
  gosub *push         ; S(form, env, form0)
  gosub *car          ; CAR(form) => form1
  mov %arg0, %ret     ; %arg0 = form1
  gosub *push         ; S(form1, form, env, form0)
  gosub *debruijn     ; debruijn(form1, env)
  mov %arg1, %ret     ; %ret = d-form1
  gosub *pop          ; form1 < S(form, env, form0)
  if %arg1 == %ret goto *debruijn_next
  mov %tmp, %sp - 1   ; %tmp -> form
  mov %arg0, %%tmp    ; %arg0 = form
  gosub *set_car      ; form = (d-form1 ...)
*debruijn_next  ; S(form, env, form0)
  gosub *pop          ; form < S(env, form0)
  mov %arg0, %ret     ; %arg0 = form
  gosub *cdr          ; CDR(form)
  mov %tmp1, %arg0    ; %tmp1 = form
  mov %arg0, %ret     ; %arg0 = CDR(form)
  gosub *get_tag
  if %ret != TAG_CONS mov %arg0, %tmp1 : goto *debruijn_cdr
  gosub *pop          ; env < S(form0)
  mov %arg1, %ret     ; %arg1 = env
  goto *debruijn_loop
*debruijn_cdr  ; %arg0 = form, S(env, form0)
  gosub *cdr          ; CDR(form)
  gosub *push         ; S(form, env, form0)
  mov %arg0, %ret     ; %arg0 = CDR(form)
  gosub *push         ; S(form-cdr, form, env, form0)
  mov %tmp, %sp - 3   ; %tmp -> env
  mov %arg1, %%tmp    ; %arg1 = env
  gosub *debruijn     ; debruijn(form-cdr, env)
  mov %arg1, %ret     ; %arg1 = d-form-cdr
  gosub *pop          ; form-cdr < S(form, env, form0)
  if %arg1 == %ret sub %sp, 2 :  goto * debruijn_finish
  gosub *pop          ; form < S(env, form0)
  mov %arg0, %ret     ; %arg0 = form
  gosub *set_cdr      ; form = (form-car . d-form-cdr)
  gosub *pop          ; env < S(form0)
*debruijn_finish  ; S(form0)
  gosub *pop          ; form0 < S()
  return

*debruijn_skip2  ; (form, env)
  gosub *push         ; S(form)
  gosub *cdr
  mov %arg0, %ret     ; %arg0 = CDR(form)
  gosub *cdr
  mov %arg0, %ret     ; %arg0 = CDDR(form)
  gosub *debruijn_start
  gosub *pop          ; form < S()
  return

*debruijn_lambda  ; (form, env)
  gosub *push         ; S(form0)
  gosub *cdr          ; CDR[(lambda args . body)]
  mov %arg0, %ret     ; %arg0 = (args . body)
  gosub *push         ; S((args . body), form0)
  mov %arg0, %arg1    ; %arg0 = env
  gosub *push         ; S(env, (args . body), form0)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; env < S((args . body), form0)
  mov %arg1, %ret     ; %arg1 = env
  gosub *set_cdr      ; cons1 = (? . env)
  gosub *pop          ; (args . body) < S(form0)
  mov %tmp, %arg0     ; %tmp = cons1
  mov %arg0, %ret     ; %arg0 = (args . body)
  gosub *car          ; CAR[(args . body)]
  mov %tmp1, %ret     ; %tmp1 = args
  gosub *cdr          ; CDR[(args . body)]
  mov %arg0, %ret     ; %arg0 = body
  gosub *push         ; S(body, form0)
  mov %arg0, %tmp     ; %arg0 = cons1
  mov %arg1, %tmp1    ; args
  gosub *set_car      ; cons1 = (args . env)
  mov %arg1, %arg0    ; %arg1 = cons1
  gosub *pop          ; body < S(form0)
  mov %arg0, %ret     ; %arg0 = body
  gosub *debruijn
  gosub *pop          ; form0 < S()
  return

*member_syntax  ; (sym)
  if %arg0 == %quote mov %ret, %sharp_t : return
  if %arg0 == %sym_begin mov %ret, %sharp_t : return
  if %arg0 == %sym_lambda mov %ret, %sharp_t : return
  if %arg0 == %sym_define mov %ret, %sharp_t : return
  if %arg0 == %sym_if mov %ret, %sharp_t : return
  if %arg0 == %sym_and mov %ret, %sharp_t : return
  if %arg0 == %sym_or mov %ret, %sharp_t : return
  if %arg0 == %sym_set mov %ret, %sharp_t : return
  if %arg0 == %sym_time mov %ret, %sharp_t : return
  mov %ret, %sharp_f
  return

*debruijn_symbol  ; (sym, env)
  mov %tmp, %arg0     ; %tmp = sym
  mov %arg0, %arg1    ; %arg0 = env
  mov %arg1, %tmp     ; %arg1 = sym
  mov %arg2, 0
  mov %arg3, 0
*debruijn_symbol_loop  ; (env, sym, index, frame)
  if %arg0 == %nil goto *debruijn_symbol_global
  gosub *push         ; S(env)
  gosub *car          ; CAR[(args ...)]
  mov %arg0, %ret     ; %arg0 = args
*debruijn_symbol_frame_loop  ; (args, sym, index, frame), S(env)
  ;; args is symbol if args represents &rest argument.
  if %arg0 == %arg1 goto *debruijn_symbol_finish
  gosub *get_tag
  if %ret != TAG_CONS goto *debruijn_symbol_next_frame
  gosub *car          ; CAR[(arg ...)]
  if %ret == %arg1 goto *debruijn_symbol_finish
  inc %arg2           ; index++
  gosub *cdr          ; CDR(args)
  mov %arg0, %ret     ; args = CDR(args)
  goto *debruijn_symbol_frame_loop
*debruijn_symbol_next_frame  ; (args, sym, index, frame), S(env)
  inc %arg3           ; frame++
  mov %arg2, 0        ; index = 0
  gosub *pop          ; env < S()
  mov %arg0, %ret     ; %arg0 = env
  gosub *cdr          ; CDR(env)
  mov %arg0, %ret     ; %arg0 = CDR(env)
  goto *debruijn_symbol_loop
*debruijn_symbol_finish  ; (args, sym, index, frame), S(env)
  gosub *pop          ; env < S()
  mov %arg0, %arg1    ; %arg0 = sym
  mov %arg1, %arg2    ; %arg1 = index
  mov %arg2, %arg3    ; %arg2 = frame
  goto *create_var  ; tail call
*debruijn_symbol_global  ; (env, sym, index, frame)
  mov %arg0, %arg1    ; %arg0 = sym
  gosub *member_syntax
  if %ret == %sharp_t mov %ret, %arg0 : return
  gosub *push         ; S(sym)
  mov %arg1, %toplevel_env
  gosub *find_var     ; => gvar or NIL
  if %ret == %nil goto *debruijn_symbol_global_error
  mov %tmp, %ret      ; %tmp = gvar
  gosub *pop          ; sym < S()
  mov %ret, %tmp      ; %ret = gvar
  return              ; return gvar
*debruijn_symbol_global_error  ; S(sym)
  mov %arg0, %toplevel_env
  mov %tmp, %sp - 1   ; %tmp -> sym
  mov %arg1, %%tmp    ; %arg1 = sym
  mov %arg2, UNBOUND
  gosub *add_global_bind
  gosub *pop          ; sym < S()
  mov %arg0, %ret     ; %arg0 = sym
  mov %arg1, %toplevel_env
  goto *find_var  ; tail call


;;;;;;;;;;
;;;*add_global_bind(env, sym, val)
;;;;;;;;;;
*add_global_bind
  gosub *push         ; S(env)
  mov %tmp1, %arg0    ; %tmp1 = env
  mov %arg0, %arg1    ; %arg0 = sym
  gosub *push         ; S(sym, env)
  mov %tmp2, %arg0    ; %tmp2 = sym
  mov %arg0, %arg2    ; %arg0 = val
  gosub *push         ; S(val, sym, env)
  mov %arg0, %tmp2    ; %arg0 = sym
  mov %arg1, %tmp1    ; %arg1 = env
  gosub *find_var
  if %ret != %nil goto *add_global_bind_found
  gosub *pop          ; val < S(sym, env)
  mov %arg1, %ret     ; %arg1 = val
  gosub *pop          ; sym < S(env)
  mov %arg0, %ret     ; %arg0 = sym
  gosub *create_gvar
  mov %arg0, %ret     ; %arg0 = gvar
  gosub *push         ; S(gvar, env)
  gosub *create_cons
  mov %arg0, %ret     ; %arg0 = cons1
  gosub *pop          ; gvar < S(env)
  mov %arg1, %ret     ; %arg1 = gvar
  gosub *set_car      ; cons1 = (gvar . ?)
  mov %tmp1, %arg0    ; %tmp1 = cons1
  mov %tmp, %sp - 1   ; %tmp -> env
  mov %arg0, %%tmp    ; %arg0 = env
  gosub *car          ; CAR(env) => alist
  mov %arg0, %tmp1    ; %arg0 = cons1
  mov %arg1, %ret     ; %arg1 = alist
  gosub *set_cdr      ; cons1 = (gvar . alist)
  mov %arg1, %arg0    ; %arg1 = cons1
  gosub *pop          ; env < S()
  mov %arg0, %ret     ; %arg0 = env
  gosub *set_car      ; env = ((gvar . alist) . rest)
  mov %ret, %arg0     ; %ret = env
  return
*add_global_bind_found  ; %ret = gvar, S(val, sym, env)
  mov %arg0, %ret     ; %arg0 = gvar
  gosub *pop          ; val < S(sym, env)
  mov %arg1, %ret     ; %arg1 = val
  gosub *set_cdr      ; gvar = (sym . val)
  gosub *pop          ; sym < S(env)
  gosub *pop          ; env < S()
  return


;;;;;;;;;;
;;;*add_subr_to_env(env, name, n)
;;sarg0 = name
;;arg0  = env
;;arg1  = n
;;;;;;;;;;
*add_subr_to_env
  gosub *push           ; S(env)
  mov %arg0, %arg1
  gosub *push           ; S(n, env)
  gosub *create_symbol
  mov %arg0, %ret       ; arg0 = new symbol
  gosub *pop            ; n < S(env)
  mov %tmp, %ret
  gosub *push           ; S(new symbol, env)
  mov %arg0, %tmp
  gosub *create_subr
  mov %arg2, %ret       ; arg2 = new subr
  gosub *pop            ; new symbol < S(env)
  mov %arg1, %ret       ; arg1 = new symbol
  gosub *pop            ; env < S()
  mov %arg0, %ret       ; arg0 = env
  goto *add_global_bind ; tail call


;;;;;;;;;;
;;;*set_global_env()
;;;;;;;;;;
*set_global_env
  mov $sarg0, "begin"
  gosub *create_symbol
  mov %sym_begin, %ret
  mov $sarg0, "cond"
  gosub *create_symbol
  mov %sym_cond, %ret
  mov $sarg0, "lambda"
  gosub *create_symbol
  mov %sym_lambda, %ret
  mov $sarg0, "define"
  gosub *create_symbol
  mov %sym_define, %ret
  mov $sarg0, "let"
  gosub *create_symbol
  mov %sym_let, %ret
  mov $sarg0, "if"
  gosub *create_symbol
  mov %sym_if, %ret
  mov $sarg0, "and"
  gosub *create_symbol
  mov %sym_and, %ret
  mov $sarg0, "or"
  gosub *create_symbol
  mov %sym_or, %ret
  mov $sarg0, "set！"
  gosub *create_symbol
  mov %sym_set, %ret
  mov $sarg0, "letrec"
  gosub *create_symbol
  mov %sym_letrec, %ret
  mov $sarg0, "let*"
  gosub *create_symbol
  mov %sym_letstar, %ret
  mov $sarg0, "time"
  gosub *create_symbol
  mov %sym_time, %ret
  mov $sarg0, "else"
  gosub *create_symbol
  mov %sym_else, %ret

  mov $sarg0, "(())"
  gosub *input_to_lobject
  mov %global_env, %ret
  mov %toplevel_env, %global_env
  mov %arg0, %global_env
  ; SUBR
  mov %arg1, lf_car
  mov $sarg0, "car"
  gosub *add_subr_to_env  ; car
  mov %arg0, %global_env
  mov %arg1, lf_cdr
  mov $sarg0, "cdr"
  gosub *add_subr_to_env  ; cdr
  mov %arg0, %global_env
  mov %arg1, lf_cons
  mov $sarg0, "cons"
  gosub *add_subr_to_env  ; cons
  mov %arg0, %global_env
  mov %arg1, lf_eq
  mov $sarg0, "eq?"
  gosub *add_subr_to_env  ; eq?
  mov %arg0, %global_env
  mov %arg1, lf_atom
  mov $sarg0, "atom?"
  gosub *add_subr_to_env  ; atom?
  mov %arg0, %global_env
  mov %arg1, lf_add
  mov $sarg0, "+"
  gosub *add_subr_to_env  ; +
  mov %arg0, %global_env
  mov %arg1, lf_sub
  mov $sarg0, "-"
  gosub *add_subr_to_env  ; -
  mov %arg0, %global_env
  mov %arg1, lf_mul
  mov $sarg0, "*"
  gosub *add_subr_to_env  ; *
  mov %arg0, %global_env
  mov %arg1, lf_div
  mov $sarg0, "／"
  gosub *add_subr_to_env  ; /
  mov %arg0, %global_env
  mov %arg1, lf_mod
  mov $sarg0, "mod"
  gosub *add_subr_to_env  ; mod
  mov %arg0, %global_env
  mov %arg1, lf_gt
  mov $sarg0, "＞"
  gosub *add_subr_to_env  ; gt
  mov %arg0, %global_env
  mov %arg1, lf_ge
  mov $sarg0, "＞＝"
  gosub *add_subr_to_env  ; ge
  mov %arg0, %global_env
  mov %arg1, lf_ls
  mov $sarg0, "＜"
  gosub *add_subr_to_env  ; ls
  mov %arg0, %global_env
  mov %arg1, lf_le
  mov $sarg0, "＜＝"
  gosub *add_subr_to_env  ; le
  mov %arg0, %global_env
  mov %arg1, lf_eq
  mov $sarg0, "＝"
  gosub *add_subr_to_env  ; = ('=' is the same as 'eq?')
  mov %arg0, %global_env
  mov %arg1, lf_set_car
  mov $sarg0, "set-car！"
  gosub *add_subr_to_env  ; set-car!
  mov %arg0, %global_env
  mov %arg1, lf_set_cdr
  mov $sarg0, "set-cdr！"
  gosub *add_subr_to_env  ; set-cdr!
  mov %arg0, %global_env
  mov %arg1, lf_eval
  mov $sarg0, "eval"
  gosub *add_subr_to_env  ; eval
  mov %arg0, %global_env
  mov %arg1, lf_apply
  mov $sarg0, "apply"
  gosub *add_subr_to_env  ; apply
  mov %arg0, %global_env
  mov %arg1, lf_booleanp
  mov $sarg0, "boolean?"
  gosub *add_subr_to_env  ; boolean?
  mov %arg0, %global_env
  mov %arg1, lf_pairp
  mov $sarg0, "pair?"
  gosub *add_subr_to_env  ; pair?
  mov %arg0, %global_env
  mov %arg1, lf_symbolp
  mov $sarg0, "symbol?"
  gosub *add_subr_to_env  ; symbol?
  mov %arg0, %global_env
  mov %arg1, lf_numberp
  mov $sarg0, "number?"
  gosub *add_subr_to_env  ; number?
  mov %arg0, %global_env
  mov %arg1, lf_procedurep
  mov $sarg0, "procedure?"
  gosub *add_subr_to_env  ; procedure?
  mov %arg0, %global_env
  mov %arg1, lf_null
  mov $sarg0, "null?"
  gosub *add_subr_to_env  ; null
  mov %arg0, %global_env
  mov %arg1, lf_read
  mov $sarg0, "read"
  gosub *add_subr_to_env  ; read
  mov %arg0, %global_env
  mov %arg1, lf_write
  mov $sarg0, "write"
  gosub *add_subr_to_env  ; write
  mov %arg0, %global_env
  mov %arg1, lf_error
  mov $sarg0, "error"
  gosub *add_subr_to_env  ; error
  mov $sarg0, "(define equal? (lambda (x y) (or (eq? x y)(and (pair? x)"
  mov $sarg0, $sarg0 + "(pair? y) (equal? (car x) (car y))"
  mov $sarg0, $sarg0 + "(equal? (cdr x) (cdr y))))))""
  gosub *input_to_lobject
  mov %arg0, %ret
  mov %arg1, %global_env
  gosub *eval_form
  return


;;;;;;;;;;;;;;;;;;;;
*start
  goto *main_game_start
  end

*read_from_console
  textclear
  mov $sret, ""
  textfield $sret, 30, 120, 610, 140, 10, 20, 0
  return