path: root/parse.asm

# Copyright (C) 2026 Sebastian G. Kirmayer <gloria@gloria-mundi.eu>
#
#  This file is part of sysf-i386.
#
#  sysf-i386 is free software: you can redistribute it and/or modify it under
#  the terms of the GNU General Public License as published by the Free
#  Software Foundation, either version 3 of the License, or (at your option)
#  any later version.
#
#  sysf-i386 is distributed in the hope that it will be useful, but WITHOUT ANY
#  WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
#  FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
#  details.
#
#  You should have received a copy of the GNU General Public License along
#  with sysf-i386. If not, see <https://www.gnu.org/licenses/>.
#

bss
align
label lineno
	long 0
label error_flag
	long 0
label macro_flag
	long 0

label parse_stack_top
	skip $((PARSE_STACK_SIZE*4))
label parse_stack_bottom
label macro_types_start
	skip $((MACROS_SIZE*4))
label macro_types_end
label macro_start
	skip $((PARSE_STACK_SIZE*16))
label macro_end
label input
	long 0
label input_end
	long 0
data
align
label parse_stack_ptr
	long parse_stack_bottom
label macro_type_ptr
	long macro_types_start
label macro_ptr
	long macro_start
text

# STK
# { IDENT START, IDENT END } (if STK & STK_HAVE_IDENT)
# LINENO (if STK & STK_HAVE_LINENO)

# On the type stack:
# callee type (if STK & STK_HAVE_VALUE)
# argument type (if STK & STK_SMALL_LAMBDA)

# stack control words:
STK_BOTTOM=1
STK_PAREN=2
STK_SMALL_LAMBDA=4
STK_BIG_LAMBDA=8

STK_TYPE_BOTTOM=256
STK_TYPE_ARROW=512
STK_TYPE_PAREN=1024
STK_TYPE_FORALL=2048

STK_HAVE_VALUE=16
STK_HAVE_IDENT=$((STK_SMALL_LAMBDA|STK_BIG_LAMBDA|STK_TYPE_FORALL))
STK_HAVE_LINENO=$((STK_PAREN|STK_TYPE_PAREN))

BACKSLASH=0x5C
SLASH=0x2F
LPAREN=0x28
RPAREN=0x29
LBRACKET=0x5B
RBRACKET=0x5D
COLON=0x3A
SEMICOLON=0x3B
OCTOTHORPE=0x23
SPACE=0x20
TAB=0x09
NEWLINE=0x0A
HYPHEN=0x2D
GREATER=0x3E
UNDERSCORE=0x5F

label parse_push # (val: i32) -> ()
	movl @parse_stack_ptr %ecx
	cmpl parse_stack_top %ecx
	je overflow.
	subl 4 %ecx
	movl %eax @%ecx
	movl %ecx @parse_stack_ptr
	ret

label parse_peek # () -> (val: i32)
	movl @parse_stack_ptr %eax
	movl @%eax %eax
	ret

label parse_pop # () -> (val: i32)
	movl @parse_stack_ptr %eax
	addl 4 @parse_stack_ptr
	movl @%eax %eax
	ret

L overflow
	movl msg_parse_overflow %eax
	movl msg_parse_overflow_end %ecx
	call report_error
	jmp error
rodata
string msg_parse_overflow "Parse stack overflow
"
text

label parse # (start: *i8, end: *i8) -> (term: *term)
	pushl %ebx
	pushl %edi
	pushl %esi
	pushl %ebp
	movl %eax @input
	movl %ecx @input_end
	call align_heap
	movl $STK_BOTTOM %eax
	call parse_push
	# push two bottoms -- this simplifies handling of unmatched )
	movl $STK_BOTTOM %eax
	call parse_push
	# push an extra poison to the type stack
	call ty_poison
	movl 0 @lineno
	movl 0 @error_flag # this must occur after the ty_poison above
