Fuji Diablog

openhsp-gc を使って簡易インタプリタ (1)

2009-06-19T22:02:14+09:00

openhsp-gc と後ろで定義されている関数を呼び出せるようにするパッチのテストとしてちょっとしたインタプリタを作ってみたその途中経過です。openhsp-gc を使って再帰下降パーサの拡張です。

まだ変数代入とif文くらいしかないのであまり面白くありません。

通常の 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
#enum global node_type_varref
#enum global node_type_assign
#enum global node_type_list
#enum global node_type_if

#enum global optype_eq = 256
#enum global optype_ne
#enum global optype_lteq
#enum global optype_gteq
#enum global optype_and
#enum global optype_or
#enum global optype_lsh
#enum global optype_rsh

#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_child int n
	return m_children(n)
#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_val_str str val
	m_val = val
	return
#modfunc node_set_child int n, struct node
	m_children(n) = node
	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
#defcfunc new_varref_node str name, local instance
	instance = new_node()
	node_set_type instance, node_type_varref
	node_set_val_str instance, name
	return instance
#defcfunc new_assign_node str name, struct rhs, local instance
	instance = new_node()
	node_set_type instance, node_type_assign
	node_set_val_str instance, name
	node_set_child instance, 0, rhs
	return instance
#defcfunc new_list_node local instance
	instance = new_node()
	node_set_type instance, node_type_list
	node_set_val instance, 0 // length
	return instance
#defcfunc new_list_node_1 struct child, local instance
	instance = new_list_node()
	append_list_node instance, child
	return instance
#modfunc append_list_node struct child
	node_set_child thismod, node_get_val(thismod), child
	node_set_val thismod, node_get_val(thismod) + 1
	return
#modcfunc get_list_node_len
	return node_get_val(thismod)
#defcfunc new_if_node struct cond, struct then_part, struct else_part, local instance
	instance = new_node()
	node_set_type instance, node_type_if
	node_set_child instance, 0, cond
	node_set_child instance, 1, then_part
	node_set_child instance, 2, else_part
	return instance
#modcfunc get_if_node_cond
	return node_get_child(thismod, 0)
#modcfunc get_if_node_then
	return node_get_child(thismod, 1)
#modcfunc get_if_node_else
	return node_get_child(thismod, 2)
#modcfunc inspect_node local lhs, local rhs
	if thismod == null {
		return "null"
	}
	switch m_type
	case node_type_literal
		return str(m_val)
	case node_type_binaryop
		lhs = inspect_node(node_get_lhs(thismod))
		rhs = inspect_node(node_get_rhs(thismod))
		return strf("(%s %s %s)", optype_to_str(m_val), lhs, rhs)
	case node_type_unaryop
		lhs = inspect_node(node_get_lhs(thismod))
		return strf("(%s %s)", optype_to_str(m_val), lhs)
	case node_type_varref
		return m_val
	case node_type_assign
		return strf("(= %s %s)", m_val, inspect_node(node_get_child(thismod, 0)))
	case node_type_list
		return inspect_node_list(thismod)
	case node_type_if
		return inspect_if_node(thismod)
	default
		assert 0
	swend
#modcfunc inspect_node_list local result
	result = "["
	repeat get_list_node_len(thismod)
		if cnt != 0 : result += ", "
		result += inspect_node(node_get_child(thismod, cnt))
	loop
	result += "]"
	return result
#modcfunc inspect_if_node local cond, local then_part, local else_part
	cond = inspect_node(get_if_node_cond(thismod))
	then_part = inspect_node(get_if_node_then(thismod))
	else_part = inspect_node(get_if_node_else(thismod))
	return strf("(if %s %s %s)", cond, then_part, else_part)
#defcfunc optype_to_str int optype
	if optype < 256 : return strf("%c", optype)
	switch optype
#define ctype CT(%1,%2) case optype_%1: return %2 
	CT(eq, "==")
	CT(ne, "!=")
	CT(lteq, "<=")
	CT(gteq, ">=")
	CT(and, "&&")
	CT(or, "||")
	CT(lsh, "<<")
	CT(rsh, "<<")
#undef CT
	swend
	assert 0
#global

#module mod_dict m_dc
#modinit
	newcom m_dc, "Scripting.Dictionary"
	m_dc("compareMode") = 0
	return
#modfunc dict_put str key, int val
	m_dc("Item", key) = val
	return
#modfunc dict_putv str key, var val
	m_dc("Item", key) = val
	return
#modcfunc dict_get str key
	return m_dc("Item", key)
#modfunc dict_remove str key
	m_dc->"Remove" key
	return
#modcfunc dict_has str key
	return m_dc("Exists", key)
#modcfunc dict_size
	return m_dc("Count")
#modfunc dict_clear
	m_dc->"RemoveAll"
	return
#defcfunc new_dict local instance
	newmod instance, mod_dict
	return instance
#global

