suzanne.soy/os
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

nano-scheme: fixed lexer, added some debug output.

Browse Source
This commit is contained in:
Georges Dupéron 2019-03-02 00:53:49 +01:00
parent af3ed23c8f
commit a215e3650a
1 changed files with 53 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
micro-scheme/nano-scheme.sh
View File

@ -9,7 +9,8 @@
# l lambda # l lambda
# r read byte # r read byte
# w write byte # w write byte
# q quote next byte in the source # b quote next byte in the source
# q quotes its argument
# i byte to int # i byte to int
# c cons # c cons
# n null # n null
@ -38,11 +39,11 @@
# F free cell ptr # F free cell ptr
# I integer int # I integer int
# Y symbol hex # Y symbol hex
# O lexer "(" mark "_"
# #
# Note: hex strings must not contain any spaces. # Note: hex strings must not contain any spaces.
h=0 h=0
s=0
heap_sbrk() { h=$(($h+1)); } heap_sbrk() { h=$(($h+1)); }
heap_get_type() { eval a=\$t$1; } heap_get_type() { eval a=\$t$1; }
@ -58,34 +59,72 @@ heap_debug() { for heap_debug_i in `seq $h`; do
heap_get_cdr $heap_debug_i; printf %s\\n $a heap_get_cdr $heap_debug_i; printf %s\\n $a
done } done }
stack_debug() { for stack_debug_i in `seq $s`; do
printf "<%s " $stack_debug_i
eval a=\$s$stack_debug_i
printf "%s>" $a
done
printf \\n; }
rlist() { rlist() {
rlist_ptr=$h
heap_sbrk; heap_set $h N _ heap_sbrk; heap_set $h N _
rlist_cdr=$h rlist_cdr=$h
heap_get_type $rlist_ptr eval a=\$s$s
while test $a != O; do while test "$a" != M && test $s -ge 0; do
heap_sbrk; heap_set_pair $h P $rlist_ptr $rlist_cdr heap_sbrk; heap_set_pair $h P $a $rlist_cdr
rlist_cdr=$h rlist_cdr=$h
rlist_ptr=$(($rlist_ptr-1)) s=$(($s-1))
heap_get_type $rlist_ptr eval a=\$s$s
done done
a=$rlist_cdr if test $s -lt 0; then
printf 'Parse error: unbalanced parenthesis'\\n
exit 1
fi
eval s$s=$rlist_cdr
}
debug_print() {
heap_get_type $1
if test $a = P; then
if $2; then printf %s ' '; else printf %s '('; fi
heap_get_val $1
debug_print $a false
heap_get_cdr $1
debug_print $a true
if $2; then :; else printf %s ')'; fi
elif test $a = N; then
if $2; then :; else printf %s '()'; fi
elif test $a = Y; then
if $2; then printf %s '.'; fi
heap_get_val $1
printf %s $a | xxd -ps -r
if $2; then printf %s ')'; fi
else
if $2; then printf %s '.'; fi
printf %s $a
heap_get_val $1
printf %s $a
heap_get_cdr $1
printf %s $a
if $2; then printf %s ')'; fi
fi
} }
main() { main() {
printf '(lxx)' \ printf '(w((lxx)r))' \
| od -v -A n -t x1 \ | od -v -A n -t x1 \
| sed -e 's/^ //' \ | sed -e 's/^ //' \
| tr ' ' \\n \ | tr ' ' \\n \
| (while read c; do | (while read c; do
echo lex:$c echo lex:$c
case "$c" in case "$c" in
28) heap_sbrk; heap_set $h O _ ;; 28) s=$(($s+1)); eval s$s=M ;;
29) rlist ;; 29) stack_debug; rlist; stack_debug ;;
*) heap_sbrk; heap_set $h Y $c ;; *) heap_sbrk; heap_set $h Y $c; s=$(($s+1)); eval s$s=$h ;;
esac esac
done done
heap_debug) heap_debug
debug_print $h false)
} }
if true; then main; exit $?; fi if true; then main; exit $?; fi