L loop
	call skip_white
	movl @input %eax
	cmpl @input_end %eax
	je eof.
	cmpb $RPAREN @%eax
	je right_paren.
	call parse_peek
	testl $STK_HAVE_VALUE %eax
	jz parse_value.
	call ty_top_is_forall
	jne parse_value.
	call parse_type
	call ty_apply_forall
	jmp loop^

L parse_value
	movl @input %eax
	movb @%eax %al
	cmpb $BACKSLASH %al
	je small_lambda.
	cmpb $SLASH %al
	je big_lambda.
	cmpb $LPAREN %al
	je left_paren.
	# Variable terms
	call read_ident
	movl $STK_SMALL_LAMBDA %edx
	call find_ident
	movl %eax %esi
	movl %ecx %ebp
	movl %edx %edi
	movl @heap_ptr %ecx
	call push_value
	testl %esi %esi
	js bad_ident.
	movl %edi %eax
	movl %ebp %ecx
	call ty_copy
	jmp value_done.
L bad_ident
	movl %esp %eax
	call ty_poison
L value_done
	movl %esp %eax
	call apply
	jmp loop^

L small_lambda
	incl @input
	call skip_white
	call read_ident
	movl %eax %esi
	movl %ecx %eax
	call parse_push
	movl %esi %eax
	call parse_push
	movl $STK_SMALL_LAMBDA %eax
	call parse_push
	call skip_white
	movl @input %eax
	cmpl @input_end %eax
	je no_colon.
	movb @%eax %al
	cmpb $COLON %al
	jne no_colon.
	incl @input
	call parse_type
	jmp loop^

L no_colon
	call stderr_lineno
	stderr "Missing argument type in lambda abstraction
"
	call ty_poison
	movl 1 @error_flag
	jmp loop^

L big_lambda
	movl @input %eax
	incl %eax
	cmpl @input_end %eax
	je bad_char
	movb @%eax %al
	cmpb $BACKSLASH %al
	jne bad_char
	addl 2 @input
	call skip_white
	call read_ident
	movl %eax %ebx
	movl %ecx %eax
	call parse_push
	movl %ebx %eax
	call parse_push
	movl $STK_BIG_LAMBDA %eax
	call parse_push
	jmp loop^

L left_paren
	incl @input
	movl @lineno %eax
	call parse_push
	movl $STK_PAREN %eax
	call parse_push
	jmp loop^

L right_paren
	incl @input
	movl $STK_PAREN %eax
	call close_paren
	jmp loop^

L eof
	movl $STK_BOTTOM %eax
	call close_paren
	popl %ebp
	popl %esi
	popl %edi
	popl %ebx
	movl @error_flag %eax
	testl %eax %eax
	jnz error
	ret

label close_paren # (type: i32) -> ()
	pushl %ebx
	pushl %edi
	pushl %ebp
	movl %eax %ebx
	# %ebx -- type wanted
	call parse_pop
	movl %eax %edi
	# %edi -- type on stack
	testl $STK_HAVE_VALUE %edi
	jz no_value.
L have_value
	testl $STK_HAVE_IDENT %edi
	jz skip.
	call parse_pop
	call parse_pop
L skip
	testl $STK_SMALL_LAMBDA %edi
	jnz small_lambda.
	testl $STK_BIG_LAMBDA %edi
	jz skip.
L big_lambda
	call ty_forall
	jmp skip.
L small_lambda
	call ty_arrow
	movl @heap_ptr %ecx
	movl @%ecx+-8 %ecx
	movl $VAL_ABS %eax
	call push_value
L skip
	testl $STK_HAVE_LINENO %edi
	jz no_lineno.
	call parse_pop
	movl %eax %ebp
	# %ebp -- lineno
L no_lineno
	call apply
	testl %ebx %edi
	jnz end.
	testl $STK_BOTTOM %edi
	jnz unmatched_right.
	testl $STK_PAREN %edi
	jnz unmatched_left.
L continue
	call parse_pop
	movl %eax %edi
	jmp have_value^ # must have value since we just called apply

L end
	popl %ebp
	popl %edi
	popl %ebx
	ret

L unmatched_right
	movl 1 @error_flag
	call stderr_lineno
	stderr "Unmatched ')'
