From 77c0fcdb08a580d361e5f097f4088d46eae774a3 Mon Sep 17 00:00:00 2001 From: Jeff Irwin Date: Sun, 10 Nov 2024 14:15:07 -0500 Subject: [PATCH] add mvp bitwise left shift operator `<<` --- src/consts.f90 | 3 + src/eval.f90 | 4 + src/lex.f90 | 3 + src/math_bit_left_shift.f90 | 155 ++++++++++++++++++++++++++++++++++++ src/tests/test.f90 | 46 +++++++++++ src/types.f90 | 19 ++++- 6 files changed, 227 insertions(+), 3 deletions(-) create mode 100644 src/math_bit_left_shift.f90 diff --git a/src/consts.f90 b/src/consts.f90 index c7edb8c3..ed53c05d 100644 --- a/src/consts.f90 +++ b/src/consts.f90 @@ -16,6 +16,7 @@ module syntran__consts_m ! Token and syntax node kinds enum. Is there a better way to do this that ! allows re-ordering enums? Currently it would break kind_name() integer, parameter :: & + less_less_token = 107, & continue_statement = 106, & continue_keyword = 105, & break_statement = 104, & @@ -242,6 +243,7 @@ function kind_token(kind) "break statement ", & ! 104 "continue ", & ! 105 "continue statement ", & ! 106 + "<< ", & ! 107 "unknown " & ! inf ] @@ -369,6 +371,7 @@ function kind_name(kind) "break_statement ", & ! 104 "continue keyword ", & ! 105 "continue statement ", & ! 106 + "less_less_token ", & ! 107 "unknown " & ! inf (trailing comma hack) ] ! FIXME: update kind_tokens array too diff --git a/src/eval.f90 b/src/eval.f90 index 9f402d14..797487f8 100644 --- a/src/eval.f90 +++ b/src/eval.f90 @@ -7,6 +7,7 @@ module syntran__eval_m use syntran__bool_m use syntran__math_m + use syntran__math_left_shift_m ! consider grouping/encapsulating in a math bitwise module? use syntran__types_m implicit none @@ -234,6 +235,9 @@ recursive subroutine eval_binary_expr(node, state, res) case (greater_equals_token) call is_ge(left, right, res, node%op%text) + case (less_less_token) + call left_shift(left, right, res, node%op%text) + case default write(*,*) err_eval_binary_op(node%op%text) call internal_error() diff --git a/src/lex.f90 b/src/lex.f90 index 051f4ec9..a9a80f35 100644 --- a/src/lex.f90 +++ b/src/lex.f90 @@ -811,6 +811,9 @@ function lex(lexer) result(token) if (lexer%lookahead() == "=") then lexer%pos = lexer%pos + 1 token = new_token(less_equals_token, lexer%pos, "<=") + else if (lexer%lookahead() == "<") then + lexer%pos = lexer%pos + 1 + token = new_token(less_less_token, lexer%pos, "<<") else token = new_token(less_token, lexer%pos, lexer%current()) end if diff --git a/src/math_bit_left_shift.f90 b/src/math_bit_left_shift.f90 new file mode 100644 index 00000000..2710912a --- /dev/null +++ b/src/math_bit_left_shift.f90 @@ -0,0 +1,155 @@ + +!=============================================================================== + +module syntran__math_left_shift_m + + ! Unlike math_bin_*.f90, this source was manually generated, but by copying + ! from math_bin_subtract.f90 and removing all the f32/f64 cases + ! + ! Shifting is defined *only* for integers, not floats. However, an i32 can + ! be shifted by i64 and vice-versa. This will not be the case for bitwise + ! and, or, etc. + + use syntran__value_m + + implicit none + + interface left_shift + module procedure left_shift_value_t + end interface left_shift + +!=============================================================================== + +contains + +!=============================================================================== + +subroutine left_shift_value_t(left, right, res, op_text) + + type(value_t), intent(in) :: left, right + + type(value_t), intent(inout) :: res + + character(len = *), intent(in) :: op_text + + select case (magic**2 * res%type + magic * left%type + right%type) + !**** + case (magic**2 * array_type + magic * array_type + i32_type) + !print *, 'array_type + i32_type' + + select case (left%array%type) + case (i32_type) + res%array = mold(left%array, i32_type) + res%array%i32 = shiftl(left%array%i32, right%sca%i32) + case (i64_type) + res%array = mold(left%array, i64_type) + res%array%i64 = shiftl(left%array%i64, right%sca%i32) + case default + write(*,*) err_eval_binary_types(op_text) + call internal_error() + end select + + !**** + case (magic**2 * array_type + magic * array_type + i64_type) + !print *, 'array_type + i64_type' + + select case (left%array%type) + case (i32_type) + res%array = mold(left%array, i64_type) + res%array%i64 = shiftl(left%array%i32, right%sca%i64) + case (i64_type) + res%array = mold(left%array, i64_type) + res%array%i64 = shiftl(left%array%i64, right%sca%i64) + case default + write(*,*) err_eval_binary_types(op_text) + call internal_error() + end select + + !**** + case (magic**2 * array_type + magic * i32_type + array_type) + !print *, 'i32_type + array_type' + + select case (right%array%type) + case (i32_type) + res%array = mold(right%array, i32_type) + res%array%i32 = shiftl(left%sca%i32, right%array%i32) + case (i64_type) + res%array = mold(right%array, i64_type) + res%array%i64 = shiftl(left%sca%i32, right%array%i64) + case default + write(*,*) err_eval_binary_types(op_text) + call internal_error() + end select + + !**** + case (magic**2 * array_type + magic * i64_type + array_type) + !print *, 'i32_type + array_type' + + select case (right%array%type) + case (i32_type) + res%array = mold(right%array, i64_type) + res%array%i64 = shiftl(left%sca%i64, right%array%i32) + case (i64_type) + res%array = mold(right%array, i64_type) + res%array%i64 = shiftl(left%sca%i64, right%array%i64) + case default + write(*,*) err_eval_binary_types(op_text) + call internal_error() + end select + + !**** + case (magic**2 * array_type + magic * array_type + array_type) + + select case (magic * left%array%type + right%array%type) + case (magic * i32_type + i32_type) + res%array = mold(right%array, i32_type) + res%array%i32 = shiftl(left%array%i32, right%array%i32) + + case (magic * i64_type + i64_type) + res%array = mold(right%array, i64_type) + res%array%i64 = shiftl(left%array%i64, right%array%i64) + + case (magic * i32_type + i64_type) + res%array = mold(right%array, i64_type) + res%array%i64 = shiftl(left%array%i32, right%array%i64) + + case (magic * i64_type + i32_type) + res%array = mold(right%array, i64_type) + res%array%i64 = shiftl(left%array%i64, right%array%i32) + + case default + write(*,*) err_eval_binary_types(op_text) + call internal_error() + + end select + + !**** + case (magic**2 * i32_type + magic * i32_type + i32_type) + res%sca%i32 = shiftl(left%sca%i32, right%sca%i32) + + case (magic**2 * i64_type + magic * i64_type + i64_type) + res%sca%i64 = shiftl(left%sca%i64, right%sca%i64) + + case (magic**2 * i64_type + magic * i64_type + i32_type) + res%sca%i64 = shiftl(left%sca%i64, right%sca%i32) + + case (magic**2 * i64_type + magic * i32_type + i64_type) + res%sca%i64 = shiftl(left%sca%i32, right%sca%i64) + + case (magic**2 * i32_type + magic * i32_type + i64_type) + res%sca%i32 = shiftl(left%sca%i32, right%sca%i64) + + !**** + case default + write(*,*) err_eval_binary_types(op_text) + call internal_error() + end select + +end subroutine left_shift_value_t + +!=============================================================================== + +end module syntran__math_left_shift_m + +!=============================================================================== + diff --git a/src/tests/test.f90 b/src/tests/test.f90 index 33f5719c..8e7233a6 100644 --- a/src/tests/test.f90 +++ b/src/tests/test.f90 @@ -1628,6 +1628,51 @@ end subroutine unit_test_literals !=============================================================================== +subroutine unit_test_bitwise(npass, nfail) + + ! Bitwise operators: shift, and, xor, etc. + + implicit none + + integer, intent(inout) :: npass, nfail + + !******** + + character(len = *), parameter :: label = "bitwise operators" + + logical, allocatable :: tests(:) + + write(*,*) "Unit testing "//label//" ..." + + tests = & + [ & + eval_i32("1 << 0;") == 1, & + eval_i32("1 << 1;") == 2, & + eval_i32("1 << 3;") == 8, & + eval_i32("0x0f << 4;") == 15*16, & + eval_i32("0x0f << 4;") == eval_i32("0xf0;"), & + eval_i32("0x00ff << 8;") == eval_i32("0xff00;"), & + eval_i32("0x00ff00 << 8;") == eval_i32("0xff0000;"), & + eval_i32("0xff00_0000 << 1;") == eval_i32("0xfe00_0000;"), & + eval_i32("0xff00_0000 << 4;") == eval_i32("0xf000_0000;"), & + eval_i32("0xff00_0000 << 8;") == eval_i32("0x0000_0000;"), & + eval_i32("0b00001011 << 0;") == eval_i32("0b00001011;"), & + eval_i32("0b00001011 << 1;") == eval_i32("0b00010110;"), & + eval_i32("0b00001011 << 2;") == eval_i32("0b00101100;"), & + eval_i32("0b00001011 << 3;") == eval_i32("0b01011000;"), & + eval_i32("0b00001011 << 4;") == eval_i32("0b10110000;"), & + .false. & ! so I don't have to bother w/ trailing commas + ] + + ! Trim dummy false element + tests = tests(1: size(tests) - 1) + + call unit_test_coda(tests, label, npass, nfail) + +end subroutine unit_test_bitwise + +!=============================================================================== + subroutine unit_test_i64(npass, nfail) ! Simple i64 integer tests of arithmetic with single-line @@ -4217,6 +4262,7 @@ subroutine unit_tests(iostat) call unit_test_struct_1 (npass, nfail) call unit_test_f64_mix (npass, nfail) call unit_test_literals (npass, nfail) + call unit_test_bitwise (npass, nfail) ! TODO: add tests that mock interpreting one line at a time (as opposed to ! whole files) diff --git a/src/types.f90 b/src/types.f90 index a912ceec..f4424b3b 100644 --- a/src/types.f90 +++ b/src/types.f90 @@ -1528,6 +1528,11 @@ logical function is_binary_op_allowed(left, op, right, left_arr, right_arr) & allowed = is_num_type(left) .and. is_num_type(right) end if + case (less_less_token) + ! Bitwise shift operators work on any combination of ints + allowed = is_int_type(left) .and. is_int_type(right) + ! TODO: arrays in elemental sense + case (and_keyword, or_keyword) if (left == array_type .and. right == array_type) then @@ -1675,16 +1680,19 @@ integer function get_binary_op_prec(kind) result(prec) ! Follow C operator precedence here, except possible for bitwise and/or case (sstar_token) - prec = 7 + prec = 8 case (star_token, slash_token, percent_token) - prec = 6 + prec = 7 case (plus_token, minus_token) - prec = 5 + prec = 6 case (less_token, less_equals_token, & greater_token, greater_equals_token) + prec = 5 + + case (less_less_token) prec = 4 case (eequals_token, bang_equals_token) @@ -1886,6 +1894,11 @@ recursive integer function get_binary_op_kind(left, op, right, & kind_ = bool_type end if + case (less_less_token) + ! Bitwise shifts always return the left operand's type + kind_ = left + ! TODO: arrays + case default !print *, 'default'