#!/usr/bin/env bash # -*- mode: sh; sh-basic-offset: 2 -*- 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" ]] || ((${BASH_VERSINFO[0]} < 4)); then echo "bash >= 4.0 required" >&2 exit 1 fi DEFAULT_IFS="$IFS" # function return and error slots ############################################## r="" e="" error() { [[ -z "$e" ]] && e="$1" || e="$1\n$e" r=$NIL return 1 } # pushback reader ############################################################## pb_max=100 pb_newline="$(printf '\034')" pb_star="$(printf '\035')" pb_get="^$" pb_unget="^$" history_flag=1 readline() { local IFS=$'\n\b' prompt="> " line set -f read -e -r -p "$prompt" line || exit 0 pb_get="${pb_get:0:$((${#pb_get}-1))}${line}${pb_newline}$" set +f unset IFS if [[ "$line" =~ ^[[:space:]]*- ]]; then echo "warning: lines starting with - aren't stored in history" >&2 elif [[ -n "$history_flag" ]]; then history -s "$line" fi } getc() { local ch if ((${#pb_get} == 2)); then readline getc else ch="${pb_get:1:1}" pb_get="^${pb_get:2}" if ((pb_max > 0)); then pb_unget="${pb_unget:0:$((${#pb_unget}-1))}" pb_unget="^${ch}${pb_unget:1:$((pb_max-1))}$" else pb_unget="^${ch}${pb_unget:1}" fi r="$ch" fi } ungetc() { if [[ "$pb_unget" == "^$" ]]; then echo "ungetc: nothing more to unget, \$pb_max=$pb_max" >&2 && return 1 else pb_get="^${pb_unget:1:1}${pb_get:1}" pb_unget="^${pb_unget:2}" fi } has_shebangP() { [[ "$(head -1 $1)" =~ ^#! && "$(head -1 $1)" =~ gherkin ]]; } strmap_file() { local f="$1" contents if has_shebangP "$f"; then contents="$(tail -n+2 "$f" | sed -e 's/^[[:space:]]*//' | tr -s '\n' $pb_newline)" else contents="$(cat "$f" | sed -e 's/^[[:space:]]*//' | tr -s '\n' $pb_newline)" fi mapped_file="(do $contents nil)" mapped_file_ptr=0 } strmap_getc() { r="${mapped_file:$((mapped_file_ptr++)):1}" } strmap_ungetc() { let --mapped_file_ptr } _getc=getc _ungetc=ungetc # memory layout & gc ########################################################### cons_ptr=0 symbol_ptr=0 protected_ptr=0 gensym_counter=0 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 heap_increment=1500 cons_limit=$heap_increment symbol_limit=$heap_increment tag_marker="$(printf '\036')" atag="${tag_marker}003" declare -A type_tags=([000]=integer [001]=symbol [002]=cons [003]=vector [004]=keyword) type() { if [[ "${1:0:1}" == "$tag_marker" ]]; then r="${type_tags[${1:1:3}]}" else r=string fi } strip_tag() { r="${1:4}"; } typeP() { local obj="$1" tag="$2" type "$obj" && [[ $r == "$tag" ]] } make_integer() { r="${tag_marker}000${1}"; } make_keyword() { r="${tag_marker}004${1:1}"; } intern_symbol() { if [[ -n "${interned_strings[$1]}" ]]; then r="${interned_strings[$1]}" else symbol_ptr="$((symbol_ptr + 1))" interned_strings["$1"]="${tag_marker}001${symbol_ptr}" symbols["$symbol_ptr"]="$1" r="${tag_marker}001${symbol_ptr}" fi } defprim() { intern_symbol "$1" && sym_ptr="$r" intern_symbol "$(printf '#' "$1")" && prim_ptr="$r" global_bindings["$sym_ptr"]=$prim_ptr r="$prim_ptr" } cons() { local the_car="$1" the_cdr="$2" mark "$the_car" mark "$the_cdr" while [[ -n "${marks[${tag_marker}002${cons_ptr}]}" ]]; do unset marks["${tag_marker}002$((cons_ptr++))"] done if [[ $cons_ptr == $cons_limit ]]; then gc fi unset environments["${tag_marker}002${cons_ptr}"] unset recur_frames["${tag_marker}002${cons_ptr}"] unset recur_fns["${tag_marker}002${cons_ptr}"] car["${tag_marker}002${cons_ptr}"]="$the_car" cdr["${tag_marker}002${cons_ptr}"]="$the_cdr" r="${tag_marker}002${cons_ptr}" cons_ptr="$((cons_ptr + 1))" } gensym() { gensym_counter=$((gensym_counter + 1)) intern_symbol "G__${gensym_counter}" } new_array() { r="arr$((array_cntr++))" declare -a $r r="${atag}${r}" } vset() { strip_tag "$1" eval "${r}[${2}]=\"${3}\"" r="$1" } vget() { strip_tag "$1" eval "r=\${${r}[${2}]}" } count_array() { strip_tag "$1" eval "r=\${#${r}[@]}" } append() { local i strip_tag "$1" eval "i=\${#${r}[@]}" eval "${r}[${i}]=\"${2}\"" r="$1" } 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 ((i < len2)); do eval "${a1}[((${i} + ${len1}))]=\"\${${a2}[${i}]}\"" ((i++)) done r="$1" } prepend() { local i len strip_tag "$2" eval "len=\${#${r}[@]}" while ((len > 0)); do eval "${r}[${len}]=\"\${${r}[((len - 1))]}\"" ((len--)) done eval "${r}[0]=\"$1\"" r="$2" } dup() { new_array local aptr="$r" strip_tag "$aptr" local narr="$r" strip_tag "$1" local len eval "len=\${#${r}[@]}" local i=0 while ((i < len)); do eval "${narr}[${i}]=\"\${${r}[${i}]}\"" ((i++)) done r="$aptr" } concat() { dup "$1" append_all "$r" "$2" } vector() { local v="$2" if [[ "$EMPTY" == "$v" || -z "$v" || "$NIL" == "$v" ]]; then new_array v="$r" fi prepend $1 $v } protect() { protected_ptr="$((protected_ptr + 1))" protected["$protected_ptr"]="$1" } unprotect() { protected_ptr="$((protected_ptr - 1))"; } acc_count=0 mark_seq() { local object="$1" while typeP "$object" cons && [[ -z "${marks[$object]}" ]]; do marks["$object"]=1 mark_acc[acc_count++]="${car[$object]}" object="${cdr[$object]}" done if typeP "$object" vector ; then count_array "$object" local i sz="$r" for ((i=0; i&2 IFS="$DEFAULT_IFS" mark "$current_env" for k in "${!environments[@]}"; do mark "${environments[$k]}"; done for k in "${!protected[@]}"; do mark "${protected[$k]}"; done for k in "${!stack[@]}"; do mark "${stack[$k]}"; done for k in "${!global_bindings[@]}"; do mark "${global_bindings[$k]}"; done cons_ptr=0 while [[ -n "${marks[${tag_marker}002${cons_ptr}]}" ]]; do unset marks["${tag_marker}002$((cons_ptr++))"] done if [[ $cons_ptr == $cons_limit ]]; then echo "expanding heap..." >&2 cons_limit=$((cons_limit + heap_increment)) fi } # reader ####################################################################### interpret_token() { [[ "$1" =~ ^-?[[:digit:]]+$ ]] \ && r=integer && return [[ "$1" =~ ^:([[:graph:]]|$pb_star)+$ ]] \ && r=keyword && return [[ "$1" =~ ^([[:graph:]]|$pb_star)+$ ]] \ && r=symbol && return return 1 } read_token() { local token="" while $_getc; do if [[ "$r" =~ ('('|')'|'['|']'|[[:space:]]|$pb_newline|,) ]]; then $_ungetc && break else token="${token}${r/\*/${pb_star}}" fi done [ -z "$token" ] && return 1 if interpret_token "$token"; then case "$r" in symbol) intern_symbol "$token" && return ;; integer) make_integer "$token" && return ;; keyword) make_keyword "$token" && return ;; *) error "unknown token type: '$r'" esac else error "unknown token: '${token}'" fi } skip_blanks() { $_getc while [[ "$r" =~ ([[:space:]]|$pb_newline|,) ]]; do $_getc; done $_ungetc } skip_comment() { $_getc while [[ "$r" != "$pb_newline" ]]; do $_getc; done } read_list() { local ch read1 read2 if lisp_read; then read1="$r" else $_getc r="$NIL" return fi $_getc && ch="$r" case "$ch" in ".") lisp_read && read2="$r" skip_blanks $_getc cons "$read1" "$read2" ;; ")") cons "$read1" $NIL ;; *) $_ungetc read_list cons "$read1" "$r" esac } read_vector() { local ch read1 if lisp_read; then read1="$r" else getc r="$EMPTY" return fi skip_blanks getc if [[ "$r" == "]" ]]; then vector "$read1" "$EMPTY" else ungetc skip_blanks read_vector vector "$read1" "$r" fi } read_string() { local s="" while true; do $_getc if [[ "$r" == "\\" ]]; then $_getc if [[ "$r" == '"' ]]; then s="${s}${r}" else s="${s}\\${r}" fi elif [[ "$r" == '"' ]]; then break else s="${s}${r}" fi done r="$(echo "$s" | tr "$pb_star" '*')" } lisp_read() { local ch read1 read2 read3 read4 skip_blanks; $_getc; ch="$r" case "$ch" in "\"") read_string ;; "(") read_list ;; "[") read_vector ;; "'") lisp_read && read1="$r" cons "$read1" $NIL && read2="$r" cons $QUOTE "$read2" ;; ";") skip_comment lisp_read ;; *) $_ungetc read_token esac } string_list() { local c="$1" ret shift if [[ "$1" == "" ]]; then cons $c $NIL && ret="$r" else string_list $* cons $c $r && ret="$r" fi r="$ret" } # printer ###################################################################### printing= escape_str() { local i c r="" for ((i=0; i < ${#1}; i++)); do c="${1:$i:1}" case "$c" in \") r="${r}\\\"" ;; \\) r="${r}\\\\" ;; *) r="${r}${c}" esac done } str_arr() { local ret="[" count_array "$1" local len=$r if (( 0 != len )); then vget $1 0 str "$r" ret="${ret}${r}" for ((i=1 ; i < $len ; i++)); do vget $1 $i str "$r" ret="${ret} ${r}" done fi r="${ret}]" } str_list() { local lst="$1" local ret if [[ "${car[$lst]}" == $FN ]]; then strip_tag "$lst" && printf -v r '#' "$r" else ret="(" str "${car[$lst]}" ret="${ret}${r}" lst="${cdr[$lst]}" while typeP "$lst" cons ; do str "${car[$lst]}" ret="${ret} ${r}" lst="${cdr[$lst]}" done if [[ "$lst" != $NIL ]]; then str "$lst" ret="${ret} . ${r}" fi r="${ret})" fi } str() { type "$1" case "$r" in integer) strip_tag "$1" && printf -v r '%d' "$r" ;; cons) str_list "$1" ;; vector) str_arr "$1" ;; symbol) strip_tag "$1" && printf -v r '%s' "$(echo "${symbols[$r]}" | tr $pb_star "*")" ;; keyword) strip_tag "$1" && printf -v r ':%s' "$r" ;; *) if [[ -n $printing ]]; then escape_str "$1" printf -v r '"%s"' "$r" else printf -v r '%s' "$1" fi ;; esac } prn() { printing=1 str "$1" printing= printf '%s' "$r" && echo } # environment & control ######################################################## frame_ptr=0 stack_ptr=0 declare -a stack intern_symbol '&' && AMP="$r" intern_symbol 'nil' && NIL="$r" intern_symbol 't' && T="$r" global_bindings[$NIL]="$NIL" global_bindings[$T]="$T" car[$NIL]="$NIL" cdr[$NIL]="$NIL" new_array && EMPTY="$r" current_env="$NIL" intern_symbol 'quote' && QUOTE=$r intern_symbol 'fn' && FN=$r intern_symbol 'if' && IF=$r intern_symbol 'set!' && SET_BANG=$r intern_symbol 'def' && DEF=$r intern_symbol 'do' && DO=$r intern_symbol 'recur' && RECUR=$r intern_symbol 'binding' && BINDING=$r declare -A specials specials[$QUOTE]=1 specials[$FN]=1 specials[$IF]=1 specials[$SET_BANG]=1 specials[$DEF]=1 specials[$DO]=1 specials[$RECUR]=1 specials[$BINDING]=1 defprim 'eq?' && EQ=$r defprim 'nil?' && NILP=$r defprim 'car' && CAR=$r defprim 'cdr' && CDR=$r defprim 'cons' && CONS=$r defprim 'list' && LIST=$r defprim 'vector' && VECTOR=$r defprim 'keyword' && KEYWORD=$r defprim 'eval' && EVAL=$r defprim 'apply' && APPLY=$r defprim 'read' && READ=$r defprim '+' && ADD=$r defprim '-' && SUB=$r defprim "$pb_star" && MUL=$r defprim '/' && DIV=$r defprim 'mod' && MOD=$r defprim '<' && LT=$r defprim '>' && GT=$r defprim 'cons?' && CONSP=$r defprim 'symbol?' && SYMBOLP=$r defprim 'number?' && NUMBERP=$r defprim 'string?' && STRINGP=$r defprim 'fn?' && FNP=$r defprim 'gensym' && GENSYM=$r defprim 'random' && RAND=$r defprim 'exit' && EXIT=$r defprim 'println' && PRINTLN=$r defprim 'sh' && SH=$r defprim 'sh!' && SH_BANG=$r defprim 'load-file' && LOAD_FILE=$r defprim 'gc' && GC=$r defprim 'error' && ERROR=$r defprim 'type' && TYPE=$r defprim 'str' && STR=$r defprim 'split' && SPLIT=$r defprim 'getenv' && GETENV=$r eval_args() { local args="$1" type "$args" if [[ "$r" == cons ]]; then while [[ "$args" != $NIL ]]; do lisp_eval "${car[$args]}" stack[$((stack_ptr++))]="$r" args="${cdr[$args]}" done elif [[ "$r" == vector ]]; then count_array "$args" local i len="$r" for ((i=0; i y)) && r=$T || r=$NIL fi ;; $CONSP) typeP "$arg0" cons && r=$T ;; $SYMBOLP) typeP "$arg0" symbol && r=$T || r=$NIL ;; $NUMBERP) typeP "$arg0" integer && r=$T || r=$NIL ;; $STRINGP) typeP "$arg0" string && r=$T || r=$NIL ;; $FNP) typeP "$arg0" cons && [[ "${car[$arg0]}" == $FN ]] && r=$T ;; $GC) gc && r=$NIL ;; $GENSYM) gensym ;; $ADD) if check_numbers "$arg0" "$arg1" ; then strip_tag "$arg0" && local x="$r" strip_tag "$arg1" && local y="$r" make_integer $((x + y)) fi ;; $SUB) if check_numbers "$arg0" "$arg1" ; then strip_tag "$arg0" && local x="$r" strip_tag "$arg1" && local y="$r" make_integer $((x - y)) fi ;; $APPLY) local old_frame_ptr=$frame_ptr frame_ptr=$stack_ptr type "$arg1" case $r in cons) while typeP "$arg1" cons; do stack[$((stack_ptr++))]="${car[$arg1]}" arg1="${cdr[$arg1]}" done [[ $arg1 != $NIL ]] && error "Bad argument to apply: not a proper list" ;; vector) count_array "$arg1" local len="$r" for ((i=0; i&2 prn "$arg0" >&2 ;; $TYPE) if [[ "$arg0" == $NIL ]]; then r=$NIL else type "$arg0" if [[ "$r" == cons ]] && [[ "${car[$arg0]}" == $FN ]]; then intern_symbol "function" else intern_symbol "$r" fi fi ;; $MUL) if check_numbers "$arg0" "$arg1" ; then strip_tag "$arg0" && local x="$r" strip_tag "$arg1" && local y="$r" make_integer $((x * y)) fi ;; $DIV) local x y if check_numbers "$arg0" "$arg1" ; then strip_tag $arg0 && x=$r strip_tag $arg1 && y=$r make_integer $((x / y)) fi ;; $RAND) if check_numbers "$arg0" ; then strip_tag $arg0 make_integer "$((RANDOM % r))" fi ;; $PRINTLN) listify_args && local to_print="$r" while [[ "$to_print" != "$NIL" ]]; do type "${car[$to_print]}" case "$r" in string) echo -e "${car[$to_print]}" ;; *) prn "${car[$to_print]}" ;; esac to_print="${cdr[$to_print]}" done r="$NIL" ;; $SH) local ret eval "ret=\$(${arg0})" IFS=$'\n' string_list $(for i in $ret; do echo "$i"; done) IFS="$DEFAULT_IFS" ;; $SH_BANG) eval "${arg0}" [[ $? == 0 ]] && r=$T || r=$NIL ;; $LOAD_FILE) local f if [[ -r ${arg0} ]]; then f="${arg0}" elif [[ -r "${arg0}.gk" ]]; then f="${arg0}.gk" fi if [[ "$f" != "" ]]; then eval_file "$f" else echo "File not found: ${arg0}" >&2 r="$NIL" fi ;; $EXIT) strip_tag $arg0 exit "$r" ;; *) strip_tag "$1" && error "unknown primitive function type: ${symbols[$r]}" return 1 esac } apply() { if [[ "${car[$1]}" == "$FN" ]]; then apply_user "$1" else apply_primitive "$1" fi } add_bindings() { type "$1" if [[ $r == cons ]]; then local pairs="$1" val while [[ "$pairs" != $NIL && "${cdr[$pairs]}" != $NIL ]]; do lisp_eval "${car[${cdr[$pairs]}]}" && val="$r" if [[ -n "$e" ]]; then return 1; fi acons "${car[$pairs]}" "$val" "$current_env" && current_env="$r" pairs="${cdr[${cdr[$pairs]}]}" done if [[ "$pairs" != $NIL ]]; then error "Bad bindings. Must be an even number of binding forms." return 1 fi elif [[ "$r" == vector ]]; then count_array "$1" local i v len="$r" if (( len % 2 == 0 )); then for (( i=0; i&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 done } # start ######################################################################## eval_string() { local str="$1" lisp_read <<<"(do $str)" protect "$r" lisp_eval "$r" unprotect } # Start REPL if no arguments [ -z "$*" ] && repl ARGV="$*" # Process parameters while [ "$*" ]; do param=$1; shift; OPTARG=$1 case $param in -e|--eval) eval_string "$OPTARG"; shift [[ $r != $NIL ]] && prn $r ;; -l|--load) eval_file "$OPTARG"; shift [[ $r != $NIL ]] && prn $r ;; -t|--test) ;; -r|--repl) repl ;; -*) usage ;; *) [[ -f "$param" ]] && has_shebangP "$param" && eval_file "$param" [[ $r != $NIL ]] && prn $r ;; esac done