"
	call parse_pop
	movl $STK_BOTTOM %eax
	call parse_push
	movl $((STK_BOTTOM|STK_HAVE_VALUE)) %eax
	call parse_push
	jmp end^

L unmatched_left
	movl 1 @error_flag
	xchgl %ebp @lineno
	call stderr_lineno
	movl %ebp @lineno
	stderr "Unmatched '('
"
	jmp continue^

L no_value
	# Push a poison value so we can continue
	orl $STK_HAVE_VALUE %edi
	movl 1 @error_flag
	movl @heap_ptr %ecx
	call push_value
	call ty_poison
	call stderr_lineno
	# %edi -- parse stack element
	testl $STK_PAREN %edi
	jnz paren.
	testl $STK_SMALL_LAMBDA %edi
	jnz small.
	testl $STK_BIG_LAMBDA %edi
	jnz big.
	testl $STK_BOTTOM %edi
	jnz bottom.
	ud2
L paren
	stderr "Empty parentheses
"
	jmp have_value^
L small
	stderr "Empty lambda abstraction
"
	jmp have_value^
L big
	stderr "Empty type lambda abstraction
"
	jmp have_value^
L bottom
	stderr "Empty program
"
	jmp have_value^

# We have just pushed a value. Check if it is an argument, and push the
# application if so.
label apply # () -> ()
	call parse_peek
	testl $STK_HAVE_VALUE %eax
	jnz do_apply.
	call parse_pop
	orl $STK_HAVE_VALUE %eax
	call parse_push
	ret
L do_apply
	call ty_apply
	movl @heap_ptr %ecx
	movl @%ecx+-8 %ecx
	movl @%ecx+-8 %ecx
	movl $VAL_APP %eax
	call push_value
	ret

label parse_type # () -> ()
	pushl %ebx
	pushl %edi
	pushl %esi
	movl $STK_TYPE_BOTTOM %eax
	call parse_push
L loop
	call skip_white
	movl @input %eax
	cmpl @input_end %eax
	je bad_eof
	movb @%eax %al
	cmpb $BACKSLASH %al
	je forall.
	cmpb $LPAREN %al
	je left_paren.
	# Variable
	call read_ident
	movl %eax %edi
	movl %ecx %esi
	# %edi..%esi -- ident
	movl @macro_ptr %ebx
	# %ebx -- macro iterator
L find_macro
	cmpl macro_start %ebx
	je no_macro.
	subl 16 %ebx
	movl %edi %eax
	movl %esi %ecx
	movl @%ebx %edx
	pushl @%ebx+4
	call streq
	je found_macro.
	jmp find_macro^

L found_macro
	movl @%ebx+12 %eax
	movl @%ebx+8 %ebx
	call ty_copy
	# %ebx -- remaining arguments
	call skip_white
	movl @input %eax
	cmpl @input_end %eax
	je no_args.
	cmpb $LBRACKET @%eax
	jne no_args.
	incl @input
L next_arg
	call parse_type
	decl %ebx
	js extra_arg.
	call ty_apply_forall
L arg_done
	call skip_white
	movl @input %eax
	cmpl @input_end %eax
	je bad_eof
	cmpb $RBRACKET @%eax
	jne next_arg^

	incl @input
L no_args
	testl %ebx %ebx
	jg missing_args.
	jl extra_args.
L have_args
	jmp op.

L extra_arg
	call ty_pop
	jmp arg_done^

L extra_args
rodata
string msg_extra_arg "Extraneous macro arguments
"
text
	movl msg_extra_arg %eax
	movl msg_extra_arg_end %ecx
	call report_error
	movl 1 @error_flag
	jmp have_args^

L missing_args
rodata
string msg_missing_args "Missing macro arguments
"
text
	movl msg_missing_args %eax
	movl msg_missing_args_end %ecx
	call report_error
	movl 1 @error_flag
L fake_args
	call ty_poison
	call ty_apply_forall
	decl %ebx %ebx
	jnz fake_args^
	jmp have_args^

