openhsp-gc を使って再帰下降パーサ

openhsp-gc と後ろで定義されている関数を呼び出せるようにするパッチのテストとして再帰下降パーサを作ってみました。

通常の HSP や OpenHSP では動かすことのできないプログラムです。バイナリを公開したのでこちらでお試しください: openhsp-gc-bin.zip

これを発展させてちょっとしたインタプリタも作ってみようかなと思っています。

#define global null null_@
dimtype null_, vartype("struct")

#enum global node_type_literal = 1
#enum global node_type_binaryop
#enum global node_type_unaryop

#module mod_node m_type, m_val, m_children
#modcfunc node_get_type
	return m_type
#modcfunc node_get_val
	return m_val
#modcfunc node_get_lhs
	return m_children(0)
#modcfunc node_get_rhs
	return m_children(1)
#modfunc node_set_type int type
	m_type = type
	return
#modfunc node_set_val int val
	m_val = val
	return
#modfunc node_set_lhs struct node
	m_children(0) = node
	return
#modfunc node_set_rhs struct node
	m_children(1) = node
	return
#defcfunc new_node local instance
	newmod instance, mod_node
	return instance
#defcfunc new_literal_node int val, local instance
	instance = new_node()
	node_set_type instance, node_type_literal
	node_set_val instance, val
	return instance
#defcfunc new_binaryop_node int operator, struct lhs, struct rhs, local instance
	instance = new_node()
	node_set_type instance, node_type_binaryop
	node_set_val instance, operator
	node_set_lhs instance, lhs
	node_set_rhs instance, rhs
	return instance
#defcfunc new_unaryop_node int operator, struct lhs, local instance
	instance = new_node()
	node_set_type instance, node_type_unaryop
	node_set_val instance, operator
	node_set_lhs instance, lhs
	return instance
#modcfunc inspect_node local lhs, local rhs
	if m_type == node_type_literal {
		return str(m_val)
	} else : if m_type == node_type_binaryop {
		lhs = inspect_node(node_get_lhs(thismod))
		rhs = inspect_node(node_get_rhs(thismod))
		return strf("(%c %s %s)", m_val, lhs, rhs)
	} else : if m_type == node_type_unaryop {
		lhs = inspect_node(node_get_lhs(thismod))
		return strf("(%c %s)", m_val, lhs)
	} else {
		assert 0
	}
#global

#module mod_parser m_src, m_pos, m_type, m_val
#enum token_type_num = 256
#enum token_type_end
#enum token_type_error
#modinit str src
	m_src = src
	m_pos = 0
	return
#define gettoken parser_gettoken thismod
#modfunc parser_gettoken
	while isspace(peek(m_src, m_pos))
		m_pos ++
	wend
	c = peek(m_src, m_pos)
	if isdigit(c) {
		m_type = token_type_num
		m_val = 0
		repeat
			c = peek(m_src, m_pos)
			if isdigit(c) == 0 : break
			m_val = m_val * 10 + (c - '0')
			m_pos ++
		loop
		return
	}
	if c == 0 {
		m_type = token_type_end
		m_val = 0
		return
	}
	m_type = c
	m_val = 0
	m_pos ++
	return
#define ctype accept(%1) parser_accept(thismod, %1)
#modcfunc parser_accept int type
	if m_type == type {
		gettoken
		return 1
	}
	return 0
#define expect(%1) parser_expect thismod, %1
#modfunc parser_expect int type
	if m_type == type {
		gettoken
	} else {
		m_type = token_type_error
	}
	return
#modcfunc parse_factor local val, local result
	if m_type == token_type_num {
		val = m_val
		gettoken
		return new_literal_node(val)
	}
	if accept('(') {
		result = parse_expr(thismod)
		expect ')'
		return result
	}
	m_type = token_type_error
	return null
#modcfunc parse_unary local op
	if m_type == '+' or m_type == '-' {
		op = m_type
		gettoken
		return new_unaryop_node(op, parse_unary(thismod))
	} else {
		return parse_factor(thismod)
	}
#modcfunc parse_muldiv local op, local result
	result = parse_unary(thismod)
	while m_type == '*' or m_type == '/'
		op = m_type
		gettoken
		result = new_binaryop_node(op, result, parse_unary(thismod))
	wend
	return result
#modcfunc parse_addsub local op, local result
	result = parse_muldiv(thismod)
	while m_type == '+' or m_type == '-'
		op = m_type
		gettoken
		result = new_binaryop_node(op, result, parse_muldiv(thismod))
	wend
	return result
#modcfunc parse_expr
	return parse_addsub(thismod)
#modcfunc parser_parse local result
	gettoken
	result = parse_expr(thismod)
	if m_type != token_type_end {
		return null
	}
	return result
#defcfunc parse str src, local parser
	newmod parser, mod_parser, src
	return parser_parse(parser)
#global

#module
#defcfunc eval_node struct node, local type, local result
	type = node_get_type(node)
	switch type
	case node_type_literal
		return node_get_val(node)
	case node_type_binaryop
		return eval_binaryop_node(node)
	case node_type_unaryop
		return eval_unaryop_node(node)
	default
		assert 0
	swend
#defcfunc eval_binaryop_node struct node, local op, local lhs, local rhs
	op = node_get_val(node)
	lhs = node_get_lhs(node)
	rhs = node_get_rhs(node)
	switch op
	case '+'
		return eval_node(lhs) + eval_node(rhs)
	case '-'
		return eval_node(lhs) - eval_node(rhs)
	case '*'
		return eval_node(lhs) * eval_node(rhs)
	case '/'
		return eval_node(lhs) / eval_node(rhs)
	default
		assert 0
	swend
#defcfunc eval_unaryop_node struct node, local op, local lhs
	op = node_get_val(node)
	lhs = node_get_lhs(node)
	switch op
	case '+'
		return eval_node(lhs)
	case '-'
		return - eval_node(lhs)
	default
		assert 0
	swend
#global

#module
#defcfunc isdigit int c
	return '0' <= c and c <= '9'
#defcfunc isspace int c
	if c == '\t' : return 1
	if c == 0x0a : return 1 // '\n'
	if c == 0x0b : return 1 // '\v'
	if c == 0x0c : return 1 // '\f'
	if c == '\r' : return 1
	if c == ' '  : return 1
	return 0
#global

#runtime "hsp3cl"

#uselib "msvcrt.dll"
#func printf "printf" str, str
#define write(%1) printf "%%s", %1

	repeat
		write "expr> "
		input expr,, 2
		if expr == "" : break
		node = parse(expr)
		if node == null {
			mes "syntax error"
		} else {
			mes inspect_node(node)
			mes "=> "+eval_node(node)
		}
	loop