#module mod_parser m_src, m_pos, m_type, m_val, m_reserved
#enum token_type_num = 256
#enum token_type_ident
#enum token_type_eq
#enum token_type_ne
#enum token_type_lteq
#enum token_type_gteq
#enum token_type_and
#enum token_type_or
#enum token_type_lsh
#enum token_type_rsh
#enum token_type_if
#enum token_type_else
#enum token_type_end
#enum token_type_error
#modinit str src
	m_src = src
	m_pos = 0
	m_reserved = new_dict()
	dict_put m_reserved, "if", token_type_if
	dict_put m_reserved, "else", token_type_else
	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 ('A' <= c and c <= 'Z') or c == '_' or ('a' <= c and c <= 'z') {
		len = 0
		while ('0' <= c and c <= '9') or ('A' <= c and c <= 'Z') or c == '_' or ('a' <= c and c <= 'z')
			len ++
			c = peek(m_src, m_pos + len)
		wend
		m_type = token_type_ident
		m_val = strmid(m_src, m_pos, len)
		if (dict_has(m_reserved, m_val)) {
			m_type = dict_get(m_reserved, m_val)
			m_val = 0
		}
		m_pos += len
		return
	}
	if c == 0 {
		m_type = token_type_end
		m_val = 0
		return
	}
	m_val = 0
	m_pos ++
	m_type = c
	
	if c == '<' {
		switch peek(m_src, m_pos)
		case '<'
			m_type = token_type_lsh
			m_pos ++
			swbreak
		case '='
			m_type = token_type_lteq
			m_pos ++
		swend
	} else : if c == '>' {
		switch peek(m_src, m_pos)
		case '>'
			m_type = token_type_rsh
			m_pos ++
			swbreak
		case '='
			m_type = token_type_gteq
			m_pos ++
		swend
	} else : if c == '=' {
		if peek(m_src, m_pos) == '=' {
			m_type = token_type_eq
			m_pos ++
		}
	} else : if c == '!' {
		if peek(m_src, m_pos) == '=' {
			m_type = token_type_ne
			m_pos ++
		}
	} else : if c == '&' {
		if peek(m_src, m_pos) == '&' {
			m_type = token_type_and
			m_pos ++
		}
	} else : if c == '|' {
		if peek(m_src, m_pos) == '|' {
			m_type = token_type_or
			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
#defcfunc token_type_to_op_type int token_type
	if token_type < 256 : return token_type
	switch token_type
#define ctype CT(%1) case token_type_%1: return optype_%1
	CT(eq)
	CT(ne)
	CT(lteq)
	CT(gteq)
	CT(and)
	CT(or)
	CT(lsh)
	CT(rsh)
#undef CT
	swend
	assert 0
#modcfunc parse_factor local val, local result
	if m_type == token_type_num {
		val = m_val
		gettoken
		return new_literal_node(val)
	}
	if m_type == token_type_ident {
		val = m_val
		gettoken
		if m_type == '=' {
			gettoken
			result = parse_expr(thismod)
			return new_assign_node(val, result)
		}
		return new_varref_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 == '-' or m_type == '!' or m_type == '~' {
		op = token_type_to_op_type(m_type)
		gettoken
		return new_unaryop_node(op, parse_unary(thismod))
	} else {
		return parse_factor(thismod)
	}

#define lvars_parse_binop local op, local result
#define body_parse_binop(%1, %2) \
	result = %1(thismod) : \
	while %2 : \
		op = token_type_to_op_type(m_type) : \
		gettoken : \
		result = new_binaryop_node(op, result, %1(thismod)) : \
	wend : \
	return result

#modcfunc parse_muldiv lvars_parse_binop
	body_parse_binop parse_unary, m_type == '*' or m_type == '/' or m_type == '%'

#modcfunc parse_addsub lvars_parse_binop
	body_parse_binop parse_muldiv, m_type == '+' or m_type == '-'

#modcfunc parse_shift lvars_parse_binop
	body_parse_binop parse_addsub, m_type == token_type_lsh or m_type == token_type_rsh

#modcfunc parse_bitand lvars_parse_binop
	body_parse_binop parse_shift, m_type == '&'

#modcfunc parse_bitor lvars_parse_binop
	body_parse_binop parse_bitand, m_type == '|' or m_type == '^'

#defcfunc is_compare_op int token_type
	if token_type == token_type_eq : return 1
	if token_type == token_type_ne : return 1
	if token_type == '<' : return 1
	if token_type == '>' : return 1
	if token_type == token_type_lteq : return 1
	if token_type == token_type_gteq : return 1
	return 0
#modcfunc parse_compare lvars_parse_binop
	body_parse_binop parse_bitor, is_compare_op(m_type)

#modcfunc parse_and lvars_parse_binop
	body_parse_binop parse_compare, m_type == token_type_and

#modcfunc parse_or lvars_parse_binop
	body_parse_binop parse_and, m_type == token_type_or

#modcfunc parse_condop local result, local then_part, local else_part
	result = parse_or(thismod)
	if accept('?') {
		then_part = new_list_node_1(parse_expr(thismod))
		expect ':'
		else_part = new_list_node_1(parse_condop(thismod))
		result = new_if_node(result, then_part, else_part)
	}
	return result
#modcfunc parse_expr
	return parse_condop(thismod)
#modcfunc parse_if_stmt local cond, local then_part, local else_part
	expect '('
	cond = parse_expr(thismod)
	expect ')'
	then_part = parse_stmt(thismod)
	if accept(token_type_else) {
		else_part = parse_stmt(thismod)
	} else {
		else_part = new_list_node()
	}
	return new_if_node(cond, then_part, else_part)
#modcfunc parse_stmt local result
	if accept(';') {
		return null
	}
	if accept('{') {
		result = parse_stmt_list(thismod)
		expect '}'
		return result
	}
	if accept(token_type_if) {
		return parse_if_stmt(thismod)
	}
	result = parse_expr(thismod)
	expect ';'
	return result
#modcfunc parse_stmt_list local result, local stmt, local pos_bak, local type_bak
	result = new_list_node()
	repeat
		pos_bak = m_pos
		type_bak = m_type
		stmt = parse_stmt(thismod)
		if m_type == token_type_error and m_pos == pos_bak {
			m_type = type_bak
			break
		}
		if stmt != null : append_list_node result, stmt
	loop
	return result
#modcfunc parser_parse local result
	gettoken
	result = parse_stmt_list(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 mod_evaluator m_root, m_varmap
#modinit struct root
	m_root = root
	m_varmap = new_dict()
	return
#modcfunc 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(thismod, node)
	case node_type_unaryop
		return eval_unaryop_node(thismod, node)
	case node_type_varref
		if dict_has(m_varmap, node_get_val(node)) == 0 {
			error "undefined variable: "+node_get_val(node)
		}
		return dict_get(m_varmap, node_get_val(node))
	case node_type_assign
		result = eval_node(thismod, node_get_child(node, 0))
		dict_put m_varmap, node_get_val(node), result
		return result
	case node_type_list
		result = 0
		repeat get_list_node_len(node)
			result = eval_node(thismod, node_get_child(node, cnt))
		loop
		return result
	case node_type_if
		return eval_if_node(thismod, node)
	default
		assert 0
	swend
#modcfunc eval_binaryop_node struct node, local op, local lhs, local rhs, local result
	op = node_get_val(node)
	lhs = node_get_lhs(node)
	rhs = node_get_rhs(node)
	switch op
#define CT(%1,%2) case %1: return eval_node(thismod, lhs) %2 eval_node(thismod, rhs)
	CT '+', +
	CT '-', -
	CT '*', *
	CT '/', /
	CT '%', \
	CT optype_lsh, <<
	CT optype_rsh, >>
	CT '&', &
	CT '|', |
	CT '^', ^
	CT optype_eq, ==
	CT optype_ne, !=
	CT '<', <
	CT '>', >
	CT optype_lteq, <=
	CT optype_gteq, >=
#undef CT
	case optype_and
		result = eval_node(thismod, lhs)
		if result == 0 : return result
		return eval_node(thismod, rhs)
	case optype_or
		result = eval_node(thismod, lhs)
		if result : return result
		return eval_node(thismod, rhs)
	swend
	assert 0
#modcfunc 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(thismod, lhs)
	case '-'
		return - eval_node(thismod, lhs)
	case '!'
		return eval_node(thismod, lhs) != 0
	case '~'
		return eval_node(thismod, lhs) ^ -1
	default
		assert 0
	swend
#modcfunc eval_if_node struct node
	cond = eval_node(thismod, get_if_node_cond(node))
	if cond {
		return eval_node(thismod, get_if_node_then(node))
	} else {
		return eval_node(thismod, get_if_node_else(node))
	}
#defcfunc evaluate struct root, local evaluator
	newmod evaluator, mod_evaluator, root
	return eval_node(evaluator, root)
#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
#deffunc error str msg
	dialog msg
	end
#global

	program = {"
		a = 42;
		if (a >= 100) {
			b = 1;
		} else if (a >= 0) {
			b = 2;
		} else {
			b = 3;
		}
	"}
	node = parse(program)
	if node == null {
		mes "syntax error"
	} else {
		mes inspect_node(node)
		mes "=> "+evaluate(node)
	}

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

2009-06-14T16:07:07+09:00

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

モジュール変数の GC を公開しました

2009-06-06T14:34:44+09:00

OpenHSP にモジュール変数の GC を追加した「openhsp-gc」を公開しました。

openhsp-gc

たとえば、次のようなスクリプトを動かすことができます。

#module mod_human m_name
#modinit str name
	m_name = name
	return
#defcfunc new_human str name, local instance
	newmod instance, mod_human, name
	return instance
#modcfunc human_get_name
	return m_name
#global
	mes human_get_name(new_human("Taro"))

#module mod_elem m_val, m_next
#modinit int val
	m_val = val
	dimtype m_next, vartype("struct")
	return
#defcfunc new_elem int val, local instance
	newmod instance, mod_elem, val
	return instance
#modcfunc elem_get_val
	return m_val
#modcfunc elem_get_next
	return m_next
#modfunc elem_set_next struct next_
	m_next = next_
	return
#global

#module mod_list m_first, m_last
#modinit
	m_first = new_elem(0)
	m_last = m_first
	return
#defcfunc new_list local instance
	newmod instance, mod_list
	return instance
#modcfunc list_get_first
	return m_first
#modcfunc list_get_last
	return m_last
#modfunc list_push struct elem
	elem_set_next m_last, elem
	m_last = elem
	return
#modfunc list_concat struct other
	elem_set_next m_last, elem_get_next(list_get_first(other))
	m_last = list_get_last(other)
	return
#global

dimtype null, vartype("struct")

l1 = new_list()
l2 = new_list()

list_push l1, new_elem(1)
list_push l1, new_elem(2)
list_push l1, new_elem(3)

list_push l2, new_elem(5)
list_push l2, new_elem(6)

list_concat l1, l2

e = elem_get_next(list_get_first(l1))
while e != null
	mes elem_get_val(e)
	e = elem_get_next(e)
wend

gzoom のコピーする座標を動かせるようにしてみる

2008-11-21T16:19:17+09:00

gzoom のコピー元、コピー先それぞれの座標とサイズを動かし動作を確かめられるスクリプトです。gsquare のコピーする四角形座標を動かせるようにしてみるの gzoom 版です。

作ったきっかけは HSP on JS GUI の試みで gzoom を実装するときにオフィシャル HSP での gzoom の動作を確かめていたら、反転コピーするときにコピーする範囲が画像の範囲を超えていたときの挙動がおかしいと気づいたことです。

#module
#deffunc boxline int x1, int y1, int x2, int y2
	line x2, y1, x1, y1
	line x2, y2
	line x1, y2
	line x1, y1
	return
#deffunc boxline2 int x1, int y1, int x2, int y2
	if x1 < x2 : min_x = x1 : max_x = x2 : else : min_x = x2 : max_x = x1
	if y1 < y2 : min_y = y1 : max_y = y2 : else : min_y = y2 : max_y = y1
	color 255, 255, 255
	boxline min_x, min_y, max_x, max_y
	color
	boxline min_x - 1, min_y - 1, max_x + 1, max_y + 1
	return
#deffunc bordered_line int x1, int y1, int x2, int y2
	color
	line x1 - 1, y1, x2 - 1, y2
	line x1 + 1, y1, x2 + 1, y2
	line x1, y1 - 1, x2, y2 - 1
	line x1, y1 + 1, x2, y2 + 1
	color 255, 255, 255
	line x1, y1, x2, y2
	return
#deffunc draw_box array rect, int x, int y
	left = rect.0 : top = rect.1 : right = rect.2 : bottom = rect.3
	if left < right : sign_x = 1 : else : sign_x = -1
	if top < bottom : sign_y = 1 : else : sign_y = -1
	bordered_line x + left, y + top, x + right, y + top
	bordered_line x + right, y + top, x + right - 10 * sign_x, y + top - 5
	bordered_line x + right, y + top, x + right - 10 * sign_x, y + top + 5
	bordered_line x + left, y + top, x + left, y + bottom
	bordered_line x + left, y + bottom, x + left - 5, y + bottom - 10 * sign_y
	bordered_line x + left, y + bottom, x + left + 5, y + bottom - 10 * sign_y
	bordered_line x + right, y + top, x + right, y + bottom
	bordered_line x + left, y + bottom, x + right, y + bottom
	color
	circle x + left - 5, y + top - 5, x + left + 5, y + top + 5
	color 255, 255, 255
	circle x + left - 4, y + top - 4, x + left + 4, y + top + 4
	return
#defcfunc between int val, int edge1, int edge2
	if edge1 <= val and val <= edge2 : return 1
	if edge2 <= val and val <= edge1 : return 1
	return 0
#defcfunc circle_collision int ax, int ay, int bx, int by, int r
	return r * r >= (ax - bx) * (ax - bx) + (ay - by) * (ay - by)
#global

screen_id_src = 1
src_w = 128 : src_h = 128
buffer screen_id_src, src_w, src_h
repeat 16
    r = cnt * 255 / 15
    y = cnt * 8
    repeat 16
        g = cnt * 255 / 15
        x = cnt * 8
        color r, g
        boxf x, y, x + 7, y + 7
    loop
loop

screen_id_dest = 2
dest_w = 320 : dest_h = 240
buffer screen_id_dest, dest_w, dest_h

box_w = 400
box_h = 400
margin_size = 16

box_src_x = margin_size
box_src_y = margin_size
box_dest_x = margin_size * 2 + box_w
box_dest_y = margin_size

offset_src_x = box_src_x + box_w / 2 - src_w / 2
offset_src_y = box_src_y + box_h / 2 - src_h / 2

offset_dest_x = box_dest_x + box_w / 2 - dest_w / 2
offset_dest_y = box_dest_y + box_h / 2 - dest_h / 2

src_rect = 5, 5, 100, 100
dup src_left, src_rect.0
dup src_top, src_rect.1
dup src_right, src_rect.2
dup src_bottom, src_rect.3

dest_rect = 20, 20, dest_w - 20, dest_h - 20
dup dest_left, dest_rect.0
dup dest_top, dest_rect.1
dup dest_right, dest_rect.2
dup dest_bottom, dest_rect.3

screen_id_main = 0
screen screen_id_main, box_w * 2 + margin_size * 3, box_h + margin_size * 2

dragging = 0 // ドラッグ中の辺 (+1: left, +2: top, +4: right, +8: bottom, 16: center, 17: right click, +0: src, +32: dest)
prev_key = 0

repeat
	gosub *do_gzoom
	gsel screen_id_main
	stick key
	left_clicking_trigger = key & 256
	right_clicking_trigger = key & 512
	stick key, 256 + 512
	left_clicking = key & 256
	right_clicking = key & 512
	if left_clicking_trigger {
		dragging = 0
		repeat 2
			if cnt : gosub *dup_from_dest : else : gosub *dup_from_src
			gosub *collision_check_left
			if dragging : dragging |= 32 * cnt : break
		loop
	} else : if right_clicking_trigger {
		repeat 2
			if cnt : gosub *dup_from_dest : else : gosub *dup_from_src
			gosub *collision_check_right
			if dragging : dragging |= 32 * cnt : break
		loop
	}
	if dragging {
		if left_clicking | right_clicking {
			gosub *move
		} else {
			dragging = 0
		}
	}

	redraw 0
	color 255, 255, 255 : boxf
	color 128, 128, 128
	boxf box_src_x,  box_src_y,  box_src_x  + box_w - 1, box_src_y  + box_h - 1
	boxf box_dest_x, box_dest_y, box_dest_x + box_w - 1, box_dest_y + box_h - 1

	pos offset_src_x, offset_src_y
	gcopy screen_id_src, 0, 0, src_w, src_h

	pos offset_dest_x, offset_dest_y
	gcopy screen_id_dest, 0, 0, dest_w, dest_h

	draw_box src_rect, offset_src_x, offset_src_y
	draw_box dest_rect, offset_dest_x, offset_dest_y
	redraw
	await 16
loop
stop

*collision_check_left
	x = mousex - offset_x
	y = mousey - offset_y
	if circle_collision(x, y, left, top, 10) : dragging = 1+2 : return
	if circle_collision(x, y, right, top, 10) : dragging = 4+2 : return
	if circle_collision(x, y, right, bottom, 10) : dragging = 4+8 : return
	if circle_collision(x, y, left, bottom, 10) : dragging = 1+8 : return

	between_x = between(x, left, right)
	between_y = between(y, top, bottom)

	if between_y {
		if abs(x - left) <= 8 : dragging = 1 : return
		if abs(x - right) <= 8 : dragging = 4 : return
	}
	if between_x {
		if abs(y - top) <= 8 : dragging = 2 : return
		if abs(y - bottom) <= 8 : dragging = 8 : return
	}
	if between_x and between_y {
		dragging = 16
		drag_start_x = x
		drag_start_y = y
		dim drag_start_rect, 4
		memcpy drag_start_rect, rect, 4 * 4
	}
	return

*collision_check_right
	if between(mousex, box_x, box_x + box_w) and between(mousey, box_y, box_y + box_h) {
		dragging = 17
		left = mousex - offset_x
		top = mousey - offset_y
		right = mousex - offset_x
		bottom = mousey - offset_y
	}
	return

*move
	if dragging & 32 {
		gosub *dup_from_dest
	} else {
		gosub *dup_from_src
	}
	d = dragging & 31
	if d == 16 {
		// 枠の中のクリック: サイズを変えずに枠全体を移動
		if drag_start_rect.0 < drag_start_rect.2 {
			dup start_min_x, drag_start_rect.0 : dup start_max_x, drag_start_rect.2
			dup min_x, left : dup max_x, right
		} else {
			dup start_max_x, drag_start_rect.0 : dup start_min_x, drag_start_rect.2
			dup max_x, left : dup min_x, right
		}
		if drag_start_rect.1 < drag_start_rect.3 {
			dup start_min_y, drag_start_rect.1 : dup start_max_y, drag_start_rect.3
			dup min_y, top : dup max_y, bottom
		} else {
			dup start_max_y, drag_start_rect.1 : dup start_min_y, drag_start_rect.3
			dup max_y, top : dup min_y, bottom
		}
		x = start_min_x + mousex - drag_start_x
		if x < box_x {
			min_x = limit(x, box_x, box_x + box_w) - offset_x
			max_x = min_x + (start_max_x - start_min_x)
		} else {
			max_x = limit(start_max_x + mousex - drag_start_x, box_x, box_x + box_w) - offset_x
			min_x = max_x - (start_max_x - start_min_x)
		}
		y = start_min_y + mousey - drag_start_y
		if y < box_y {
			min_y = limit(y, box_y, box_y + box_h) - offset_y
			max_y = min_y + (start_max_y - start_min_y)
		} else {
			max_y = limit(start_max_y + mousey - drag_start_y, box_y, box_y + box_h) - offset_y
			min_y = max_y - (start_max_y - start_min_y)
		}
		return
	}
	if d == 17 {
		// 右クリック
		right = limit(mousex, box_x, box_x + box_w) - offset_x
		bottom = limit(mousey, box_y, box_y + box_h) - offset_y
		return
	}
	if d & 1 {
		left = limit(mousex, box_x, box_x + box_w) - offset_x
	} else : if d & 4 {
		right = limit(mousex, box_x, box_x + box_w) - offset_x
	}
	if d & 2 {
		top = limit(mousey, box_y, box_y + box_h) - offset_y
	} else : if d & 8 {
		bottom = limit(mousey, box_y, box_y + box_h) - offset_y
	}
	return

*dup_from_dest
	dup rect, dest_rect
	dup box_x, box_dest_x
	dup box_y, box_dest_y
	dup offset_x, offset_dest_x
	dup offset_y, offset_dest_y
	gosub *dup_rect
	return

*dup_from_src
	dup rect, src_rect
	dup box_x, box_src_x
	dup box_y, box_src_y
	dup offset_x, offset_src_x
	dup offset_y, offset_src_y
	gosub *dup_rect
	return

*dup_rect
	dup left, rect.0
	dup top, rect.1
	dup right, rect.2
	dup bottom, rect.3
	return

*do_gzoom
	gsel screen_id_dest
	color 200, 200, 200 : boxf
	pos dest_left, dest_top
	gzoom dest_right - dest_left, dest_bottom - dest_top, screen_id_src, src_left, src_top, src_right - src_left, src_bottom - src_top
	return

オフィシャル HSP でおかしな挙動をする具体例

オフィシャル HSP の表示結果
HSP on JS の表示結果

gsquare のコピーする四角形座標を動かせるようにしてみる

2008-08-11T22:54:20+09:00

src_x_list = 50, 590, 590, 50
src_y_list = 50, 50, 430, 430

dest_x_list = 50, 590, 540, 100
dest_y_list = 50, 50, 430, 430

buffer 3
buffer 2
picload dir_exe+"/sample/hspcv/bgsamp.jpg"
screen 1
screen 0

dragging = -1, -1
prev_key = 0, 0

repeat
    gsel 3
        color 255, 255, 255 : boxf
        gsquare 2, dest_x_list, dest_y_list, src_x_list, src_y_list
    gsel 0
        copy_from = 2
        dup x_list, src_x_list
        dup y_list, src_y_list
        gosub *draw
    gsel 1
        copy_from = 3
        dup x_list, dest_x_list
        dup y_list, dest_y_list
        gosub *draw
    await 16
loop
stop

*draw
    redraw 0
    color 255, 255, 255 : boxf
    pos 0, 0
    gcopy copy_from, 0, 0, 640, 480
    getkey key
    key &= ginfo_sel == ginfo_act
    if key & prev_key.ginfo_sel == 0 {
        repeat 4
            dx = mousex - x_list.cnt
            dy = mousey - y_list.cnt
            if 10 * 10 >= dx * dx + dy * dy {
                dragging.ginfo_sel = cnt
                break
            }
        loop
    }
    if dragging.ginfo_sel >= 0 {
        if key {
            x_list(dragging.ginfo_sel) = mousex
            y_list(dragging.ginfo_sel) = mousey
        } else {
            dragging.ginfo_sel = -1
        }
    }
    color 255
    pos x_list.3, y_list.3
    repeat 4
        line x_list.cnt, y_list.cnt
    loop
    prev_key.ginfo_sel = key
    redraw
    return

OpenHSP ver 3.2 の可変長引数対応 strf を HSP 3.1 でも使えるようにするプラグインを作ったよ

2008-05-13T15:19:00+09:00

strf_ex

OpenHSP ver 3.2 の strf は可変長引数対応になって便利なので、HSP 3.1 でも動かせるようにプラグインにしてみました。みんなぜひ使うといいと思うよ！

サンプル

付属しているサンプルとまったく同じものをここに掲載しておきます。

// サンプル
//     strf_ex : OpenHSP ver 3.2 の可変長引数対応 strf を HSP 3.1 でも使えるようにするプラグイン

// ファイル strf_ex.dll と次の 2 文で strf_ex が使えるようになります
#regcmd "hsp3cmdinit", "strf_ex.dll"
#cmd strf_ex 0

//標準の strf を置き換えることもできます
;#undef strf
;#define global strf strf_ex

mes strf_ex("<%s><%d><%f>", "hoge",123, 3.14) //=> <hoge><123><3.140000>

// 型が合わなければ自動的に変換されます
mes strf_ex( "<%s><%d><%f>", 123, 3.14, "hoge" ) //=> <123><3><0.000000>

mes strf_ex( "%%" ) //=> %

a = 0x80000000
mes strf_ex( "<%d><%u><%o><%x>", a, a, a, a ) //=> <-2147483648><2147483648><20000000000><80000000>

mes strf_ex( "%.3s", "hello" ) //=> hel
mes strf_ex( "<%06d>", 123 ) //=> <000123>

// `*' で幅や精度を引数から得る機能はありません！
;mes strf_ex( "<%.*s>", 3, "hello" ) //エラー
;mes strf_ex( "<%0*d>", 6, 123 ) //エラー

// 数が合わない場合もエラー
;mes strf_ex( "%d" ) //エラー
;mes strf_ex( "", 123 ) //エラー

// HSP 3.1 の strf では %s で文字列ポインタから文字列を取り出せました（仕様外）が、
// そうはできなくなりました。

a = "hoge"
mes strf( "<%s>", varptr(a) + 1 ) //=> <oge>
mes strf_ex( "<%s>", varptr(a) + 1 ) //=> <10683521>

// HSP 3.2 からは必ず dupptr をかましてやってください
a = "hoge"
dupptr b, varptr(a) + 1, 1, 2
mes strf_ex( "<%s>", b) //=> <oge>

// なんと3.1では第二引数が文字列だとそれ単体で返ってきてしまいます
// 3.2 ではそんなことはありません
mes strf( "<%s>", "abc") //=> abc
mes strf_ex( "<%s>", "abc") //=> <abc>

// 3.1 の strf は結果が長いと場合によっては異常終了したり、なぞのエラーが出たり、システムエラーが発生したりします
;mes strlen(strf("%05000d",0))
;mes strlen(strf("%06000d",0))
;mes strlen(strf("%07000d",0))
;mes strlen(strf("%08000d",0))

// 3.2 ではそんなことはありません
mes strlen(strf_ex("%05000d",0)) //=> 5000
mes strlen(strf_ex("%06000d",0)) //=> 6000
mes strlen(strf_ex("%07000d",0)) //=> 7000
mes strlen(strf_ex("%08000d",0)) //=> 8000
mes strlen(strf_ex("%0100000d",0)) //=> 100000

// こんなところかな。

HSP の rnd を再現

2008-03-28T13:30:59+09:00

HSP の rnd 関数の実装は以下のようになっています。（ OpenHSP trunc/hsp3/hsp3int.cpp#L493 ）

ival = code_geti();
if ( ival == 0 ) throw HSPERR_DIVIDED_BY_ZERO;
reffunc_intfunc_ivalue = rand()%ival;

C の標準ライブラリの rand の値を引数の値で剰余しているだけですね。

HSP は VC++ でビルドされています。 VC++ の rand の実装は良い乱数・悪い乱数に掲載されています。

ということで、HSP の rnd を再現してみると以下のような感じ。

#module
#defcfunc rnd2 int a
    x = x * 214013 + 2531011
    return ((x>>16)&32767)\a
#deffunc randomize2 int a
    x = a
    return
#global

randomize 12345
randomize2 12345

repeat 10
    mes ""+rnd(1000)+", "+rnd2(1000)
loop

結果も同じですね。

HSP 対応版 kmyacc を公開しました

2008-03-24T19:28:09+09:00

HSP 対応版 kmyacc ダウンロード

Windows 用バイナリアーカイブとソースアーカイブの二つを用意しました。

他の言語のプロトタイプを参考にやったら出来ました！ kmyacc 本体をイジる必要があったのは改行周りだけでした。（ HSP では改行が文の終わりだから。 Python 版でも同じように改行周りで特別に処理していた。）

-tオプション（デバッグモード）、-aオプション（reduce時のactionを一つ一つサブルーチンに分けてラベル型配列変数を使って実行）に対応しています。

ActionScriptのyaccを作ったよ - yukobaの日記の画像を見ると ActionScript 版のデバッグモードでは accept 後にツリーを表示しているようですね。 HSP 版でも次期バージョンで対応するかもしれません。→対応しました

kmyacc の作者、各言語のプロトタイプの作者に感謝します。

Ver 1.10 として更新しました。デバッグモード時に下図のようなパーサーツリーのダンプが出来るようになりました。

方法は、まず kmyacc 実行時に-tオプションをつけます。すると、デバッグのためのトレース表示を行うようになります。これだけではツリーのダンプはされません。さらにツリーのダンプを行うには、 yyparse を呼ぶ直前あたりに yyDumpParseTree = 1 というコードを差し込みます。

構文木を使ったサンプル

付属のサンプル（ calc.hspy ）では物足りないと思うので、構文木を使ったサンプルも置いておきます。参考にしてみてください。変数の代入とか、if文とか使えます。

%token kNUMBER kIDENT kEOL kIF kELSE kEND

%right '='
%left '+' '-'
%left '*' '/'

%%

program
    : stmt_list { syntaxtree = $1 }

stmt_list
    : { new_list_node $$ }
    | stmt_list stmt kEOL { yylrec++ : append_list_node $$, $2 }
    | stmt_list kEOL

stmt
    : expr
    | if_stmt

if_stmt
    : kIF expr kEOL stmt_list else_stmt kEND
        {
            new_if_node $$, $2, $4, $5
        }

else_stmt
    : kELSE kEOL stmt_list { $$ = $3 }
    | { new_list_node $$ }

expr
    : expr '+' expr { new_operator_node $$, '+', $1, $3 }
    | expr '-' expr { new_operator_node $$, '-', $1, $3 }
    | expr '*' expr { new_operator_node $$, '*', $1, $3 }
    | expr '/' expr { new_operator_node $$, '/', $1, $3 }
    | '(' expr ')' { $$ = $2 }
    | kNUMBER { new_literal_node $$, $1 }
    | kIDENT { new_varref_node $$, $1 }
    | kIDENT '=' expr { new_assign_node $$, $1, $3 }

%%

#runtime "hsp3cl"

if 0 {
#defcfunc varref str varname
    if vars( "Exists", varname ) {
        return vars( "Item", varname )
    }
    mes "undefined variable `"+varname+"'"
    return 0
#deffunc setvar str varname, int val
    if vars( "Exists", varname ) : vars -> "Remove" varname
    vars -> "Add" varname, val
    return
}

#module m_node type, children, val
#enum TYPE_LITERAL = 1
#enum TYPE_VARREF
#enum TYPE_ASSIGN
#enum TYPE_OPERATOR
#enum TYPE_LIST
#enum TYPE_IF

#define last_node (nodes(length(nodes)-1))

#modfunc init_literal_node int _val
    type = TYPE_LITERAL
    val = _val
    return
#deffunc new_literal_node var ret, int _val
    newmod nodes, m_node
    init_literal_node last_node, _val
    ret = last_node
    return

#modfunc init_varref_node str varname
    type = TYPE_VARREF
    val = varname
    return
#deffunc new_varref_node var ret, str varname
    newmod nodes, m_node
    init_varref_node last_node, varname
    ret = last_node
    return

#modfunc init_assign_node str varname, var expr
    type = TYPE_ASSIGN
    val = varname
    children = expr
    return
#deffunc new_assign_node var ret, str varname, var expr
    newmod nodes, m_node
    init_assign_node last_node, varname, expr
    ret = last_node
    return

#modfunc init_operator_node int operator, var lhs, var rhs
    type = TYPE_OPERATOR
    val = operator
    children = lhs, rhs
    return
#deffunc new_operator_node var ret, int operator, var lhs, var rhs
    newmod nodes, m_node
    init_operator_node last_node, operator, lhs, rhs
    ret = last_node
    return

#modfunc init_list_node
    type = TYPE_LIST
    dimtype children, 5
    val = 0 // appended flag
    return
#deffunc new_list_node var ret
    newmod nodes, m_node
    init_list_node last_node
    ret = last_node
    return
#modfunc append_list_node var append_node
    if val {
        children( length( children ) ) = append_node
    } else {
        children = append_node
    }
    val = 1
    return

#modfunc init_if_node var cond, var tstmt, var fstmt
    type = TYPE_IF
    children = cond, tstmt, fstmt
    return
#deffunc new_if_node var ret, var cond, var tstmt, var fstmt
    newmod nodes, m_node
    init_if_node last_node, cond, tstmt, fstmt
    ret = last_node
    return

#defcfunc eval_node modvar m_node@
    if type == TYPE_LITERAL {
        return val
    }
    if type == TYPE_VARREF {
        return varref( val )
    }
    if type == TYPE_ASSIGN {
        v = eval_node( children )
        setvar val, v
        return v
    }
    if type == TYPE_OPERATOR {
        l = eval_node( children.0 )
        r = eval_node( children.1 )
        if val == '+' {
            return l + r
        }
        if val == '-' {
            return l - r
        }
        if val == '*' {
            return l * r
        }
        if val == '/' {
            return l / r
        }
    }
    if type == TYPE_LIST {
        result = 0
        foreach children
            result = eval_node( children.cnt )
        loop
        return result
    }
    if type == TYPE_IF {
        if eval_node( children.0 ) {
            return eval_node( children.1 )
        }
        return eval_node( children.2 )
    }
    mes "must not happen" : stop
#global

    newcom vars, "Scripting.Dictionary"
    vars("compareMode") = 0
    
    newcom reserved, "Scripting.Dictionary"
    reserved -> "Add" "if", kIF
    reserved -> "Add" "else", kELSE
    reserved -> "Add" "end", kEND
    
    yyparse
    if vartype( syntaxtree ) == 5 : mes eval_node( syntaxtree )
    ;end stat
    stop

*yylex
    if start == 0 {
        input expr,, 1
        if peek( expr ) == 0 : return 0
        expr_ptr = 0
        start = 1
    }
    char = peek( expr, expr_ptr )
    if char == 10 || char == 13 {
        start = 0
        return kEOL
    }
    if char == ' ' || char == '\t' {
        expr_ptr ++
        goto *yylex
    }
    if char >= '0' && char <= '9' {
        yylval = char - '0'
        expr_ptr ++
        repeat
            char = peek( expr, expr_ptr )
            if char >= '0' && char <= '9' : else : break
            yylval = yylval * 10 + char - '0'
            expr_ptr ++
        loop
        return kNUMBER
    }
    if ( char >= 'a' && char <= 'z' ) || ( char >= 'A' && char <= 'Z' ) || char == '_' {
        yylval = expr_ptr
        repeat
            char = peek( expr, expr_ptr )
            cond   = char >= 'a' && char <= 'z'
            cond ||= char >= 'A' && char <= 'Z'
            cond ||= char == '_'
            cond ||= char >= '0' && char <= '9'
            if cond : else : break
            expr_ptr ++
        loop
        yylval = strmid( expr, yylval, expr_ptr - yylval )
        if reserved( "Exists", yylval ) {
            return reserved( "Item", yylval )
        }
        return kIDENT
    }
    expr_ptr ++
    return char

*yyerror
    mes yyerrmsg
    return

mrefを使わずにstatに値を格納

2008-03-21T06:25:18+09:00

ちょっとした HSP の小技。

gosub *@f : if 0 : *@ : return 123
mes stat ;=> 123

もちろん、ほとんどの場合では素直に mref を使った方がいいでしょう。

文字列の式を計算 (演算子順位法)

2008-02-12T08:00:49+09:00

このプログラムはパーサーのアルゴリズムとか全く知らないときに自分で考えたものです。後から分かったんですが、「演算子順位法」というアルゴリズムを再発明していました。

演算子順位法の利点は以下のような感じでしょうか:

演算子を動的に変更できる
システムのスタックが伸びない

スマートな演算子順位法のプログラムはこちらを見るといいと思います！ JavaScript で数式パーサを書いてみた。 - IT戦記

Ruby で書いた

#module calc_token type, val
#modinit int _type, var _val
    type = _type
    val = _val
    return
#defcfunc calc_token_type modvar calc_token@
    return type
#defcfunc calc_token_val modvar calc_token@
    return val
#global

#module calc

#enum TOKEN_TYPE_NONE = 0
#enum TOKEN_TYPE_BINARY_OPERATOR
#enum TOKEN_TYPE_UNARY_OPERATOR
#enum TOKEN_TYPE_NUM
#enum TOKEN_TYPE_LEFT_BRACKETS
#enum TOKEN_TYPE_RIGHT_BRACKETS

#deffunc init_calc
    binary_operators           = "*", "/", "+", "-"
    binary_operators_priority  =   2,   2,   1,   1
    unary_operators            = "+", "-"
    unary_operators_priority   =   5,   3
    return

#defcfunc calc_operate_binary int operator, double a, double b
    switch operator
    case 0
        return a * b
    case 1
        return a / b
    case 2
        return a + b
    case 3
        return a - b
    swend

#defcfunc calc_operate_unary int operator, double a
    switch operator
    case 0
        return a
    case 1
        return -a
    swend

#deffunc calc_scan_num
    c = char
    if c == '-' : c = peek( expr, i + 1 )
    if c < '0' || c > '9' : return
    type = TOKEN_TYPE_NUM
    size = 1
    find = 1
    repeat
        if i + size >= len : break
        c = peek( expr, i + size )
        if c < '0' || c > '9' : break
        size ++
    loop
    c = peek( expr, i + size )
    if c == '.' {
        c = peek( expr, i + size + 1 )
        if c >= '0' && c <= '9' {
            size ++
            repeat
                if i + size >= len : break
                c = peek( expr, i + size )
                if c < '0' || c > '9' : break
                size ++
            loop
        }
    }
    val = double( strmid( expr, i, size ) )
    return

#deffunc calc_scan_operator array operators
    foreach operators
        dup operator, operators.cnt
        if strmid( expr, i, strlen( operator ) ) == operator {
            size = strlen( operator )
            val = cnt
            find = 1
            break
        }
    loop
    return

#deffunc calc_lex str _expr
    expr = _expr
    dimtype tokens, 5
    prev_type = TOKEN_TYPE_NONE
    i = 0
    len = strlen( expr )
    find = 1
    repeat
        if i >= len : break
        char = peek( expr, i )
        switch char
        case ' ' : case 0x09 : case 0x0a
        case 0x0d : case 0x0c
            i ++
            continue
        swend
        find = 0 : size = 0 : type = TOKEN_TYPE_NONE : val = 0
        switch prev_type
        case TOKEN_TYPE_NONE : case TOKEN_TYPE_LEFT_BRACKETS
        case TOKEN_TYPE_BINARY_OPERATOR : case TOKEN_TYPE_UNARY_OPERATOR
            calc_scan_num
            if find : swbreak
            calc_scan_operator unary_operators
            if find : type = TOKEN_TYPE_UNARY_OPERATOR : swbreak
            if char == '(' {
                type = TOKEN_TYPE_LEFT_BRACKETS
                size = 1
                find = 1
                swbreak
            }
            swbreak
        case TOKEN_TYPE_NUM : case TOKEN_TYPE_RIGHT_BRACKETS
            calc_scan_operator binary_operators
            if find : type = TOKEN_TYPE_BINARY_OPERATOR : swbreak
            if char == ')' {
                type = TOKEN_TYPE_RIGHT_BRACKETS
                size = 1
                find = 1
                swbreak
            }
        swend
        if find == 0 : break
        newmod tokens, calc_token, type, val
        prev_type = type
        i += size
    loop
    if find == 0 {
        error = "構文エラーです"
        return 1
    }
    return 0

#deffunc calc_insert_rpn_tokens
    i = rpn_tokens_size
    repeat
        if i <= rpn_tokens_ptr : break
        rpn_tokens( i ) = rpn_tokens( i - 1 )
        i --
    loop
    rpn_tokens( rpn_tokens_ptr ) = token
    rpn_tokens_size ++
    return

#defcfunc calc_is_token_operator var t
    if calc_token_type( t ) == TOKEN_TYPE_BINARY_OPERATOR : return 1
    if calc_token_type( t ) == TOKEN_TYPE_UNARY_OPERATOR  : return 1
    return 0

#defcfunc calc_operator_token_prioririty var t
    if calc_token_type( t ) == TOKEN_TYPE_BINARY_OPERATOR {
        return binary_operators_priority( calc_token_val( t ) )
    }
    return unary_operators_priority( calc_token_val( t ) )

#defcfunc calc_rop_is_end
    if rs_stack_ptr <= 0 : return 0
    if rs_stack( rs_stack_ptr - 1 ) != brackets_level : return 0

    if rpn_tokens_ptr >= rpn_tokens_size : return 1
    token1 = rpn_tokens( rpn_tokens_ptr )
    if tokens_i + 1 >= length( tokens ) : return 1
    token2 = tokens( tokens_i + 1 )

    if calc_is_token_operator( token1 ) == 0 : return 1
    if calc_is_token_operator( token2 ) == 0 : return 1

    token1p = calc_operator_token_prioririty( token1 )
    token2p = calc_operator_token_prioririty( token2 )

    return token2p <= token1p

#deffunc calc_rop_exit
    while calc_rop_is_end()
        rs_stack_ptr --
        rpn_tokens_ptr ++
    wend
    return

#deffunc calc_convert_to_rpn
    ret = 0
    dimtype rpn_tokens, 5
    rpn_tokens_size = 0
    rpn_tokens_ptr = 0
    prev_type = TOKEN_TYPE_NONE
    dim rs_stack
    rs_stack_ptr = 0
    brackets_level = 0

    foreach tokens
        tokens_i = cnt
        dup token, tokens.cnt
        type = calc_token_type( token )
        switch type
        case TOKEN_TYPE_NUM
            calc_insert_rpn_tokens
            rpn_tokens_ptr ++
            if prev_type == TOKEN_TYPE_BINARY_OPERATOR || prev_type == TOKEN_TYPE_UNARY_OPERATOR {
                calc_rop_exit
            }
            swbreak
        case TOKEN_TYPE_BINARY_OPERATOR
        case TOKEN_TYPE_UNARY_OPERATOR
            calc_insert_rpn_tokens
            rs_stack.rs_stack_ptr = brackets_level
            rs_stack_ptr ++
            swbreak
        case TOKEN_TYPE_LEFT_BRACKETS
            brackets_level ++
            swbreak
        case TOKEN_TYPE_RIGHT_BRACKETS
            if brackets_level <= 0 {
                error = "不正な閉じカッコです"
                ret = 1
                break
            }
            brackets_level --
            calc_rop_exit
            swbreak
        default
            error = "不明なトークンです"
            ret = 1
            break
        swend
        prev_type = type
    loop
/*  デバッグ表示
    repeat rpn_tokens_size
        if calc_token_type( rpn_tokens.cnt ) == TOKEN_TYPE_BINARY_OPERATOR {
            mes binary_operators( calc_token_val( rpn_tokens.cnt ) )
        } else : if calc_token_type( rpn_tokens.cnt ) == TOKEN_TYPE_UNARY_OPERATOR {
            mes unary_operators( calc_token_val( rpn_tokens.cnt ) )
        } else {
            mes calc_token_val( rpn_tokens.cnt )
        }
    loop */
    if ret : return ret
    if rpn_tokens_ptr != rpn_tokens_size {
        error = "式が途中で終了しています"
        return 1
    }
    if brackets_level != 0 {
        error = "カッコが閉じられていません"
        return 1
    }
    return 0

#deffunc calculate_rpn var result
    ddim stack, 1
    stack_ptr = 0
    ret = 0
    foreach rpn_tokens
        dup token, rpn_tokens.cnt
        type = calc_token_type( token )
        switch type
        case TOKEN_TYPE_NUM
            stack.stack_ptr = calc_token_val( token )
            stack_ptr ++
            swbreak
        case TOKEN_TYPE_BINARY_OPERATOR
            if stack_ptr < 2 {
                error = "オペランドが足りません"
                ret = 1
                break
            }
            stack_ptr --
            _b = stack.stack_ptr
            stack_ptr --
            _a = stack.stack_ptr
            stack.stack_ptr = calc_operate_binary( calc_token_val( token ), _a, _b )
            stack_ptr ++
            swbreak
        case TOKEN_TYPE_UNARY_OPERATOR
            if stack_ptr < 1 {
                error = "オペランドが足りません"
                ret = 1
                break
            }
            stack( stack_ptr-1 ) = calc_operate_unary( calc_token_val( token ), stack( stack_ptr-1 ) )
            swbreak
        default
            error = "不明なトークンです"
            ret = 1
            break
        swend
    loop
    if ret : return ret
    if stack_ptr != 1 {
        error = "オペランドが足りないか、余っています"
        return 1
    }
    result = stack.0
    return 0

#deffunc calculate str _expr, var result
    calc_lex _expr
    if stat : return stat
    calc_convert_to_rpn
    if stat : return stat
    calculate_rpn result
    return stat

#global
init_calc

exprs = "1+2*(3+4)", "1+--1", " ( 1 + ( 2 + ( 3 ) ) )", "2.5/-1.2", "1+", "((", "()", ""
foreach exprs
    expr = exprs.cnt
    mes expr
    calculate expr, result
    if stat {
        mes "Error: "+error@calc
    } else {
        mes " = " + result
    }
loop

二項演算子のオペランドの _a と _b が逆だったので修正。

d3module Z ソート

2008-02-07T06:28:58+09:00

#include "d3m.hsp"

#module cube

#deffunc init_cube
    // 面の座標（4点）のパターン（4つ）
    dim pattern, 4, 4
    pattern.0.0 = 0, 0, 0, 0
    pattern.0.1 = 0, 1, 1, 0
    pattern.0.2 = 1, 1, 0, 0
    pattern.0.3 = 1, 1, 1, 1

    dim association, 3, 6
    // それぞれの面(6)のX,Y,Z(3)について、patternのインデックスを設定する
    // よい変数名がうかばない
    association.0.0 = 0, 1, 2
    association.0.1 = 3, 1, 2
    association.0.2 = 1, 0, 2
    association.0.3 = 1, 3, 2
    association.0.4 = 1, 2, 0
    association.0.5 = 1, 2, 3
    return

#deffunc cube_coordinate int face
    dup xs, pattern( 0, association( 0, face ) )
    dup ys, pattern( 0, association( 1, face ) )
    dup zs, pattern( 0, association( 2, face ) )
    return

#deffunc draw_cube int face
    cube_coordinate face
    d3square xs, ys, zs
    return

#defcfunc face_dist int face
    cube_coordinate face
    dx = 0.25 * ( xs.0 + xs.1 + xs.2 + xs.3 )
    dy = 0.25 * ( ys.0 + ys.1 + ys.2 + ys.3 )
    dz = 0.25 * ( zs.0 + zs.1 + zs.2 + zs.3 )

    // ダサい＞＜
    dx += local_coordinate@.0 - camera@.0
    dy += local_coordinate@.1 - camera@.1
    dz += local_coordinate@.2 - camera@.2

    return d3dist( dx, dy, dz )

#deffunc cube_sorted_faces array faces
    dim faces, 6 // 面番号の配列
    ddim face_dists, 6 // 面のカメラとの距離
    repeat 6
        faces.cnt = cnt
        face_dists.cnt = face_dist( cnt )
    loop

    // バブルソート
    repeat 6
        i = cnt
        repeat 6 - i - 1
            j = cnt
            dup n, faces.j
            dup v, face_dists.j
            if( v < v.1 ) {
                tmp_n = n
                tmp_v = v
                n = n.1
                v = v.1
                n.1 = tmp_n
                v.1 = tmp_v
            }
        loop
    loop
    return

#global
init_cube

    gmode 3,,, 200
    repeat
        redraw 0
        camera = sin(0.01*cnt)*1.5, cos(0.01*cnt)*1.5, 1.0
        d3setcam camera.0, camera.1, camera.2
        local_coordinate = -0.5, -0.5, -0.5
        d3setlocal local_coordinate.0, local_coordinate.1, local_coordinate.2
        color : boxf
        cube_sorted_faces faces
        repeat 6
            i = faces.cnt
            hsvcolor i * 192 / 6, 255, 255
            draw_cube i
        loop
        redraw 1
        await 40
    loop

d3module でマウス座標と重なっているセルを調べる

2008-02-05T08:04:47+09:00

といっても、二次元座標から三次元座標に変換をするわけではありません。書き込んだバッファから pget してどのセルと重なっているか調べるだけです。

#include "d3m.hsp"

#const WINDOW_ID_MAIN 0
#const WINDOW_ID_WORK 1

#const PANEL_SIZE_X 1.0
#const PANEL_SIZE_Y 1.0

#const PANEL_DISTANCE_X PANEL_SIZE_X * 1.1
#const PANEL_DISTANCE_Y PANEL_SIZE_Y * 1.1

#const PANELS_NUM_X 10
#const PANELS_NUM_Y 10

#const PANELS_ALL_SIZE_X PANEL_DISTANCE_X * ( PANELS_NUM_X - 1 ) + PANEL_SIZE_X
#const PANELS_ALL_SIZE_Y PANEL_DISTANCE_Y * ( PANELS_NUM_Y - 1 ) + PANEL_SIZE_Y

#const PANELS_START_X 0.0 - PANELS_ALL_SIZE_X / 2
#const PANELS_START_Y 0.0 - PANELS_ALL_SIZE_Y / 2

    buffer WINDOW_ID_WORK
    screen WINDOW_ID_MAIN

    repeat
        d3setcam sin(0.01*cnt)*10, cos(0.01*cnt)*10, 10
        mx = mousex : my = mousey
        gsel WINDOW_ID_WORK
        cls
        gosub *draw
        pget mx, my
        select_x = ginfo_r : select_y = ginfo_g
        gsel WINDOW_ID_MAIN
        redraw 0
        color 255, 255, 255 : boxf
        gosub *draw
        redraw
        await 40
    loop
    stop


*draw
    repeat PANELS_NUM_Y
        y = cnt
        py = PANEL_DISTANCE_Y * y + PANELS_START_Y
        repeat PANELS_NUM_X
            x = cnt
            px = PANEL_DISTANCE_X * x + PANELS_START_X
            pxs = px, px + PANEL_SIZE_X, px + PANEL_SIZE_X, px
            pys = py, py, py + PANEL_SIZE_Y, py + PANEL_SIZE_Y
            pzs = 0, 0, 0, 0
            if ginfo_sel == WINDOW_ID_WORK {
                color x, y
            } else {
                color
                if select_x == x && select_y == y {
                    color 255
                }
            }
            d3square pxs, pys, pzs
        loop
    loop
    return

簡単にスペースの連続した文字列を得る

2008-02-02T19:30:57+09:00

mes "["+strf("%10.0d", 0 )+"]"

10 のところを変更すれば任意のサイズにできるよ。

memset を使うのに比べて変数が不要な分、簡単。

HSP の文字列リテラルを表す正規表現

2008-02-01T06:11:09+09:00

文字列リテラル: /"[^\\"]*(\\.[^\\"]*)*("|$)/
複数行文字列リテラル: /\{"[^\\"]*(("(?!\})|\\.)[^\\"]*)*"\}/m
文字コードリテラル: /'[^\\']*(\\.[^\\']*)*('|$)/

少し前は文字列リテラルを表す正規表現ってどう書けばいいのかぜんぜん分からなかったんだけれど、今だとぜんぜん普通に書けた。

ところで、文字列リテラル中にダブルクォートが3つ以上入る場合、複数行文字列リテラルを使った方がスクリプトの文字数が短くなる。

mes "\""
mes {"""}

mes "\"\""
mes {""""}

mes "\"\"\""
mes {"""""}

というわけで、たとえ 1 行でもダブルクォートのたくさん入った文字列を使う場合は複数行文字列リテラルを使おう。

文字列リテラル正規表現でググってみました。

refluxflow::memo: 文字列リテラルにマッチする正規表現

そっか。もう少し短くかけたね。

文字列リテラル: /"([^\\"]|\\.)*("|$)/
複数行文字列リテラル: /\{"([^\\"]|\\.|"(?!\}))*"\}/m
文字コードリテラル: /'([^\\']|\\.)*('|$)/

複数行文字列リテラルは /\{"([^\\"]|\\.|")*?"\}/m でもいいか。

巨大な実数を str に渡したり、 mes で表示しようとすると落ちる。

2008-01-31T22:37:03+09:00

mes 1e100 // 落ちる

これで HSP が落ちる。

a = str(1e100) // 落ちる

str に渡しても落ちる。

#runtime "hsp3cl"
mes 1e100 // 落ちない
a = str(1e100) // 落ちない

両方ともランタイムが hsp3cl なら落ちない。

環境は Windows XP Home SP2 / HSP3.1

OpenHSP のソースコードを追っかけてみた。

hspvar_str.cpp

static char conv[64];

という固定長の配列に書き込んでいたので、これを超えるとバッファオーバーフローが発生するというわけですねー。

同じような原因で、a=strf("%5000d", 0 )で終了時に「問題が発生したため、hsp3.exe を終了します。ご不便をおかけして申し訳ありません。」というエラーが出たり。