L no_macro
	movl %edi %eax
	movl %esi %ecx
	movl $((STK_BIG_LAMBDA|STK_TYPE_FORALL)) %edx
	call find_ident
	testl %eax %eax
	js not_found.
	movl %ecx %eax
	call ty_push
	jmp op.
L not_found
	call ty_poison
	jmp op.

L forall
	movl @input %eax
	incl %eax
	cmpl @input_end %eax
	je bad_eof
	addl 2 @input
	movb @%eax %al
	cmpb $SLASH %al
	jne bad_char
	call skip_white
	call read_ident
	movl %eax %ebx
	movl %ecx %eax
	call parse_push
	movl %ebx %eax
	call parse_push
	movl $STK_TYPE_FORALL %eax
	call parse_push
	jmp loop^

L left_paren
	incl @input
	movl @lineno %eax
	call parse_push
	movl $STK_TYPE_PAREN %eax
	call parse_push
	jmp loop^

L op
	call skip_white
	movl @input %eax
	cmpl @input_end %eax
	je end.
	movb @%eax %al
	cmpb $HYPHEN %al
	je arrow.
	cmpb $RPAREN %al
	je right_paren.
	jmp end.

L arrow
	movl @input %eax
	incl %eax
	cmpl @input_end %eax
	je end.
	movb @%eax %al
	cmpb $GREATER %al
	jne end.
	addl 2 @input
	movl $STK_TYPE_ARROW %eax
	call parse_push
	jmp loop^

L right_paren
	movl $((STK_TYPE_PAREN|STK_TYPE_BOTTOM)) %eax
	call close_type_paren
	testl $STK_TYPE_PAREN %eax
	jz done.
	incl @input
	jmp op^

L end
	movl $STK_TYPE_BOTTOM %eax
	call close_type_paren
L done
	popl %esi
	popl %edi
	popl %ebx
	ret

label close_type_paren # (types: i32) -> (type: i32)
	pushl %ebx
	pushl %edi
	pushl %esi
	movl %eax %ebx
	# %ebx -- wanted types
L loop
	call parse_pop
	movl %eax %edi
	# %edi -- current type
	testl $STK_HAVE_IDENT %edi
	jz no_ident.
	call parse_pop
	call parse_pop
L no_ident
	testl $STK_HAVE_LINENO %edi
	jz no_lineno.
	call parse_pop
	movl %eax %esi
	# %esi -- lineno
L no_lineno
	testl %ebx %edi
	jnz done.
	testl $STK_TYPE_ARROW %edi
	jnz arrow.
	testl $STK_TYPE_PAREN %edi
	jnz paren.
	testl $STK_TYPE_FORALL %edi
	jnz forall.
	ud2

L arrow
	call ty_arrow
	jmp loop^

L paren
	movl 1 @error_flag
	xchgl %esi @lineno
	call stderr_lineno
	movl %esi @lineno
	stderr "Unmatched '('
"
	jmp loop^

L forall
	call ty_forall
	jmp loop^

L done
	movl %edi %eax
	popl %esi
	popl %edi
	popl %ebx
	ret

label find_ident # (start: *i8, end: *i8, type: i32) -> (vidx: i32, tidx: i32, type: *type)
	pushl %ebx
	pushl %esi
	pushl %edi
	pushl %ebp
	movl %edx %ebx
	pushl 0
	pushl 0
	pushl %ecx
	pushl %eax
	call ty_top
	movl %eax %edi
	movl @parse_stack_ptr %esi
	# %ebx -- type
	# @%esp -- ident
	# @%esp+4 -- ident end
	# @%esp+8 -- value index
	# @%esp+12 -- type index
	# %esi -- pointer running down the stack
	# %edi -- type stack pointer
L loop
	# %ebp -- type & flags
	movl @%esi %ebp
	addl 4 %esi
	testl $STK_HAVE_VALUE %ebp
	jz no_value.
	movl %edi %eax
	call ty_skip
	movl %eax %edi
