#!/usr/bin/env bash
# -*- mode: sh; sh-basic-offset: 2 -*-

proc usage {
  echo "$0 [OPTION] FILE..."
  echo
  echo "Options:"
  echo "  -e|--eval STR    Evaluate STR"
  echo "  -l|--load FILE   Load and evaluate FILE"
  echo "  -r|--repl        Start a REPL"
  exit 2
}

if [[ -z "$BASH_VERSION" ]] || sh-expr '${BASH_VERSINFO[0]} < 4' {
  echo "bash >= 4.0 required" > !2
  exit 1
}

setglobal DEFAULT_IFS = $IFS

# function return and error slots ##############################################

setglobal r = ''""
setglobal e = ''""

proc error {
  [[ -z "$e" ]] && setglobal e = $1 || setglobal e = ""$1\n$e""
  setglobal r = $NIL
  return 1
}

# pushback reader ##############################################################

setglobal pb_max = '100'
setglobal pb_newline = $[printf '\034]
setglobal pb_star = $[printf '\035]
setglobal pb_get = '"^$'"
setglobal pb_unget = '"^$'"
setglobal history_flag = '1'

proc readline {
  local IFS=$'\n\b' prompt="> " line
  set -f
  read -e -r -p $prompt line || exit 0
  setglobal pb_get = ""$(pb_get:0:$((${#pb_get}-1)))$(line)$(pb_newline)$""
  set +f
  unset IFS
  if [[ "$line" =~ ^[[:space:]]*- ]] {
    echo "warning: lines starting with - aren't stored in history" > !2
  } elif [[ -n "$history_flag" ]] {
    history -s $line
  }
}

proc getc {
  local ch
  if sh-expr '${#pb_get} == 2' {
    readline
    getc
  } else {
    setglobal ch = $(pb_get:1:1)
    setglobal pb_get = ""^$(pb_get:2)""
    if sh-expr 'pb_max > 0' {
      setglobal pb_unget = $(pb_unget:0:$((${#pb_unget}-1)))
      setglobal pb_unget = ""^$(ch)$(pb_unget:1:$((pb_max-1)))$""
    } else {
      setglobal pb_unget = ""^$(ch)$(pb_unget:1)""
    }
    setglobal r = $ch
  }
}

proc ungetc {
  if [[ "$pb_unget" == "^$" ]] {
    echo "ungetc: nothing more to unget, \$pb_max=$pb_max" > !2 && return 1
  } else {
    setglobal pb_get = ""^$(pb_unget:1:1)$(pb_get:1)""
    setglobal pb_unget = ""^$(pb_unget:2)""
  }
}

proc has_shebangP { [[ "$(head -1 $1)" =~ ^#! && "$(head -1 $1)" =~ gherkin ]]; }

proc strmap_file {
  local f="$1" contents
  if has_shebangP $f {
    setglobal contents = $[tail -n+2 $f | sed -e 's/^[[:space:]]*//' | tr -s '\n' $pb_newline]
  } else {
    setglobal contents = $[cat $f | sed -e 's/^[[:space:]]*//' | tr -s '\n' $pb_newline]
  }
  setglobal mapped_file = ""(do $contents nil)""
  setglobal mapped_file_ptr = '0'
}

proc strmap_getc {
  setglobal r = $(mapped_file:$((mapped_file_ptr++)):1)
}

proc strmap_ungetc {
  let --mapped_file_ptr
}

setglobal _getc = 'getc'
setglobal _ungetc = 'ungetc'

# memory layout & gc ###########################################################

setglobal cons_ptr = '0'
setglobal symbol_ptr = '0'

setglobal protected_ptr = '0'
setglobal gensym_counter = '0'
setglobal array_cntr = '0'

declare -A interned_strings
declare -A car
declare -A cdr
declare -A environments
declare -A recur_frames
declare -A recur_fns
declare -A marks
declare -A global_bindings

declare -a symbols
declare -a protected
declare -a mark_acc

setglobal heap_increment = '1500'
setglobal cons_limit = $heap_increment
setglobal symbol_limit = $heap_increment

setglobal tag_marker = $[printf '\036]

setglobal atag = ""$(tag_marker)003""

declare -A type_tags=([000]=integer
                      [001]=symbol
                      [002]=cons
                      [003]=vector
                      [004]=keyword)

proc type {
  if [[ "${1:0:1}" == "$tag_marker" ]] {
    setglobal r = $(type_tags[${1:1:3}])
  } else {
    setglobal r = 'string'
  }
}

proc strip_tag { setglobal r = $(1:4); }

proc typeP {
  local obj="$1" tag="$2"
  type $obj && [[ $r == "$tag" ]]
}

proc make_integer { setglobal r = ""$(tag_marker)000$(1)""; }

proc make_keyword { setglobal r = ""$(tag_marker)004$(1:1)""; }

proc intern_symbol {
  if [[ -n "${interned_strings[$1]}" ]] {
    setglobal r = $(interned_strings[$1])
  } else {
    setglobal symbol_ptr = "$shExpr('symbol_ptr + 1')"
    compat array-assign interned_strings '"$1"' ""$(tag_marker)001$(symbol_ptr)""
    compat array-assign symbols '"$symbol_ptr"' $1
    setglobal r = ""$(tag_marker)001$(symbol_ptr)""
  }
}

proc defprim {
  intern_symbol $1 && setglobal sym_ptr = $r
  intern_symbol $[printf '#<primitive:%s>' $1] && setglobal prim_ptr = $r
  compat array-assign global_bindings '"$sym_ptr"' $prim_ptr
  setglobal r = $prim_ptr
}

proc cons {
  local the_car="$1" the_cdr="$2"
  mark $the_car
  mark $the_cdr {
    unset marks["$(tag_marker)002$shExpr('cons_ptr++')"]
  }
  if [[ $cons_ptr == $cons_limit ]] {
    gc
  }
  unset environments["$(tag_marker)002$(cons_ptr)"]
  unset recur_frames["$(tag_marker)002$(cons_ptr)"]
  unset recur_fns["$(tag_marker)002$(cons_ptr)"]
  compat array-assign car '"${tag_marker}002${cons_ptr}"' $the_car
  compat array-assign cdr '"${tag_marker}002${cons_ptr}"' $the_cdr
  setglobal r = ""$(tag_marker)002$(cons_ptr)""
  setglobal cons_ptr = "$shExpr('cons_ptr + 1')"
}

proc gensym {
  setglobal gensym_counter = $shExpr('gensym_counter + 1')
  intern_symbol "G__$(gensym_counter)"
}

proc new_array {
  setglobal r = ""arr$shExpr('array_cntr++')""
  declare -a $r
  setglobal r = ""$(atag)$(r)""
}

proc vset {
  strip_tag $1
  eval "$(r)[$(2)]=\"$(3)\""
  setglobal r = $1
}

proc vget {
  strip_tag $1
  eval "r=\${$(r)[$(2)]}"
}

proc count_array {
  strip_tag $1
  eval "r=\${#$(r)[@]}"
}

proc append {
  local i
  strip_tag $1
  eval "i=\${#$(r)[@]}"
  eval "$(r)[$(i)]=\"$(2)\""
  setglobal r = $1
}

proc append_all {
  strip_tag $1
  local a1="$r"
  strip_tag $2
  local a2="$r"
  local len1 len2
  eval "len1=\${#$(a1)[@]}"
  eval "len2=\${#$(a2)[@]}"
  local i=0
  while sh-expr 'i < len2' {
    eval "$(a1)[(($(i) + $(len1)))]=\"\${$(a2)[$(i)]}\""
    sh-expr 'i++'
  }
  setglobal r = $1
}

proc prepend {
  local i len
  strip_tag $2
  eval "len=\${#$(r)[@]}"
  while sh-expr 'len > 0' {
    eval "$(r)[$(len)]=\"\${$(r)[((len - 1))]}\""
    sh-expr 'len--'
  }
  eval "$(r)[0]=\"$1\""
  setglobal r = $2
}

proc dup {
  new_array
  local aptr="$r"
  strip_tag $aptr
  local narr="$r"
  strip_tag $1
  local len
  eval "len=\${#$(r)[@]}"
  local i=0
  while sh-expr 'i < len' {
    eval "$(narr)[$(i)]=\"\${$(r)[$(i)]}\""
    sh-expr 'i++'
  }
  setglobal r = $aptr
}

proc concat {
  dup $1
  append_all $r $2
}

proc vector {
  local v="$2"
  if [[ "$EMPTY" == "$v" || -z "$v" || "$NIL" == "$v" ]] { 
    new_array
    setglobal v = $r
  }
  prepend $1 $v
}

proc protect {
  setglobal protected_ptr = "$shExpr('protected_ptr + 1')"
  compat array-assign protected '"$protected_ptr"' $1
}

proc unprotect { setglobal protected_ptr = "$shExpr('protected_ptr - 1')"; }

setglobal acc_count = '0'

proc mark_seq {
  local object="$1"
  while typeP $object cons {
    compat array-assign marks '"$object"' '1'
    compat array-assign mark_acc 'acc_count++' $(car[$object])
    setglobal object = $(cdr[$object])
  }
  if typeP $object vector  {
    count_array $object
    local i sz="$r"
    for ((i=0; i<sz; i++)); do
      vget "$object" $i
      mark_acc[acc_count++]="$r"
    done
  }
}

proc mark {
  setglobal acc_count = '0'
  mark_seq $1
  local i
  for ((i=0; i<${#mark_acc[@]}; i++)); do
    mark_seq "${mark_acc[$i]}"
  done
  setglobal mark_acc = ''()
}

proc gc {
  echo "GC..." > !2
  setglobal IFS = $DEFAULT_IFS
  mark $current_env
  for k in [$(!environments[@])]    { mark $(environments[$k]);    }
  for k in [$(!protected[@])]       { mark $(protected[$k]);       }
  for k in [$(!stack[@])]           { mark $(stack[$k]);           }
  for k in [$(!global_bindings[@])] { mark $(global_bindings[$k]); }
  setglobal cons_ptr = '0' {
    unset marks["$(tag_marker)002$shExpr('cons_ptr++')"]
  }
  if [[ $cons_ptr == $cons_limit ]] {
    echo "expanding heap..." > !2
    setglobal cons_limit = $shExpr('cons_limit + heap_increment')
  }
}

# reader #######################################################################

proc interpret_token {
  [[ "$1" =~ ^-?[[:digit:]]+$ ]] \
    && setglobal r = 'integer' && return
  [[ "$1" =~ ^:([[:graph:]]|$pb_star)+$ ]] \
    && setglobal r = 'keyword' && return
  [[ "$1" =~ ^([[:graph:]]|$pb_star)+$ ]] \
    && setglobal r = 'symbol' && return
  return 1
}

proc read_token {
  local token=""
  while $_getc {
    if [[ "$r" =~ ('('|')'|'['|']'|[[:space:]]|$pb_newline|,) ]] {
      $_ungetc && break
    } else {
      setglobal token = ""$(token)$(r/\*/${pb_star})""
    }
  }
  test -z $token && return 1
  if interpret_token $token {
    match $r {
      with symbol  intern_symbol $token && return 
      with integer make_integer $token && return 
      with keyword make_keyword $token && return 
      with * error "unknown token type: '$r'"
    }
  } else {
    error "unknown token: '$(token)'"
  }
}

proc skip_blanks {
  $_getc { $_getc; }
  $_ungetc
}

proc skip_comment {
  $_getc { $_getc; }
}

proc read_list {
  local ch read1 read2
  if lisp_read {
    setglobal read1 = $r
  } else {
    $_getc
    setglobal r = $NIL
    return
  }
  $_getc && setglobal ch = $r
  match $ch {
    with "."
      lisp_read && setglobal read2 = $r
      skip_blanks
      $_getc
      cons $read1 $read2
      
    with ")" cons $read1 $NIL 
    with *
      $_ungetc
      read_list
      cons $read1 $r
  }
}

proc read_vector {
  local ch read1
  if lisp_read {
    setglobal read1 = $r
  } else {
    getc
    setglobal r = $EMPTY
    return
  }
  skip_blanks
  getc
  if [[ "$r" == "]" ]] {
    vector $read1 $EMPTY
  } else {
    ungetc
    skip_blanks
    read_vector
    vector $read1 $r
  }
}

proc read_string {
  local s=""
  while true {
    $_getc
    if [[ "$r" == "\\" ]] {
      $_getc
      if [[ "$r" == '"' ]] {
	setglobal s = ""$(s)$(r)""
      } else {
	setglobal s = ""$(s)\\$(r)""
      }
    } elif [[ "$r" == '"' ]] {
      break
    } else {
      setglobal s = ""$(s)$(r)""
    }
  }
  setglobal r = $[echo $s | tr $pb_star '*]
}

proc lisp_read {
  local ch read1 read2 read3 read4
  skip_blanks; $_getc; setglobal ch = $r
  match $ch {
    with "\""
      read_string
      
    with "("
      read_list
      
    with "["
      read_vector
      
    with "'"
      lisp_read && setglobal read1 = $r
      cons $read1 $NIL && setglobal read2 = $r
      cons $QUOTE $read2
      
    with ";"
      skip_comment
      lisp_read
      
    with *
      $_ungetc
      read_token
  }
}

proc string_list {
  local c="$1" ret
  shift
  if [[ "$1" == "" ]] {
    cons $c $NIL && setglobal ret = $r
  } else {
    string_list $ifsjoin(Argv)
    cons $c $r && setglobal ret = $r
  }
  setglobal r = $ret
}

# printer ######################################################################
setglobal printing = ''

proc escape_str {
  local i c
  setglobal r = ''""
  for ((i=0; i < ${#1}; i++)); do
    c="${1:$i:1}"
    case "$c" in
      \") r="${r}\\\"" ;;
      \\) r="${r}\\\\" ;;
      *) r="${r}${c}"
    esac
  done
}

proc str_arr {
  local ret="["
  count_array $1
  local len=$r
  if sh-expr ' 0 != len ' {
    vget $1 0
    str $r
    setglobal ret = ""$(ret)$(r)""
    for ((i=1 ; i < $len ; i++)); do
      vget $1 $i
      str "$r"
      ret="${ret} ${r}"
    done
  }
  setglobal r = ""$(ret)]""
}

proc str_list {
  local lst="$1"
  local ret
  if [[ "${car[$lst]}" == $FN ]] {
    strip_tag $lst && printf -v r '#<function:%s>' $r
  } else {
    setglobal ret = '"('"
    str $(car[$lst])
    setglobal ret = ""$(ret)$(r)""
    setglobal lst = $(cdr[$lst])
    while typeP $lst cons {
      str $(car[$lst])
      setglobal ret = ""$(ret) $(r)""
      setglobal lst = $(cdr[$lst])
    }
    if [[ "$lst" != $NIL ]] {
      str $lst
      setglobal ret = ""$(ret) . $(r)""
    }
    setglobal r = ""$(ret))""
  }
}

proc str {
  type $1
  match $r {
    with integer strip_tag $1 && printf -v r '%d' $r 
    with cons str_list $1 
    with vector str_arr $1 
    with symbol strip_tag $1 && printf -v r '%s' $[echo $(symbols[$r]) | tr $pb_star "*] 
    with keyword strip_tag $1 && printf -v r ':%s' $r 
    with *
      if [[ -n $printing ]] {
        escape_str $1
        printf -v r '"%s"' $r
      } else {
        printf -v r '%s' $1
      }
      
  }
}

proc prn {
  setglobal printing = '1'
  str $1
  setglobal printing = ''
  printf '%s' $r && echo
}

# environment & control ########################################################

setglobal frame_ptr = '0'
setglobal stack_ptr = '0'

declare -a stack

intern_symbol '&'      && setglobal AMP = $r
intern_symbol 'nil'    && setglobal NIL = $r
intern_symbol 't'      && setglobal T = $r
compat array-assign global_bindings '$NIL' $NIL
compat array-assign global_bindings '$T' $T
compat array-assign car '$NIL' $NIL
compat array-assign cdr '$NIL' $NIL

new_array && setglobal EMPTY = $r

setglobal current_env = $NIL

intern_symbol 'quote'   && setglobal QUOTE = $r
intern_symbol 'fn'      && setglobal FN = $r
intern_symbol 'if'      && setglobal IF = $r
intern_symbol 'set!'    && setglobal SET_BANG = $r
intern_symbol 'def'     && setglobal DEF = $r
intern_symbol 'do'      && setglobal DO = $r
intern_symbol 'recur'   && setglobal RECUR = $r
intern_symbol 'binding' && setglobal BINDING = $r

declare -A specials

compat array-assign specials '$QUOTE' '1'
compat array-assign specials '$FN' '1'
compat array-assign specials '$IF' '1'
compat array-assign specials '$SET_BANG' '1'
compat array-assign specials '$DEF' '1'
compat array-assign specials '$DO' '1'
compat array-assign specials '$RECUR' '1'
compat array-assign specials '$BINDING' '1'

defprim 'eq?'       && setglobal EQ = $r
defprim 'nil?'      && setglobal NILP = $r
defprim 'car'       && setglobal CAR = $r
defprim 'cdr'       && setglobal CDR = $r
defprim 'cons'      && setglobal CONS = $r
defprim 'list'      && setglobal LIST = $r
defprim 'vector'    && setglobal VECTOR = $r
defprim 'keyword'   && setglobal KEYWORD = $r
defprim 'eval'      && setglobal EVAL = $r
defprim 'apply'     && setglobal APPLY = $r
defprim 'read'      && setglobal READ = $r
defprim '+'         && setglobal ADD = $r
defprim '-'         && setglobal SUB = $r
defprim $pb_star  && setglobal MUL = $r
defprim '/'         && setglobal DIV = $r
defprim 'mod'       && setglobal MOD = $r
defprim '<'         && setglobal LT = $r
defprim '>'         && setglobal GT = $r
defprim 'cons?'     && setglobal CONSP = $r
defprim 'symbol?'   && setglobal SYMBOLP = $r
defprim 'number?'   && setglobal NUMBERP = $r
defprim 'string?'   && setglobal STRINGP = $r
defprim 'fn?'       && setglobal FNP = $r
defprim 'gensym'    && setglobal GENSYM = $r
defprim 'random'    && setglobal RAND = $r
defprim 'exit'      && setglobal EXIT = $r
defprim 'println'   && setglobal PRINTLN = $r
defprim 'sh'        && setglobal SH = $r
defprim 'sh!'       && setglobal SH_BANG = $r
defprim 'load-file' && setglobal LOAD_FILE = $r
defprim 'gc'        && setglobal GC = $r
defprim 'error'     && setglobal ERROR = $r
defprim 'type'      && setglobal TYPE = $r
defprim 'str'       && setglobal STR = $r
defprim 'split'     && setglobal SPLIT = $r
defprim 'getenv'    && setglobal GETENV = $r

proc eval_args {
  local args="$1"
  type $args
  if [[ "$r" == cons ]] { {
      lisp_eval $(car[$args])
      compat array-assign stack '$((stack_ptr++))' $r
      setglobal args = $(cdr[$args])
    }
  } elif [[ "$r" == vector ]] {
    count_array $args
    local i len="$r"
    for ((i=0; i<len; i++)); do
      vget "$args" "$i"
      lisp_eval "$r"
      stack[$((stack_ptr++))]="$r"
    done
  } elif [[ "$1" != "$NIL" ]] {
    str $args
    error "Unknown argument type: $r"
  }
}

proc listify_args {
  local p=$shExpr('stack_ptr - 1') ret=$NIL stop
  [[ -z "$1" ]] && setglobal stop = $frame_ptr || setglobal stop = $1
  while sh-expr 'stop <= p' {
    cons $(stack[$p]) $ret && setglobal ret = $r
    setglobal p = $shExpr('p - 1')
  }
  setglobal r = $ret
}

proc vectify_args {
  local stop=$shExpr('stack_ptr - 1') ret
  new_array
  setglobal ret = $r
  [[ -z "$1" ]] && setglobal p = $frame_ptr || setglobal p = $1
  while sh-expr 'p <= stop' {
    append $ret $(stack[$((p++))])
  }
  setglobal r = $ret
}

proc acons {
  local key="$1" datum="$2" a_list="$3"
  cons $key $datum && cons $r $a_list
}

proc aget {
  local key="$1" a_list="$2 {
    if [[ "${car[${car[$a_list]}]}" == "$key" ]] {
      setglobal r = $(cdr[${car[$a_list]}]) && return 0
    }
    setglobal a_list = $(cdr[$a_list])
  }
  setglobal r = $NIL && return 1
}

proc analyze {
  local fn="$1" body="$2" env="$3 {
    type $(car[$body])
    if [[ "$r" == cons ]] {
      match $(car[${car[$body]}]) {
        with $FN compat array-assign environments '"${car[$body]}"' $env 
        with $RECUR
          compat array-assign recur_fns '"${car[$body]}"' $fn
          compat array-assign recur_frames '"${car[$body]}"' $frame_ptr
          
        with * analyze $fn $(car[$body]) $env 
      }
    }
    setglobal body = $(cdr[$body])
  }
}

proc copy_list {
  local lst="$1" copy="$NIL" prev="$NIL" curr="$NIL {
    cons $(car[$lst]) $NIL && setglobal curr = $r
    if [[ "$copy" == "$NIL" ]] {
      setglobal copy = $curr
    } else {
      compat array-assign cdr '"$prev"' $curr
    }
    setglobal prev = $curr
    setglobal lst = $(cdr[$lst])
  }
  setglobal r = $copy
}

proc apply_user {
  local fn="$1"
  local body="$(cdr[${cdr[$fn]}])"
  local params="$(car[${cdr[$fn]}])"
  local p="$frame_ptr"
  local ret="$NIL"
  local old_env

  [[ -z "${environments[$fn]}" ]] && local env=$NIL || local env="$(environments[$fn])"

  type $params
  local ptype="$r"
  if [[ "$ptype" == "cons" ]] { {
      acons $(car[$params]) $(stack[$((p++))]) $env && setglobal env = $r
      setglobal params = $(cdr[$params])
    }
    if [[ "${car[$params]}" == $AMP ]] {
      listify_args $p && local more="$r"
      acons $(car[${cdr[$params]}]) $more $env && setglobal env = $r
    }
  } elif [[ "$ptype" == "vector" ]] {
    local i=1 len
    count_array $params
    setglobal len = $r
    vget $params 0
    while sh-expr 'i <= len' {
      acons $r $(stack[$((p++))]) $env && setglobal env = $r
      vget $params $shExpr('i++')
    }
    if [[ "$r" == "$AMP" ]] {
      listify_args $p && local more="$r"
      vget $params $i
      acons $r $more $env && setglobal env = $r
    }
  } elif [[ "$params" != $NIL ]] {
    error "Illegal type ($(ptype)) for params in function"
    return 1
  }


  analyze $fn $body $env

  setglobal old_env = $current_env
  setglobal current_env = $env
  do_ $body && setglobal ret = $r
  setglobal current_env = $old_env
  setglobal r = $ret
}

proc eval_file {
  strmap_file $1
  setglobal _getc = 'strmap_getc'
  setglobal _ungetc = 'strmap_ungetc'
  lisp_read
  setglobal _getc = 'getc'
  setglobal _ungetc = 'ungetc'
  protect $r
  lisp_eval $r
  unprotect
}

proc check_numbers {
    if ! typeP $1 integer  {
      str $1
      error "'$r' is not a number"
      return 1
    }
    shift
  }
}

proc rev_str {
  local i rev=""
  for ((i=0; i < ${#1}; i++)); do
    rev="${1:$i:1}${rev}"
  done
  setglobal r = $rev
}

proc apply_primitive {
  local primitive="$1"
  local arg0="$(stack[$frame_ptr])"
  local arg1="$(stack[$((frame_ptr+1))])"
  local arg2="$(stack[$((frame_ptr+2))])"

  setglobal r = $NIL
  match $primitive {
    with $EQ         [[ "$arg0" == "$arg1" ]] && setglobal r = $T 
    with $NILP       [[ "$arg0" == $NIL ]] && setglobal r = $T    
    with $CAR        setglobal r = $(car[$arg0])                  
    with $CDR        setglobal r = $(cdr[$arg0])                  
    with $CONS       cons $arg0 $arg1               
    with $LIST       listify_args                       
    with $VECTOR     vectify_args                       
    with $KEYWORD
      type $arg0
      match $r {
        with string make_keyword $arg0 
        with keyword setglobal r = $arg0 
        with *
          strip_tag $arg0
          error "Unable to make keyword from: $r"
          setglobal r = $NIL
      }
      
    with $STR
      listify_args && setglobal strs = $r
      local ret= {
        str $(car[$strs])
        setglobal ret = ""$(ret)$r""
        setglobal strs = $(cdr[$strs])
      }
      setglobal r = $ret
      
    with $SPLIT
      local i ret="$NIL" last=0
      rev_str $arg1 && local rev="$r"
      for ((i=0; i < ${#rev}; i++)); do
        if [[ "${rev:$i:1}" == "$arg0" ]]; then
          rev_str "${rev:$last:$((i - last))}"
          cons "$r" "$ret" && ret="$r"
          last="$((i + 1))"
        fi
      done
      if sh-expr 'last != 0' {
        rev_str $(rev:$last:$((${#rev} - last)))
        cons $r $ret && setglobal ret = $r
      }
      setglobal r = $ret
      
    with $GETENV
      [[ -n "$arg0" ]] && eval "r=\$$(arg0)"
      [[ -z "$r" ]] && setglobal r = $NIL
      
    with $EVAL       lisp_eval $arg0    
    with $READ       lisp_read            
    with $MOD
      if check_numbers $arg0 $arg1  {
        strip_tag $arg0 && local x="$r"
        strip_tag $arg1 && local y="$r"
        make_integer $shExpr('x % y')
      }
      
    with $LT
      if check_numbers $arg0 $arg1  {
        strip_tag $arg0 && local x="$r"
        strip_tag $arg1 && local y="$r"
        sh-expr 'x < y' && setglobal r = $T || setglobal r = $NIL
      }
      
    with $GT
      if check_numbers $arg0 $arg1  {
        strip_tag $arg0 && local x="$r"
        strip_tag $arg1 && local y="$r"
        sh-expr 'x > y' && setglobal r = $T || setglobal r = $NIL
      }
      
    with $CONSP      typeP $arg0 cons    && setglobal r = $T                                 
    with $SYMBOLP    typeP $arg0 symbol  && setglobal r = $T || setglobal r = $NIL                       
    with $NUMBERP    typeP $arg0 integer && setglobal r = $T || setglobal r = $NIL                       
    with $STRINGP    typeP $arg0 string  && setglobal r = $T || setglobal r = $NIL                       
    with $FNP        typeP $arg0 cons    && [[ "${car[$arg0]}" == $FN ]] && setglobal r = $T 
    with $GC         gc && setglobal r = $NIL                                                  
    with $GENSYM     gensym                                                        
    with $ADD
      if check_numbers $arg0 $arg1  {
        strip_tag $arg0 && local x="$r"
        strip_tag $arg1 && local y="$r"
        make_integer $shExpr('x + y')
      }
      
    with $SUB
      if check_numbers $arg0 $arg1  {
        strip_tag $arg0 && local x="$r"
        strip_tag $arg1 && local y="$r"
        make_integer $shExpr('x - y')
      }
      
    with $APPLY
      local old_frame_ptr=$frame_ptr
      setglobal frame_ptr = $stack_ptr
      type $arg1
      match $r {
        with cons
          while typeP $arg1 cons {
            compat array-assign stack '$((stack_ptr++))' $(car[$arg1])
            setglobal arg1 = $(cdr[$arg1])
          }
          [[ $arg1 != $NIL ]] && error "Bad argument to apply: not a proper list"
          
        with vector
          count_array $arg1
          local len="$r"
          for ((i=0; i<len; i++)); do
            vget "$arg1" "$i"
            stack[$((stack_ptr++))]="$r"
          done
          
        with * error "Bad argument to apply: not a list"
      }
      if [[ -z "$e" ]] {
        apply $arg0
      }
      setglobal stack_ptr = $frame_ptr
      setglobal frame_ptr = $old_frame_ptr
      
    with $ERROR
      printf 'lisp error: ' > !2
      prn $arg0           > !2
      
    with $TYPE
      if [[ "$arg0" == $NIL ]] {
        setglobal r = $NIL
      } else {
        type $arg0
        if [[ "$r" == cons ]] && [[ "${car[$arg0]}" == $FN ]] {
          intern_symbol "function"
        } else {
          intern_symbol $r
        }
      }
      
    with $MUL
      if check_numbers $arg0 $arg1  {
        strip_tag $arg0 && local x="$r"
        strip_tag $arg1 && local y="$r"
        make_integer $shExpr('x * y')
      }
      
    with $DIV
      local x y
      if check_numbers $arg0 $arg1  {
        strip_tag $arg0 && setglobal x = $r
        strip_tag $arg1 && setglobal y = $r
        make_integer $shExpr('x / y')
      }
      
    with $RAND
      if check_numbers $arg0  {
        strip_tag $arg0
        make_integer "$shExpr('RANDOM % r')"
      }
      
    with $PRINTLN
      listify_args && local to_print="$r {
        type $(car[$to_print])
        match $r {
          with string
            echo -e $(car[$to_print])
            
          with * prn $(car[$to_print])
            
        }
        setglobal to_print = $(cdr[$to_print])
      }
      setglobal r = $NIL
      
    with $SH
      local ret
      eval "ret=\$($(arg0))"
      setglobal IFS = '$'\n''
      string_list $[for i in [$ret] { echo $i; }]
      setglobal IFS = $DEFAULT_IFS
      
    with $SH_BANG
      eval $(arg0)
      [[ $? == 0 ]] && setglobal r = $T || setglobal r = $NIL
      
    with $LOAD_FILE
      local f
      if [[ -r ${arg0} ]] {
        setglobal f = $(arg0)
      } elif [[ -r "${arg0}.gk" ]] {
        setglobal f = ""$(arg0).gk""
      }
      if [[ "$f" != "" ]] {
        eval_file $f
      } else {
        echo "File not found: $(arg0)" > !2
        setglobal r = $NIL
      }
      
    with $EXIT
      strip_tag $arg0
      exit "$r"
      
    with * strip_tag $1 && error "unknown primitive function type: $(symbols[$r])"
      return 1
  }
}

proc apply {
  if [[ "${car[$1]}" == "$FN" ]] {
    apply_user $1
  } else {
    apply_primitive $1
  }
}

proc add_bindings {
  type $1
  if [[ $r == cons ]] {
    local pairs="$1" val {
      lisp_eval $(car[${cdr[$pairs]}]) && setglobal val = $r
      if [[ -n "$e" ]] { return 1; }
      acons $(car[$pairs]) $val $current_env && setglobal current_env = $r
      setglobal pairs = $(cdr[${cdr[$pairs]}])
    }
    if [[ "$pairs" != $NIL ]] {
      error "Bad bindings. Must be an even number of binding forms."
      return 1
    }
  } elif [[ "$r" == vector ]] {
    count_array $1
    local i v len="$r"
    if sh-expr ' len % 2 == 0 ' {
      for (( i=0; i<len; )); do
        vget "$1" $((i++))
        v="$r"
        vget "$1" $((i++))
        lisp_eval "$r"
        if [[ -n "$e" ]]; then return 1; fi
        acons "$v" "$r" "$current_env" && current_env="$r"
      done
    } else {
      error "Bad bindings. Must be an even number of binding forms."
    }
  } else {
    error "bindings not available."
  }
}

proc do_ {
  local body="$1" result="$NIL {
    lisp_eval $(car[$body]) && setglobal result = $r
    setglobal body = $(cdr[$body])
  }
  if typeP $result cons && [[ "${car[$result]}" == "$FN" ]] {
    copy_list $result
    compat array-assign environments '"$r"' $current_env
  } else {
    setglobal r = $result
  }
}

proc eval_special {
  local special="$1"
  local op="$(car[$1])"
  local args="$(cdr[$1])"
  local arg0="$(car[$args])"
  local arg1="$(car[${cdr[$args]}])"
  local arg2="$(car[${cdr[${cdr[$args]}]}])"
  match $op {
    with $QUOTE  setglobal r = $arg0        
    with $DO     do_ $args      
    with $FN     setglobal r = $special     
    with $IF
      lisp_eval $arg0
      [[ "$r" != "$NIL" ]] && lisp_eval $arg1 || lisp_eval $arg2
      
    with $SET_BANG
      if [[ -n "${global_bindings[$arg0]}" ]] {
        lisp_eval $arg1 && compat array-assign global_bindings '$arg0' $r
      } else {
        strip_tag $arg0 && error "unbound variable: $(symbols[$r])"
      }
      
    with $RECUR
      setglobal frame_ptr = $(recur_frames[$1])
      setglobal stack_ptr = $frame_ptr {
        lisp_eval $(car[$args])
        compat array-assign stack '$((stack_ptr++))' $r
        setglobal args = $(cdr[$args])
      }
      setglobal current_env = $(environments[$1])
      apply_user $(recur_fns[$1])
      
    with $DEF
      lisp_eval $arg1 && compat array-assign global_bindings '"$arg0"' $r
      setglobal r = $arg0
      
    with $BINDING
      local binding_body="$(cdr[$args])"
      local old_env="$current_env"
      add_bindings $arg0
      if [[ -z "$e" ]] {
        do_ $binding_body
      }
      setglobal current_env = $old_env
      
    with *
      strip_tag $op
      error "eval_special: unknown form: $(symbols[$r])"
  }
}

proc eval_function {
  local op="$(car[$1])" eval_op
  local args="$(cdr[$1])"
  local old_frame_ptr=$frame_ptr
  setglobal frame_ptr = $stack_ptr
  lisp_eval $op && setglobal eval_op = $r
  if [[ -z "$e" ]] {
    protect $eval_op
    eval_args $args
    if [[ -z "$e" ]] {
      apply $eval_op
    }
    unprotect
  }
  setglobal stack_ptr = $frame_ptr
  setglobal frame_ptr = $old_frame_ptr
}

proc lisp_eval {
  type $1
  match $r {
    with symbol
      [[ "$1" == "$NIL" ]] && setglobal r = $NIL && return
      [[ "$1" == "$T" ]] && setglobal r = $T && return
      aget $1 $current_env && return
      if [[ -n "${global_bindings[$1]}" ]] {
        setglobal r = $(global_bindings[$1])
      } else {
        strip_tag $1 && error "unable to resolve $(symbols[$r])"
      }
      
    with cons
      if [[ -n "${specials[${car[$1]}]}" ]] {
        eval_special $1
      } else {
        eval_function $1
      }
      
    with vector
      local old_frame_ptr=$frame_ptr
      local old_stack_ptr=$stack_ptr
      setglobal frame_ptr = $stack_ptr
      eval_args $1
      if [[ -z "$e" ]] {
        vectify_args
      }
      setglobal stack_ptr = $old_stack_ptr
      setglobal frame_ptr = $old_frame_ptr
      
    with integer setglobal r = $1   
    with string  setglobal r = $1 
    with keyword setglobal r = $1 
    with *
      error "lisp_eval: unrecognized type"
      return 1
      
  }
}

# repl #########################################################################

proc init_history {
  intern_symbol "$(pb_star)1" && setglobal hist1 = $r
  intern_symbol "$(pb_star)2" && setglobal hist2 = $r
  intern_symbol "$(pb_star)3" && setglobal hist3 = $r
  compat array-assign global_bindings '"$hist1"' $NIL
  compat array-assign global_bindings '"$hist2"' $NIL
  compat array-assign global_bindings '"$hist3"' $NIL
}

proc update_history {
  compat array-assign global_bindings '"$hist3"' $(global_bindings[$hist2])
  compat array-assign global_bindings '"$hist2"' $(global_bindings[$hist1])
  compat array-assign global_bindings '"$hist1"' $r
}

proc repl {
  init_history
  while true {
    setglobal e = ''   # clear existing error state
    lisp_read
    [[ -n "$e" ]] && printf "read error: $e\n" > !2
    protect $r
    lisp_eval $r
    update_history
    [[ -n "$e" ]]  && printf "eval error: $e\n" > !2
    prn $r
    [[ -n "$e" ]] && printf "print error: $e\n" > !2
    unprotect
  }
}

# start ########################################################################

proc eval_string {
  local str="$1"
  lisp_read <<<"(do $str)"
  protect $r
  lisp_eval $r
  unprotect
}

# Start REPL if no arguments
test -z "$ifsjoin(Argv)" && repl

setglobal ARGV = "$ifsjoin(Argv)"
# Process parameters
while test "$ifsjoin(Argv)" {
  setglobal param = $1; shift; setglobal OPTARG = $1
  match $param {
    with -e|--eval eval_string $OPTARG; shift
               [[ $r != $NIL ]] && prn $r
               
    with -l|--load eval_file $OPTARG; shift
               [[ $r != $NIL ]] && prn $r
               
    with -t|--test 
    with -r|--repl repl 
    with -* usage 
    with *         [[ -f "$param" ]] && has_shebangP $param && eval_file $param
               [[ $r != $NIL ]] && prn $r
               
  }
}