# Copyright (C) 2026 Sebastian G. Kirmayer # # 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 . # 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