L no_value
	testl $STK_HAVE_IDENT %ebp
	jz no_ident.
	movl @%esi %eax
	movl @%esi+4 %ecx
	addl 8 %esi
	movl @%esp %edx
	pushl @%esp+4
	call streq
	je found.
L no_ident
	testl $STK_SMALL_LAMBDA %ebp
	jz no_type.
	movl %edi %eax
	call ty_skip
	movl %eax %edi
L no_type
	leal @%esi+4 %eax
	testl $STK_HAVE_LINENO %ebp
	cmovnz %eax %esi
	testl $((STK_BIG_LAMBDA|STK_TYPE_FORALL)) %ebp
	jz no_type_inc.
	incl @%esp+12
L no_type_inc
	testl $STK_SMALL_LAMBDA %ebp
	jz no_value_inc.
	incl @%esp+8
L no_value_inc
	testl $STK_BOTTOM %ebp
	jz loop^
	movl @%esp %eax
	movl @%esp+4 %ecx
	call missing_ident
L error
	movl -1 %eax
	movl 1 @error_flag
	jmp end.
L found
	testl %ebx %ebp
	jz bad_ident.
	movl @%esp+8 %eax
	movl @%esp+12 %ecx
	movl %edi %edx
L end
	addl 16 %esp
	popl %ebp
	popl %edi
	popl %esi
	popl %ebx
	ret

L bad_ident
	movl @%esp %eax
	movl @%esp+4 %ecx
	movl %ebx %edx
	call bad_ident
	jmp error^

label read_ident # () -> (start: *i8, end: *i8)
	movl @input %eax
	movl %eax %ecx
L loop
	cmpl @input_end %ecx
	je done.
	movb @%ecx %dl
	incl %ecx
	cmpb $UNDERSCORE %dl
	je loop^
	cmpb 0x30 %dl
	jb done_ungetc.
	cmpb 0x39 %dl
	jbe loop^
	cmpb 0x41 %dl
	jb done_ungetc.
	cmpb 0x5A %dl
	jbe loop^
	cmpb 0x61 %dl
	jb done_ungetc.
	cmpb 0x7A %dl
	jbe loop^
L done_ungetc
	decl %ecx
L done
	cmpl %eax %ecx
	je bad_char
	movl %ecx @input
	ret

label bad_char
	movl msg_bad_char %eax
	movl msg_bad_char_end %ecx
	call report_error
	jmp error

label bad_eof
	cmpl 0 @macro_flag
	jnz macro.
	movl msg_bad_eof %eax
	movl msg_bad_eof_end %ecx
	call report_error
	jmp error
L macro
	movl msg_bad_eof_macro %eax
	movl msg_bad_eof_macro_end %ecx
	call report_error
	jmp error

rodata
string msg_bad_char "Unexpected character
"
string msg_bad_eof "Unexpected end of file
"
string msg_bad_eof_macro "Unexpected end of line
"
text

# Skip whitespace including comments and macros.
label skip_white
	movl @input %edx
	xorl %ecx %ecx
	cmpl %ecx @lineno
	jne loop.
	incl @lineno
	incl %ecx
L loop
	cmpl @input_end %edx
	je done.
	movb @%edx %al
	cmpb $SPACE %al
	je white.
	cmpb $NEWLINE %al
	je newline.
	cmpb $TAB %al
	je white.
	cmpb $SEMICOLON %al
	je comment.
	cmpb $OCTOTHORPE %al
	je macro.
L done
	movl %edx @input
	ret
L comment
	incl %edx
	cmpl @input_end %edx
	je done^
	cmpb $NEWLINE @%edx
	jne comment^
L newline
	incl @lineno
	movl 1 %ecx
	incl %edx
	jmp loop^
L white
	xorl %ecx %ecx
	incl %edx
	jmp loop^
L macro
	testl %ecx %ecx
	jz done^

	pushl %ebx
	pushl %edi

	# Macro handlings.
	# 1. Find end of line
	incl %edx
	movl %edx @input
L loop
	cmpl @input_end %edx
	je eol.
	cmpb $NEWLINE @%edx
	je eol.
	incl %edx
	jmp loop^
L eol
	pushl @input_end
	movl %edx @input_end
	movl 1 @macro_flag
	# Now, the entire input is just this line. So we can use normal parse
	# functions to parse the line. There is no risk of infinite recursion since
	# the input consists of a single line, so there are no newlines.
	movl $STK_BOTTOM %eax
	call parse_push

	call read_ident
	movl @macro_ptr %edx
	cmpl macro_end %edx
	je macro_overflow.
	movl %eax @%edx
	movl %ecx @%edx+4
	movl @input %eax
	cmpl @input_end %eax
	je bad_eof
	cmpb $LBRACKET @%eax
	jne no_args.
	incl @input
	call skip_white
L loop
	call read_ident
	movl %eax %ebx
	movl %ecx %eax
	call parse_push
	movl %ebx %eax
	call parse_push
	movl $STK_BIG_LAMBDA %eax
	call parse_push
	call skip_white
	movl @input %eax
	cmpl @input_end %eax
	je bad_eof
	cmpb $RBRACKET @%eax
	jne loop^
	incl @input
L no_args
	call parse_type
	movl @input %eax
	cmpl @input_end %eax
	je ok.
rodata
string msg_macro_extra "Extraneous input at end of macro
"
text
	movl msg_macro_extra %eax
	movl msg_macro_extra_end %ecx
	call report_error
	movl 1 @error_flag

L ok
	xorl %edi %edi
	# %edi -- num args
L loop
	call parse_pop
	testl $STK_BOTTOM %eax
	jnz done.
	incl %edi
	call parse_pop
	call parse_pop
	call ty_forall
	jmp loop^
L done
	movl @macro_ptr %eax
	movl %edi @%eax+8
	movl @macro_type_ptr %edi
	movl %edi @%eax+12
	call ty_top
	movl %eax %ebx
	call ty_skip
	leal @%edi+%eax %ecx
	subl %ebx %ecx
	cmpl macro_types_end %ecx
	ja macro_overflow.
	movl %ecx @macro_type_ptr
	# %ebx -- src
	# %eax -- src end
	# %edi -- dst
	# %ecx -- dst end
L loop
	movl @%ebx %edx
	movl %edx @%edi
	addl 4 %ebx
	addl 4 %edi
	cmpl %eax %ebx
	jne loop^

	call ty_pop
	addl 16 @macro_ptr
	movl @input_end %eax
	movl %eax @input
	popl @input_end
	movl 0 @macro_flag
	popl %edi
	popl %ebx
	jmp skip_white

L macro_overflow
	movl msg_macro_overflow %eax
	movl msg_macro_overflow_end %ecx
	call report_error
	jmp error
rodata
string msg_macro_overflow "Too many macros
"
text

label push_value # (val: i32, start ptr: *i32)
	movl @heap_ptr %edx
	addl 8 %edx
	movl %edx @heap_ptr
	cmpl @heap_end %edx
	ja alloc.
L have_space
	movl %eax @%edx+-4
	movl %ecx @%edx+-8
	ret
L alloc
	pushl %eax
	pushl %ecx
	call alloc
	popl %ecx
	popl %eax
	movl @heap_ptr %edx
	jmp have_space^

label missing_ident # (start: *i8, end: *i8) -> ()
	pushl %eax
	pushl %ecx
	call stderr_lineno
	stderr "Name not found: "
	popl %ecx
	popl %eax
	call stderr
	stderr "
"
	ret

label bad_ident # (start: *i8, end: *i8, wanted-type: i32)
	pushl %edx
	pushl %eax
	pushl %ecx
	call stderr_lineno
	popl %ecx
	popl %eax
	call stderr
	stderr " is not a "
	popl %eax
	call stderr_type
	stderr "
"
	ret

label stderr_type # (type: i32)
	testl $STK_SMALL_LAMBDA %eax
	jnz small.
L big
	stderr "type variable"
	ret
L small
	stderr "term variable"
	ret