diff --git a/config/sysdep.f90 b/config/sysdep.f90 index e08746a..7af88cd 100644 --- a/config/sysdep.f90 +++ b/config/sysdep.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2019 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -35,11 +35,14 @@ module pm_sysdep ! ********* Error messages **************** ! Error messages in colour logical:: pm_colour_messages=.true. + logical:: pm_bright_messages=.true. + logical:: pm_bold_messages=.true. + character(len=*),parameter:: pm_error_start_bright=achar(27)//'[91;1m' character(len=*),parameter:: pm_error_start=achar(27)//'[31;1m' character(len=*),parameter:: pm_error_end=achar(27)//'[39;22m' character(len=*),parameter:: pm_loc_start=achar(27)//'[1m' character(len=*),parameter:: pm_loc_end=achar(27)//'[22m' - + ! ********* File settings ***************** ! Standard output integer,parameter:: pm_stdout_unit=6 @@ -50,11 +53,14 @@ module pm_sysdep ! Suffix for input files character(len=4),parameter:: pm_file_suffix='.pmm' - ! Prefix for library files - character(len=15),parameter:: pm_file_prefix='/usr/lib/pm/lib' + ! Environment variable holding location of library files + character(len=12),parameter:: pm_env_var='PM_LANG_LIBS' ! Directory separator (one character only) character(len=1),parameter:: pm_file_dirsep='/' + + ! Path separator (one character only) + character(len=1),parameter:: pm_lib_path_sep=':' ! Maximum size of file name integer,parameter:: pm_max_filename_size=4096 @@ -62,10 +68,15 @@ module pm_sysdep ! Character value used to signal end of file character(len=1),parameter:: pm_eof_char=achar(0) + ! Default library path + character(len=22):: pm_default_lib_path='/usr/share/pm-lang/lib' + logical:: pm_default_lib_path_set=.true. ! ************ Compiler defaults **************** integer,parameter:: pm_default_ftn_dims=15 logical,parameter:: pm_default_ftn_has_contiguous=.true. + integer,parameter:: pm_default_ftn_lines=255 + integer,parameter:: pm_default_ftn_max_stack_array=10*1024*1024 ! ************ Memory model ********************* @@ -80,13 +91,14 @@ module pm_sysdep ! Types used by memory model (block offsets,object sizes,bitmap flags) - ! integer,parameter:: pm_p=kind(1) ! Pointer offsets, object types + - ! flags (>~24 bits, typically int) -integer,parameter:: pm_p=8 + ! integer,parameter:: pm_p=kind(1) ! Pointer offsets, object types + + ! flags (>~24 bits, typically int) + + integer,parameter:: pm_p=8 - integer,parameter:: pm_f=kind(1) ! Bitmap storage (integer word) - ! On some systems int64 may - ! improve things slightly + integer,parameter:: pm_f=kind(1) ! Bitmap storage (integer word) + ! On some systems int64 may + ! improve things slightly ! ********* Vector Virtual Machine ******** @@ -166,20 +178,50 @@ module pm_sysdep ! Long long integers - big enough to address any file integer,parameter:: pm_lln=MPI_OFFSET_KIND - + + ! Maximum arguments to a PM procedure (must be 2**m-1 for some m) + integer,parameter:: pm_max_args=31 + character(len=3),parameter:: pm_maxargs_str=' 31' + contains - function pm_argc() result(n) - integer:: n - n=iargc() - end function pm_argc + function pm_argc() result(n) + integer:: n + n=command_argument_count() + end function pm_argc + + subroutine pm_getarg(n,str) + integer,intent(in)::n + character(len=*):: str + call get_command_argument(n,str) + end subroutine pm_getarg + + subroutine pm_get_env_var(varname,str,ok) + character(len=*):: varname,str + logical:: ok + integer:: status + call get_environment_variable(varname,str,status=status) + ok=status==0 + end subroutine pm_get_env_var - subroutine pm_getarg(n,str) - integer,intent(in)::n - character(len=*):: str - call getarg(n,str) - end subroutine pm_getarg +!!$ function pm_argc() result(n) +!!$ integer:: n +!!$ n=iargc() +!!$ end function pm_argc +!!$ +!!$ subroutine pm_getarg(n,str) +!!$ integer,intent(in)::n +!!$ character(len=*):: str +!!$ call getarg(n,str) +!!$ end subroutine pm_getarg + +!!$ subroutine pm_get_env_var(varname,str,ok) +!!$ character(len=*):: varname,str +!!$ logical:: ok +!!$ call getenv(varname,str) +!!$ ok=str/=' ' +!!$ end subroutine pm_get_env_var function pm_isatty(l) result(ok) integer,intent(in)::l @@ -194,25 +236,66 @@ end function pm_isatty ! ok=pm_colour_messages ! end function pm_isatty - subroutine pm_module_filename(inbuffer,buffer) - character(len=*):: inbuffer,buffer - integer:: n,m - buffer=inbuffer - n=len_trim(buffer) - if(n>len(pm_file_suffix)) then - if(buffer(n-len(pm_file_suffix)+1:n)==pm_file_suffix) return - endif - if(buffer(1:4)=='lib.') then - m=len(pm_file_prefix) - buffer(m+1:m+n)=buffer(1:n) - buffer(1:m)=pm_file_prefix - endif - do m=1,n - if(buffer(m:m)=='.') then - buffer(m:m)=pm_file_dirsep - endif - enddo - buffer(n+1:n+len(pm_file_suffix))=pm_file_suffix - end subroutine pm_module_filename + subroutine pm_module_filename(inbuffer,buffer,lib_path_set,lib_path) + character(len=*),intent(in):: inbuffer,lib_path + character(len=*),intent(out):: buffer + logical,intent(in):: lib_path_set + integer:: n,m,i,tot,pathlen + logical:: ok + n=len_trim(inbuffer) + if(n>len(pm_file_suffix)) then + if(inbuffer(n-len(pm_file_suffix)+1:n)==pm_file_suffix) then + buffer=inbuffer + return + endif + endif + if(inbuffer(1:4)=='lib.'.and.lib_path_set) then + i=1 + do + m=index(lib_path(i:),pm_lib_path_sep) +!!$ write(*,*) 'm=',m,trim(lib_path(i:m-1)) + if(m==0) then + m=len_trim(lib_path) + else + m=m+i-2 + endif + if(m>=i) then + pathlen=m-i+1 + tot=pathlen+n-3 + if(tot+len_trim(pm_file_suffix)>len(buffer)) then + if(m+2>len(lib_path)) exit + i=m+2 + cycle + endif + buffer(1:pathlen)=lib_path(i:m) + do i=4,n + if(inbuffer(i:i)=='.') then + buffer(i+pathlen-3:i+pathlen-3)=pm_file_dirsep + else + buffer(i+pathlen-3:i+pathlen-3)=inbuffer(i:i) + endif + enddo + buffer(tot+1:)=pm_file_suffix +!!$ write(*,*) 'TRY:',trim(buffer) + inquire(file=trim(buffer),exist=ok) + if(ok) return + else + exit + endif + if(m+2>len(lib_path)) exit + i=m+2 + end do + endif + do m=1,n + if(inbuffer(m:m)=='.') then + buffer(m:m)=pm_file_dirsep + else + buffer(m:m)=inbuffer(m:m) + endif + end do + if(n+len(pm_file_suffix)<=len(buffer)) then + buffer(n+1:)=pm_file_suffix + endif + end subroutine pm_module_filename end module pm_sysdep diff --git a/lib/sys/pm.pmm b/lib/sys/pm.pmm new file mode 100644 index 0000000..ef3a7b9 --- /dev/null +++ b/lib/sys/pm.pmm @@ -0,0 +1,1860 @@ +/* + PM (Parallel Models) Programming Language + + Released under the MIT License (MIT) + Copyright (c) Tim Bellerby, 2025 + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. +*/ + + +PM__intrinsic num_elements(any)->(literal(int)) : "num_elems_fold" + +PM__intrinsic mod(literal(int),literal(int))->(literal(int)) : "mod_fold" +PM__intrinsic ==(literal(int),literal(int))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(int),literal(int))->(literal(bool)) : "ne_fold" +PM__intrinsic >=(literal(int),literal(int))->(literal(bool)) : "ge_fold" +PM__intrinsic >(literal(int),literal(int))->(literal(bool)) : "gt_fold" +PM__intrinsic +(literal(int),literal(int))->(literal(int)) : "add_fold" +PM__intrinsic -(literal(int),literal(int))->(literal(int)) : "sub_fold" +PM__intrinsic *(literal(int),literal(int))->(literal(int)) : "mult_fold" +PM__intrinsic /(literal(int),literal(int))->(literal(int)) : "divide_fold" +PM__intrinsic **(literal(int),literal(int))->(literal(int)) : "pow_fold" +PM__intrinsic max(literal(int),literal(int))->(literal(int)) : "max_fold" +PM__intrinsic min(literal(int),literal(int))->(literal(int)) : "min_fold" +PM__intrinsic -(literal(int))->(literal(int)) : "uminus_fold" +PM__intrinsic string(literal(int))->(literal(string)) : "string_fold" +PM__intrinsic abs(literal(int))->(literal(int)) : "abs_fold" +PM__intrinsic ~(literal(int))->(literal(int)) : "bnot_fold" +PM__intrinsic &(literal(int),literal(int))->(literal(int)) : "band_fold" +PM__intrinsic |(literal(int),literal(int))->(literal(int)) : "bor_fold" +PM__intrinsic ~(literal(int),literal(int))->(literal(int)) : "bxor_fold" +PM__intrinsic shift(literal(int),literal(int))->(literal(int)) : "bshift_fold" +PM__intrinsic pdiff(literal(int),literal(int))->(literal(int)) : "pdiff_fold" +PM__intrinsic sign(literal(int),literal(int))->(literal(int)) : "sign_fold" +PM__intrinsic rem(literal(int),literal(int))->(literal(int)) : "modulo_fold" +PM__intrinsic and(literal(bool),literal(bool))->(literal(bool)) : "and_fold" +PM__intrinsic or(literal(bool),literal(bool))->(literal(bool)) : "or_fold" +PM__intrinsic except(literal(bool),literal(bool))->(literal(bool)) : "except_fold" +PM__intrinsic ==(literal(bool),literal(bool))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(bool),literal(bool))->(literal(bool)) : "ne_fold" +PM__intrinsic ==(literal(string),literal(string))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(string),literal(string))->(literal(bool)) : "ne_fold" +PM__intrinsic ==(literal(real),literal(real))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(real),literal(real))->(literal(bool)) : "ne_fold" +PM__intrinsic ++(literal(string),literal(string))->(literal(string)) : "concat_fold" +PM__intrinsic mod(fix(int),fix(int))->(fix(int)) : "mod_fold" +PM__intrinsic ==(fix(int),fix(int))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(int),fix(int))->(fix(bool)) : "ne_fold" +PM__intrinsic >=(fix(int),fix(int))->(fix(bool)) : "ge_fold" +PM__intrinsic >(fix(int),fix(int))->(fix(bool)) : "gt_fold" +PM__intrinsic +(fix(int),fix(int))->(fix(int)) : "add_fold" +PM__intrinsic -(fix(int),fix(int))->(fix(int)) : "sub_fold" +PM__intrinsic *(fix(int),fix(int))->(fix(int)) : "mult_fold" +PM__intrinsic /(fix(int),fix(int))->(fix(int)) : "divide_fold" +PM__intrinsic **(fix(int),fix(int))->(fix(int)) : "pow_fold" +PM__intrinsic max(fix(int),fix(int))->(fix(int)) : "max_fold" +PM__intrinsic min(fix(int),fix(int))->(fix(int)) : "min_fold" +PM__intrinsic -(fix(int))->(fix(int)) : "uminus_fold" +PM__intrinsic string(fix(int))->(fix(string)) : "string_fold" +PM__intrinsic abs(fix(int))->(fix(int)) : "abs_fold" +PM__intrinsic ~(fix(int))->(fix(int)) : "bnot_fold" +PM__intrinsic &(fix(int),fix(int))->(fix(int)) : "band_fold" +PM__intrinsic |(fix(int),fix(int))->(fix(int)) : "bor_fold" +PM__intrinsic ~(fix(int),fix(int))->(fix(int)) : "bxor_fold" +PM__intrinsic shift(fix(int),fix(int))->(fix(int)) : "bshift_fold" +PM__intrinsic pdiff(fix(int),fix(int))->(fix(int)) : "pdiff_fold" +PM__intrinsic sign(fix(int),fix(int))->(fix(int)) : "sign_fold" +PM__intrinsic rem(fix(int),fix(int))->(fix(int)) : "modulo_fold" +PM__intrinsic and(fix(bool),fix(bool))->(fix(bool)) : "and_fold" +PM__intrinsic or(fix(bool),fix(bool))->(fix(bool)) : "or_fold" +PM__intrinsic except(fix(bool),fix(bool))->(fix(bool)) : "except_fold" +PM__intrinsic ==(fix(bool),fix(bool))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(bool),fix(bool))->(fix(bool)) : "ne_fold" +PM__intrinsic ==(fix(string),fix(string))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(string),fix(string))->(fix(bool)) : "ne_fold" +PM__intrinsic ==(fix(real),fix(real))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(real),fix(real))->(fix(bool)) : "ne_fold" +PM__intrinsic ++(fix(string),fix(string))->(fix(string)) : "concat_fold" + +// ************************************** +// BASIC TYPES +// ************************************** + +// String type +PM__intrinsic<> print(string): "print" + +proc print(x) { + print(string(x)) +} + +PM__intrinsic<> print_all(string): "print"(1) + +proc print_all(x) { + print_all(string(x)) +} + +PM__intrinsic ++(string,string)->(string) : "concat" + +proc ++(x:string,y)=$++.(x,string(y)) +proc ++(x,y)=$++.(string(x),string(y)) +proc string(x:string)=x +proc string(x:null)="null" +proc fmt(x,y)=x:compile_error( """fmt"" operator not yet implmented") + +// sint type +PM__intrinsic PM__assign_var(&sint,sint): "assign_i" +PM__intrinsic mod(sint,sint)->(sint) : "mod_i" +PM__intrinsic ==(sint,sint)->(bool) : "eq_i" +PM__intrinsic /=(sint,sint)->(bool) : "ne_i" +PM__intrinsic >=(sint,sint)->(bool) : "ge_i" +PM__intrinsic >(sint,sint)->(bool) : "gt_i" +PM__intrinsic +(sint,sint)->(sint) : "add_i" +PM__intrinsic -(sint,sint)->(sint) : "sub_i" +PM__intrinsic *(sint,sint)->(sint) : "mult_i" +PM__intrinsic /(sint,sint)->(sint) : "divide_i" +PM__intrinsic **(sint,sint)->(sint) : "pow_i" +PM__intrinsic max(sint,sint)->(sint) : "max_i" +PM__intrinsic min(sint,sint)->(sint) : "min_i" +PM__intrinsic -(sint)->(sint) : "uminus_i" +PM__intrinsic string(sint)->(string) : "string_i" +PM__intrinsic int(sint)->(int) : "long_i" +PM__intrinsic sreal(sint)->(sreal) : "real_i" +PM__intrinsic real(sint)->(real) : "double_i" +proc sint(x:sint)=x +PM__intrinsic abs(sint)->(sint) : "abs_i" +PM__intrinsic bit_not(sint)->(sint) : "bnot_i" +PM__intrinsic &(sint,sint)->(sint) : "band_i" +PM__intrinsic |(sint,sint)->(sint) : "bor_i" +PM__intrinsic ~(sint,sint)->(sint) : "bxor_i" +PM__intrinsic shift(sint,sint)->(sint) : "bshift_i" +PM__intrinsic pdiff(sint,sint)->(sint) : "pdiff_i" +PM__intrinsic sign(sint,sint)->(sint) : "sign_i" +PM__intrinsic rem(sint,sint)->(sint) : "modulo_i" +PM__intrinsic int8(sint)->(int8) : "i8_i" +PM__intrinsic int16(sint)->(int16) : "i16_i" +PM__intrinsic int32(sint)->(int32) : "i32_i" +PM__intrinsic int64(sint)->(int64) : "i64_i" +PM__intrinsic lint(sint)->(lint) : "offset_i" + +// int type +PM__intrinsic PM__assign_var(&int,int): "assign_ln" +PM__intrinsic mod(int,int)->(int) : "mod_ln" +PM__intrinsic ==(int,int)->(bool) : "eq_ln" +PM__intrinsic /=(int,int)->(bool) : "ne_ln" +PM__intrinsic >=(int,int)->(bool) : "ge_ln" +PM__intrinsic >(int,int)->(bool) : "gt_ln" +PM__intrinsic +(int,int)->(int) : "add_ln" +PM__intrinsic -(int,int)->(int) : "sub_ln" +PM__intrinsic *(int,int)->(int) : "mult_ln" +proc *(x:int,y:fix(1))=x +PM__intrinsic /(int,int)->(int) : "divide_ln" +proc /(x:int,y:fix(1))=x +PM__intrinsic **(int,int)->(int) : "pow_ln" +PM__intrinsic max(int,int)->(int) : "max_ln" +PM__intrinsic min(int,int)->(int) : "min_ln" +PM__intrinsic -(int)->(int) : "uminus_ln" +PM__intrinsic string(int)->(string) : "string_ln" +PM__intrinsic fmt(int,int)->(string) : "fmt_ln" +PM__intrinsic sint(int)->(sint) : "int_ln" +PM__intrinsic sreal(int)->(sreal) : "real_ln" +PM__intrinsic real(int)->(real) : "double_ln" +proc int(x:int)=x +PM__intrinsic abs(int)->(int) : "abs_ln" +PM__intrinsic ~(int)->(int) : "bnot_ln" +PM__intrinsic &(int,int)->(int) : "band_ln" +PM__intrinsic |(int,int)->(int) : "bor_ln" +PM__intrinsic ~(int,int)->(int) : "bxor_ln" +PM__intrinsic shift(int,int)->(int) : "bshift_ln" +PM__intrinsic pdiff(int,int)->(int) : "pdiff_ln" +PM__intrinsic sign(int,int)->(int) : "sign_ln" +PM__intrinsic rem(int,int)->(int) : "modulo_ln" +PM__intrinsic int8(int)->(int8) : "i8_ln" +PM__intrinsic int16(int)->(int16) : "i16_ln" +PM__intrinsic int32(int)->(int32) : "i32_ln" +PM__intrinsic int64(int)->(int64) : "i64_ln" +PM__intrinsic lint(int)->(lint) : "offset_ln" + +// lint type +PM__intrinsic PM__assign_var(&lint,lint): "assign_offset" +PM__intrinsic mod(lint,lint)->(lint) : "mod_offset" +PM__intrinsic ==(lint,lint)->(bool) : "eq_offset" +PM__intrinsic /=(lint,lint)->(bool) : "ne_offset" +PM__intrinsic >=(lint,lint)->(bool) : "ge_offset" +PM__intrinsic >(lint,lint)->(bool) : "gt_offset" +PM__intrinsic +(lint,lint)->(lint) : "add_offset" +proc +(x:lint,y:fix(0))=x +proc +(x:fix(0),y:lint)=y +PM__intrinsic -(lint,lint)->(lint) : "sub_offset" +proc -(x:lint,y:fix(0))=x +PM__intrinsic *(lint,lint)->(lint) : "mult_offset" +proc *(x:lint,y:fix(1))=x +proc *(x:fix(1),y:lint)=y +PM__intrinsic /(lint,lint)->(lint) : "divide_offset" +proc /(x:lint,y:fix(1))=x +PM__intrinsic **(lint,lint)->(lint) : "pow_offset" +proc **(x:lint,y:fix(0))=1 +proc **(x:lint,y:fix(1))=x +proc **(x:lint,y:fix(2))=x*x +PM__intrinsic max(lint,lint)->(lint) : "max_offset" +PM__intrinsic min(lint,lint)->(lint) : "min_offset" +PM__intrinsic -(lint)->(lint) : "uminus_offset" +PM__intrinsic string(lint)->(string) : "string_offset" +PM__intrinsic fmt(lint,int)->(string) : "fmt_offset" +PM__intrinsic sint(lint)->(sint) : "int_offset" +PM__intrinsic sreal(lint)->(sreal) : "real_offset" +PM__intrinsic real(lint)->(real) : "double_offset" +proc lint(x:lint)=x +PM__intrinsic abs(lint)->(lint) : "abs_offset" +PM__intrinsic ~(lint)->(lint) : "bnot_offset" +PM__intrinsic &(lint,lint)->(lint) : "band_offset" +PM__intrinsic |(lint,lint)->(lint) : "bor_offset" +PM__intrinsic ~(lint,lint)->(lint) : "bxor_offset" +PM__intrinsic shift(lint,lint)->(lint) : "bshift_offset" +PM__intrinsic pdiff(lint,lint)->(lint) : "pdiff_offset" +PM__intrinsic sign(lint,lint)->(lint) : "sign_offset" +PM__intrinsic rem(lint,lint)->(lint) : "modulo_offset" +PM__intrinsic int8(lint)->(int8) : "i8_offset" +PM__intrinsic int16(lint)->(int16) : "i16_offset" +PM__intrinsic int32(lint)->(int32) : "i32_offset" +PM__intrinsic int64(lint)->(int64) : "i64_offset" +PM__intrinsic int(lint)->(int) : "long_offset" + +// int8 type +PM__intrinsic PM__assign_var(&int8,int8): "assign_i8" +PM__intrinsic mod(int8,int8)->(int8) : "mod_i8" +PM__intrinsic ==(int8,int8)->(bool) : "eq_i8" +PM__intrinsic /=(int8,int8)->(bool) : "ne_i8" +PM__intrinsic >=(int8,int8)->(bool) : "ge_i8" +PM__intrinsic >(int8,int8)->(bool) : "gt_i8" +PM__intrinsic +(int8,int8)->(int8) : "add_i8" +proc +(x:int8,y:fix(0))=x +proc +(x:fix(0),y:int8)=y +PM__intrinsic -(int8,int8)->(int8) : "sub_i8" +proc -(x:int8,y:fix(0))=x +PM__intrinsic *(int8,int8)->(int8) : "mult_i8" +proc *(x:int8,y:fix(1))=x +proc *(x:fix(1),y:int8)=y +PM__intrinsic /(int8,int8)->(int8) : "divide_i8" +proc /(x:int8,y:fix(1))=x +PM__intrinsic **(int8,int8)->(int8) : "pow_i8" +proc **(x:int8,y:fix(0))=1 +proc **(x:int8,y:fix(1))=x +proc **(x:int8,y:fix(2))=x*x +PM__intrinsic max(int8,int8)->(int8) : "max_i8" +PM__intrinsic min(int8,int8)->(int8) : "min_i8" +PM__intrinsic -(int8)->(int8) : "uminus_i8" +PM__intrinsic sint(int8)->(sint) : "int_i8" +PM__intrinsic sreal(int8)->(sreal) : "real_i8" +PM__intrinsic real(int8)->(real) : "double_i8" +proc int8(x:int8)=x +PM__intrinsic abs(int8)->(int8) : "abs_i8" +PM__intrinsic ~(int8)->(int8) : "bnot_i8" +PM__intrinsic &(int8,int8)->(int8) : "band_i8" +PM__intrinsic |(int8,int8)->(int8) : "bor_i8" +PM__intrinsic ~(int8,int8)->(int8) : "bxor_i8" +PM__intrinsic shift(int8,int8)->(int8) : "bshift_i8" +PM__intrinsic pdiff(int8,int8)->(int8) : "pdiff_i8" +PM__intrinsic sign(int8,int8)->(int8) : "sign_i8" +PM__intrinsic rem(int8,int8)->(int8) : "modulo_i8" +PM__intrinsic int16(int8)->(int16) : "i16_i8" +PM__intrinsic int32(int8)->(int32) : "i32_i8" +PM__intrinsic int64(int8)->(int64) : "i64_i8" +PM__intrinsic int(int8)->(int) : "long_i8" +PM__intrinsic lint(int8)->(lint) : "offset_i8" + +// int16 type +PM__intrinsic PM__assign_var(&int16,int16): "assign_i16" +PM__intrinsic mod(int16,int16)->(int16) : "mod_i16" +PM__intrinsic ==(int16,int16)->(bool) : "eq_i16" +PM__intrinsic /=(int16,int16)->(bool) : "ne_i16" +PM__intrinsic >=(int16,int16)->(bool) : "ge_i16" +PM__intrinsic >(int16,int16)->(bool) : "gt_i16" +PM__intrinsic +(int16,int16)->(int16) : "add_i16" +proc +(x:int16,y:fix(0))=x +proc +(x:fix(0),y:int16)=y +PM__intrinsic -(int16,int16)->(int16) : "sub_i16" +proc -(x:int16,y:fix(0))=x +PM__intrinsic *(int16,int16)->(int16) : "mult_i16" +proc *(x:int16,y:fix(1))=x +proc *(x:fix(1),y:int16)=y +PM__intrinsic /(int16,int16)->(int16) : "divide_i16" +proc /(x:int16,y:fix(1))=x +PM__intrinsic **(int16,int16)->(int16) : "pow_i16" +proc **(x:int16,y:fix(0))=1 +proc **(x:int16,y:fix(1))=x +proc **(x:int16,y:fix(2))=x*x +PM__intrinsic max(int16,int16)->(int16) : "max_i16" +PM__intrinsic min(int16,int16)->(int16) : "min_i16" +PM__intrinsic -(int16)->(int16) : "uminus_i16" +PM__intrinsic sint(int16)->(sint) : "int_i16" +PM__intrinsic sreal(int16)->(sreal) : "real_i16" +PM__intrinsic real(int16)->(real) : "double_i16" +proc int16(x:int16)=x +PM__intrinsic abs(int16)->(int16) : "abs_i16" +PM__intrinsic ~(int16)->(int16) : "bnot_i16" +PM__intrinsic &(int16,int16)->(int16) : "band_i16" +PM__intrinsic |(int16,int16)->(int16) : "bor_i16" +PM__intrinsic ~(int16,int16)->(int16) : "bxor_i16" +PM__intrinsic shift(int16,int16)->(int16) : "bshift_i16" +PM__intrinsic pdiff(int16,int16)->(int16) : "pdiff_i16" +PM__intrinsic sign(int16,int16)->(int16) : "sign_i16" +PM__intrinsic rem(int16,int16)->(int16) : "modulo_i16" +PM__intrinsic int8(int16)->(int16) : "i8_i16" +PM__intrinsic int32(int16)->(int32) : "i32_i16" +PM__intrinsic int64(int16)->(int64) : "i64_i16" +PM__intrinsic int(int16)->(int) : "long_i16" +PM__intrinsic lint(int16)->(lint) : "offset_i16" + +// int32 type +PM__intrinsic PM__assign_var(&int32,int32): "assign_i32" +PM__intrinsic mod(int32,int32)->(int32) : "mod_i32" +PM__intrinsic ==(int32,int32)->(bool) : "eq_i32" +PM__intrinsic /=(int32,int32)->(bool) : "ne_i32" +PM__intrinsic >=(int32,int32)->(bool) : "ge_i32" +PM__intrinsic >(int32,int32)->(bool) : "gt_i32" +PM__intrinsic +(int32,int32)->(int32) : "add_i32" +proc +(x:int32,y:fix(0))=x +proc +(x:fix(0),y:int32)=y +PM__intrinsic -(int32,int32)->(int32) : "sub_i32" +proc -(x:int32,y:fix(0))=x +PM__intrinsic *(int32,int32)->(int32) : "mult_i32" +proc *(x:int32,y:fix(1))=x +proc *(x:fix(1),y:int32)=y +PM__intrinsic /(int32,int32)->(int32) : "divide_i32" +proc /(x:int32,y:fix(1))=x +PM__intrinsic **(int32,int32)->(int32) : "pow_i32" +proc **(x:int32,y:fix(0))=1 +proc **(x:int32,y:fix(1))=x +proc **(x:int32,y:fix(2))=x*x +PM__intrinsic max(int32,int32)->(int32) : "max_i32" +PM__intrinsic min(int32,int32)->(int32) : "min_i32" +PM__intrinsic -(int32)->(int32) : "uminus_i32" +PM__intrinsic sint(int32)->(sint) : "int_i32" +PM__intrinsic sreal(int32)->(sreal) : "real_i32" +PM__intrinsic real(int32)->(real) : "double_i32" +proc int32(x:int32)=x +PM__intrinsic abs(int32)->(int32) : "abs_i32" +PM__intrinsic ~(int32)->(int32) : "bnot_i32" +PM__intrinsic &(int32,int32)->(int32) : "band_i32" +PM__intrinsic |(int32,int32)->(int32) : "bor_i32" +PM__intrinsic ~(int32,int32)->(int32) : "bxor_i32" +PM__intrinsic shift(int32,int32)->(int32) : "bshift_i32" +PM__intrinsic pdiff(int32,int32)->(int32) : "pdiff_i32" +PM__intrinsic sign(int32,int32)->(int32) : "sign_i32" +PM__intrinsic rem(int32,int32)->(int32) : "modulo_i32" +PM__intrinsic int8(int32)->(int32) : "i8_i32" +PM__intrinsic int16(int32)->(int32) : "i16_i32" +PM__intrinsic int64(int32)->(int64) : "i64_i32" +PM__intrinsic int(int32)->(int) : "long_i32" +PM__intrinsic lint(int32)->(lint) : "offset_i32" + +// int64 type +PM__intrinsic PM__assign_var(&int64,int64): "assign_i64" +PM__intrinsic mod(int64,int64)->(int64) : "mod_i64" +PM__intrinsic ==(int64,int64)->(bool) : "eq_i64" +PM__intrinsic /=(int64,int64)->(bool) : "ne_i64" +PM__intrinsic >=(int64,int64)->(bool) : "ge_i64" +PM__intrinsic >(int64,int64)->(bool) : "gt_i64" +PM__intrinsic +(int64,int64)->(int64) : "add_i64" +proc +(x:int64,y:fix(0))=x +proc +(x:fix(0),y:int64)=y +PM__intrinsic -(int64,int64)->(int64) : "sub_i64" +proc -(x:int64,y:fix(0))=x +PM__intrinsic *(int64,int64)->(int64) : "mult_i64" +proc *(x:int64,y:fix(1))=x +proc *(x:fix(1),y:int64)=y +PM__intrinsic /(int64,int64)->(int64) : "divide_i64" +proc /(x:int64,y:fix(1))=x +PM__intrinsic **(int64,int64)->(int64) : "pow_i64" +proc **(x:int64,y:fix(0))=1 +proc **(x:int64,y:fix(1))=x +proc **(x:int64,y:fix(2))=x*x +PM__intrinsic max(int64,int64)->(int64) : "max_i64" +PM__intrinsic min(int64,int64)->(int64) : "min_i64" +PM__intrinsic -(int64)->(int64) : "uminus_i64" +PM__intrinsic string(int64)->(string) : "string_i64" +PM__intrinsic fmt(int64,int)->(string) : "fmt_i64" +PM__intrinsic sint(int64)->(sint) : "int_i64" +PM__intrinsic sreal(int64)->(sreal) : "real_i64" +PM__intrinsic real(int64)->(real) : "double_i64" +proc int64(x:int64)=x +PM__intrinsic abs(int64)->(int64) : "abs_i64" +PM__intrinsic ~(int64)->(int64) : "bnot_i64" +PM__intrinsic &(int64,int64)->(int64) : "band_i64" +PM__intrinsic |(int64,int64)->(int64) : "bor_i64" +PM__intrinsic ~(int64,int64)->(int64) : "bxor_i64" +PM__intrinsic shift(int64,int64)->(int64) : "bshift_i64" +PM__intrinsic pdiff(int64,int64)->(int64) : "pdiff_i64" +PM__intrinsic sign(int64,int64)->(int64) : "sign_i64" +PM__intrinsic rem(int64,int64)->(int64) : "modulo_i64" +PM__intrinsic int8(int64)->(int64) : "i8_i64" +PM__intrinsic int16(int64)->(int64) : "i16_i64" +PM__intrinsic int32(int64)->(int64) : "i32_i64" +PM__intrinsic int(int64)->(int) : "long_i64" +PM__intrinsic lint(int64)->(lint) : "offset_i64" + +// sreal type +PM__intrinsic PM__assign_var(&sreal,sreal): "assign_r" +PM__intrinsic mod(sreal,sreal)->(sreal) : "mod_r" +PM__intrinsic ==(sreal,sreal)->(bool) : "eq_r" +PM__intrinsic /=(sreal,sreal)->(bool) : "ne_r" +PM__intrinsic >=(sreal,sreal)->(bool) : "ge_r" +PM__intrinsic >(sreal,sreal)->(bool) : "gt_r" +PM__intrinsic +(sreal,sreal)->(sreal) : "add_r" +PM__intrinsic -(sreal,sreal)->(sreal) : "sub_r" +PM__intrinsic *(sreal,sreal)->(sreal) : "mult_r" +PM__intrinsic /(sreal,sreal)->(sreal) : "divide_r" +PM__intrinsic **(sreal,sreal)->(sreal) : "pow_r" +PM__intrinsic max(sreal,sreal)->(sreal) : "max_r" +PM__intrinsic min(sreal,sreal)->(sreal) : "min_r" +PM__intrinsic -(sreal)->(sreal) : "uminus_r" +PM__intrinsic string(sreal)->(string) : "string_r" +PM__intrinsic _fmt(sreal,int,int)->(string) : "fmt_dp_r" +PM__intrinsic strunc(sreal)->(sint) : "int_r" +PM__intrinsic trunc(sreal)->(int) : "long_r" +PM__intrinsic ltrunc(sreal)->(lint) : "offset_r" +PM__intrinsic real(sreal)->(real) : "double_r" +proc sreal(x:sreal)=x +PM__intrinsic abs(sreal)->(sreal) : "abs_r" +PM__intrinsic acos(sreal)->(sreal) : "acos_r" +PM__intrinsic asin(sreal)->(sreal) : "asin_r" +PM__intrinsic atan(sreal)->(sreal) : "atan_r" +PM__intrinsic atan2(sreal,sreal)->(sreal) : "atan2_r" +PM__intrinsic cos(sreal)->(sreal) : "cos_r" +PM__intrinsic cosh(sreal)->(sreal) : "cosh_r" +PM__intrinsic exp(sreal)->(sreal) : "exp_r" +PM__intrinsic log(sreal)->(sreal) : "log_r" +PM__intrinsic log10(sreal)->(sreal) : "log10_r" +PM__intrinsic sin(sreal)->(sreal) : "sin_r" +PM__intrinsic sinh(sreal)->(sreal) : "sinh_r" +PM__intrinsic sqrt(sreal)->(sreal) : "sqrt_r" +PM__intrinsic tan(sreal)->(sreal) : "tan_r" +PM__intrinsic tanh(sreal)->(sreal) : "tanh_r" +PM__intrinsic floor(sreal)->(sreal) : "floor_r" +PM__intrinsic ceil(sreal)->(sreal) : "ceil_r" +PM__intrinsic rem(sreal,sreal)->(sreal) : "modulo_r" +PM__intrinsic sign(sreal,sreal)->(sreal) : "sign_r" +PM__intrinsic pdiff(sreal,sreal)->(sreal) : "pdiff_r" +PM__intrinsic lint(sreal)->(lint) : "offset_r" +PM__intrinsic scpx(sreal)->(scpx) : "complex_r" +PM__intrinsic _scpx2(sreal,sreal)->(scpx) : "complex2_r" +proc scpx(x:any_real,y:any_real)=_scpx2(sreal(x),sreal(y)) + +// real type +PM__intrinsic PM__assign_var(&real,real): "assign_d" +PM__intrinsic mod(real,real)->(real) : "mod_d" +PM__intrinsic ==(real,real)->(bool) : "eq_d" +PM__intrinsic /=(real,real)->(bool) : "ne_d" +PM__intrinsic >=(real,real)->(bool) : "ge_d" +PM__intrinsic >(real,real)->(bool) : "gt_d" +PM__intrinsic +(real,real)->(real) : "add_d" +PM__intrinsic -(real,real)->(real) : "sub_d" +PM__intrinsic *(real,real)->(real) : "mult_d" +PM__intrinsic /(real,real)->(real) : "divide_d" +PM__intrinsic **(real,real)->(real) : "pow_d" +PM__intrinsic max(real,real)->(real) : "max_d" +PM__intrinsic min(real,real)->(real) : "min_d" +PM__intrinsic -(real)->(real) : "uminus_d" +PM__intrinsic string(real)->(string) : "string_d" +PM__intrinsic _fmt(real,int,int)->(string) : "fmt_dp_d" +PM__intrinsic strunc(real)->(sint) : "int_d" +PM__intrinsic trunc(real)->(int) : "long_d" +PM__intrinsic ltrunc(real)->(lint) : "offset_d" +PM__intrinsic sreal(real)->(sreal) : "real_d" +proc real(x:real)=x +PM__intrinsic abs(real)->(real) : "abs_d" +PM__intrinsic acos(real)->(real) : "acos_d" +PM__intrinsic asin(real)->(real) : "asin_d" +PM__intrinsic atan(real)->(real) : "atan_d" +PM__intrinsic atan2(real,real)->(real) : "atan2_d" +PM__intrinsic cos(real)->(real) : "cos_d" +PM__intrinsic cosh(real)->(real) : "cosh_d" +PM__intrinsic exp(real)->(real) : "exp_d" +PM__intrinsic log(real)->(real) : "log_d" +PM__intrinsic log10(real)->(real) : "log10_d" +PM__intrinsic sin(real)->(real) : "sin_d" +PM__intrinsic sinh(real)->(real) : "sinh_d" +PM__intrinsic sqrt(real)->(real) : "sqrt_d" +PM__intrinsic tan(real)->(real) : "tan_d" +PM__intrinsic tanh(real)->(real) : "tanh_d" +PM__intrinsic floor(real)->(real) : "floor_d" +PM__intrinsic ceil(real)->(real) : "ceil_d" +PM__intrinsic rem(real,real)->(real) : "modulo_d" +PM__intrinsic sign(real,real)->(real) : "sign_d" +PM__intrinsic pdiff(real,real)->(real) : "pdiff_d" +PM__intrinsic lint(real)->(lint) : "offset_d" +PM__intrinsic cpx(real)->(cpx) : "complex_d" +PM__intrinsic _cpx2(real,real)->(cpx) : "complex2_d" +proc cpx(x:real_num,y:real_num)=_cpx2(real(x),real(y)) + +// scpx type +PM__intrinsic PM__assign_var(&scpx,scpx): "assign_c" +PM__intrinsic +(scpx,scpx)->(scpx) : "add_c" +PM__intrinsic -(scpx,scpx)->(scpx) : "sub_c" +PM__intrinsic *(scpx,scpx)->(scpx) : "mult_c" +PM__intrinsic /(scpx,scpx)->(scpx) : "divide_c" +PM__intrinsic **(scpx,sreal)->(scpx) : "rpow_c" +PM__intrinsic **(scpx,scpx)->(scpx) : "pow_c" +PM__intrinsic -(scpx)->(scpx) : "uminus_c" +PM__intrinsic ==(scpx,scpx)->(bool) : "eq_c" +PM__intrinsic /=(scpx,scpx)->(bool) : "ne_c" +PM__intrinsic re(scpx)->(sreal) : "real_c" +PM__intrinsic abs(scpx)->(scpx) : "abs_c" +PM__intrinsic acos(scpx)->(scpx) : "acos_c" +PM__intrinsic asin(scpx)->(scpx) : "asin_c" +PM__intrinsic atan(scpx)->(scpx) : "atan_c" +PM__intrinsic atan2(scpx,scpx)->(scpx) : "atan2_c" +PM__intrinsic cos(scpx)->(scpx) : "cos_c" +PM__intrinsic cosh(scpx)->(scpx) : "cosh_c" +PM__intrinsic exp(scpx)->(scpx) : "exp_c" +PM__intrinsic log(scpx)->(scpx) : "log_c" +PM__intrinsic sin(scpx)->(scpx) : "sin_c" +PM__intrinsic sinh(scpx)->(scpx) : "sinh_c" +PM__intrinsic sqrt(scpx)->(scpx) : "sqrt_c" +PM__intrinsic tan(scpx)->(scpx) : "tan_c" +PM__intrinsic tanh(scpx)->(scpx) : "tanh_c" +PM__intrinsic im(scpx)->(sreal) : "imag_c" +PM__intrinsic conj(scpx)->(scpx) : "conj_c" + +// cpx type +PM__intrinsic PM__assign_var(&cpx,cpx): "assign_dc" +PM__intrinsic +(cpx,cpx)->(cpx) : "add_dc" +PM__intrinsic -(cpx,cpx)->(cpx) : "sub_dc" +PM__intrinsic *(cpx,cpx)->(cpx) : "mult_dc" +PM__intrinsic /(cpx,cpx)->(cpx) : "divide_dc" +PM__intrinsic **(cpx,real)->(cpx) : "dpow_dc" +proc **(x:cpx,y:sreal)=x**real(y) +PM__intrinsic **(cpx,cpx)->(cpx) : "pow_dc" +PM__intrinsic -(cpx)->(cpx) : "uminus_dc" +PM__intrinsic ==(cpx,cpx)->(bool) : "eq_dc" +PM__intrinsic /=(cpx,cpx)->(bool) : "ne_dc" +PM__intrinsic re(cpx)->(real) : "real_dc" +PM__intrinsic abs(cpx)->(cpx) : "abs_dc" +PM__intrinsic acos(cpx)->(cpx) : "acos_dc" +PM__intrinsic asin(cpx)->(cpx) : "asin_dc" +PM__intrinsic atan(cpx)->(cpx) : "atan_dc" +PM__intrinsic atan2(cpx,cpx)->(cpx) : "atan2_dc" +PM__intrinsic cos(cpx)->(cpx) : "cos_dc" +PM__intrinsic cosh(cpx)->(cpx) : "cosh_dc" +PM__intrinsic exp(cpx)->(cpx) : "exp_dc" +PM__intrinsic log(cpx)->(cpx) : "log_dc" +PM__intrinsic sin(cpx)->(cpx) : "sin_dc" +PM__intrinsic sinh(cpx)->(cpx) : "sinh_dc" +PM__intrinsic sqrt(cpx)->(cpx) : "sqrt_dc" +PM__intrinsic tan(cpx)->(cpx) : "tan_dc" +PM__intrinsic tanh(cpx)->(cpx) : "tanh_dc" +PM__intrinsic im(cpx)->(real) : "imag_dc" +PM__intrinsic conj(cpx)->(cpx) : "conj_dc" + +// Cannot convert real to int (must use nint or trunc) +proc sint(x:any_real)=sint(0) :compile_error("Cannot convert real to integer") +proc int(x:any_real)=0 :compile_error("Cannot convert real to integer") +proc lint(x:any_real)=lint(0) :compile_error("Cannot convert real to integer") + +// Some numeric conversions not hard-coded +proc cpx(x:real_num)=cpx(real(x)) +proc scpx(x:real_num)=cpx(sreal(x)) +proc string(x:any_int)=string(int64(x)) +proc string(x:any_cpx)= string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x) +proc fmt(x:real_num,f:[int,int])=_fmt(x,f.1,f.2) +proc fmt(x:real_num,f:int)=_fmt(x,f,max(1,abs(f)-6)) +proc int(x:fix(int))=x + + +// Abstract numeric types +type any_int is sint,int,lint,int8,int16,int32,int64 +type any_real is sreal,real +type any_cpx is scpx,cpx +type int_num is any_int +type real_num is int_num, any_real +type cpx_num is real_num,any_cpx +type num is cpx_num + +// Numeric type conversion +proc convert(x:int_num,y:sint)=sint(x) +proc convert(x:int_num,y:int)=int(x) +proc convert(x:int_num,y:lint)=lint(x) +proc convert(x:int_num,y:int8)=int8(x) +proc convert(x:int_num,y:int16)=int16(x) +proc convert(x:int_num,y:int32)=int32(x) +proc convert(x:int_num,y:int64)=int64(x) +proc convert(x:int_num,y:sreal)=sreal(x) +proc convert(x:int_num,y:real)=real(x) +proc convert(x:real_num,y:cpx)=cpx(x) +proc convert(x:real_num,y:scpx)=scpx(x) + +proc as(x:int_num,y:)=sint(x) +proc as(x:int_num,y:)=int(x) +proc as(x:int_num,y:)=lint(x) +proc as(x:int_num,y:)=int8(x) +proc as(x:int_num,y:)=int16(x) +proc as(x:int_num,y:)=int32(x) +proc as(x:int_num,y:)=int64(x) +proc as(x:real_num,y:)=sreal(x) +proc as(x:real_num,y:)=real(x) +proc as(x:real_num,y:)=scpx(x) +proc as(x:real_num,y:)=cpx(x) + + +// Mixed arithmatic +type _to_sint is int +type _to_lint is sint,int +type _to_int8 is sint,int,lint +type _to_int16 is sint,int,lint,int8 +type _to_int32 is sint,int,lint,int8,int16 +type _to_int64 is sint,int,lint,int8,int16,int32 +type _to_real is any_int +type _to_sreal is any_int,real +type _to_cpx is real_num +type _to_scpx is real_num,cpx +proc balance(x:sint,y:sint)=x,y +proc balance(x:int,y:int)=x,y +proc balance(x:lint,y:lint)=x,y +proc balance(x:int8,y:int8)=x,y +proc balance(x:int16,y:int16)=x,y +proc balance(x:int32,y:int32)=x,y +proc balance(x:int64,y:int64)=x,y +proc balance(x:sreal,y:sreal)=x,y +proc balance(x:real,y:real)=x,y +proc balance(x:scpx,y:scpx)=x,y +proc balance(x:cpx,y:cpx)=x,y +proc balance(x:sint,y:_to_sint)=x,sint(y) +proc balance(x:lint,y:_to_lint)=x,lint(y) +proc balance(x:int8,y:_to_int8)=x,int8(y) +proc balance(x:int16,y:_to_int16)=x,int16(y) +proc balance(x:int32,y:_to_int32)=x,int32(y) +proc balance(x:int64,y:_to_int64)=x,int64(y) +proc balance(x:sreal,y:_to_sreal)=x,sreal(y) +proc balance(x:real,y:_to_real)=x,real(y) +proc balance(x:scpx,y:_to_scpx)=x,scpx(y) +proc balance(x:cpx,y:_to_cpx)=x,cpx(y) +proc balance(x:_to_sint,y:sint)=sint(x),y +proc balance(x:_to_lint,y:lint)=lint(x),y +proc balance(x:_to_int8,y:int8)=int8(x),y +proc balance(x:_to_int16,y:int16)=int16(x),y +proc balance(x:_to_int32,y:int32)=int32(x),y +proc balance(x:_to_int64,y:int64)=int64(x),y +proc balance(x:_to_sreal,y:sreal)=sreal(x),y +proc balance(x:_to_real,y:real)=real(x),y +proc balance(x:_to_scpx,y:scpx)=scpx(x),y +proc balance(x:_to_cpx,y:cpx)=cpx(x),y +proc div(x:any_int,y:any_int)=if(sz=>r,-1-r) where r=if(sz=>x,abs(x)-1)/if(sz=>y,abs(y))where sz=sign(x,y)==x +proc _divz(x:any_int,y:any_int)=z { + var z,_=balance(x,y) + if(sign(x,y)==x):z=x/y else: z=-1-(abs(x)-1)/abs(y) +} +proc mod(x:real_num,y:real_num)=xx mod yy where xx,yy=balance(x,y) +proc ==(x:num,y:num)=xx==yy where xx,yy=balance(x,y) +proc /=(x:num,y:num)=xx/=yy where xx,yy=balance(x,y) +proc >=(x:real_num,y:real_num)=xx>=yy where xx,yy=balance(x,y) +proc >(x:real_num,y:real_num)=xx>yy where xx,yy=balance(x,y) +proc +(x:num,y:num)=xx+yy where xx,yy=balance(x,y) +proc -(x:num,y:num)=xx-yy where xx,yy=balance(x,y) +proc *(x:num,y:num)=xx*yy where xx,yy=balance(x,y) +proc /(x:num,y:num)=xx/yy where xx,yy=balance(x,y) +proc **(x:num,y:num)=xx**yy where xx,yy=balance(x,y) +proc &(x:num,y:num)=xx&yy where xx,yy=balance(x,y) +proc |(x:num,y:num)=xx|yy where xx,yy=balance(x,y) +proc ~(x:num,y:num)=xx ~ yy where xx,yy=balance(x,y) +proc shift(x:num,y:num)=xx shift yy where xx,yy=balance(x,y) +proc max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y) +proc min(x:num,y:num)=min(xx,yy) where xx,yy=balance(x,y) + +// Indexed arithmetic +proc +'(x,y)=$+.(x,y) +proc -'(x,y)=$-.(x,y) +proc *'(x,y)=$*.(x,y) +proc /'(x,y)=$/.(x,y) +proc -'(x)=$-.(x) + +// bool type +PM__intrinsic PM__assign_var(&bool,bool): "assign_l" +PM__intrinsic string(bool)->(string) : "string_l" +PM__intrinsic and(bool,bool)->(bool) : "and" +PM__intrinsic or(bool,bool)->(bool) : "or" +PM__intrinsic not(bool)->(bool) : "not" +PM__intrinsic ==(bool,bool)->(bool) : "eq_l" +PM__intrinsic /=(bool,bool)->(bool) : "ne_l" + + +// val function having null effect +proc val(x)=x + + +// ******************************************** +// TUPLES +// ******************************************** + +// Tuple types + +type tuple1d(t1,r:1) is rec {PM__d1:t1,_r:r} +type tuple2d(t1,t2,r:2) is rec {PM__d1:t1,PM__d2:t2,_r:r} +type tuple3d(t1,t2,t3,r:3) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,_r:r} +type tuple4d(t1,t2,t3,t4,r:4) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,_r:r} +type tuple5d(t1,t2,t3,t4,t5,r:5) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,_r:r} +type tuple6d(t1,t2,t3,t4,t5,t6,r:6) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6,_r:r} +type tuple7d(t1,t2,t3,t4,t5,t6,t7,r:7) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6,PM__d7:t7,_r:r} + +type dimension_number is 1,2,3,4,5,6,7 +type tuple(t,r:dimension_number) +type tuple(t,r:1) is ...,tuple1d(t,r) +type tuple(t,r:2) is ...,tuple2d(t,t,r) +type tuple(t,r:3) is ...,tuple3d(t,t,t,r) +type tuple(t,r:4) is ...,tuple4d(t,t,t,t,r) +type tuple(t,r:5) is ...,tuple5d(t,t,t,t,t,r) +type tuple(t,r:6) is ...,tuple6d(t,t,t,t,t,t,r) +type tuple(t,r:7) is ...,tuple7d(t,t,t,t,t,t,t,r) + +proc tuple(x)=rec tuple1d { + PM__d1=x,_r=1 +} +proc tuple(x,y)=rec tuple2d { + PM__d1=x,PM__d2=y,_r=2 +} +proc tuple(x,y,z)=rec tuple3d { + PM__d1=x,PM__d2=y,PM__d3=z,_r=3 +} +proc tuple(x,y,z,t)=rec tuple4d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,_r=4 +} +proc tuple(x,y,z,t,u)=rec tuple5d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,_r=5 +} +proc tuple(x,y,z,t,u,v)=rec tuple6d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,_r=6 +} +proc tuple(x,y,z,t,u,v,w)=rec tuple7d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,PM__d7=w,_r=7 +} + +proc dim(t:tuple1d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple2d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple3d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple4d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple5d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple6d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple7d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple2d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple3d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple4d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple5d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple6d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple7d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple3d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple4d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple5d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple6d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple7d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple4d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple5d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple6d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple7d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple5d,n:literal(5) or [literal(5)])=t.5 +proc dim(t:tuple6d,n:literal(5) or [literal(5)])=t.5 +proc dim(t:tuple7d,n:literal(5) or [literal(5)])=t.5 +proc dim(t:tuple6d,n:literal(6) or [literal(6)])=t.6 +proc dim(t:tuple7d,n:literal(6) or [literal(6)])=t.6 +proc dim(t:tuple7d,n:literal(7) or [literal(7)])=t.7 + +proc indices(x:tuple1d)=[1] +proc indices(x:tuple2d)=[1,2] +proc indices(x:tuple3d)=[1,2,3] +proc indices(x:tuple4d)=[1,2,3,4] +proc indices(x:tuple5d)=[1,2,3,4,5] +proc indices(x:tuple6d)=[1,2,3,4,5,6] +proc indices(x:tuple7d)=[1,2,3,4,5,6,7] + +proc full_rank(x:tuple1d)=1 +proc full_rank(x:tuple2d)=2 +proc full_rank(x:tuple3d)=3 +proc full_rank(x:tuple4d)=4 +proc full_rank(x:tuple5d)=5 +proc full_rank(x:tuple6d)=6 +proc full_rank(x:tuple7d)=7 +proc rank(x:tuple)=full_rank(x) + +proc reduce(p:proc,x:tuple1d)=x.1 +proc reduce(p:proc,x:tuple2d)=p.(x.2,x.1) +proc reduce(p:proc,x:tuple3d)=p.(p.(x.3,x.2),x.1) +proc reduce(p:proc,x:tuple4d)=p.(p.(p.(x.4,x.3),x.2),x.1) +proc reduce(p:proc,x:tuple5d)=p.(p.(p.(p.(x.5,x.4),x.3),x.2),x.1) +proc reduce(p:proc,x:tuple6d)=p.(p.(p.(p.(p.(x.6,x.5),x.4),x.3),x.2),x.1) +proc reduce(p:proc,x:tuple7d)=p.(p.(p.(p.(p.(p.(x.7,x.6),x.5),x.4),x.3),x.2),x.1) + +proc map(p:proc,x:tuple1d)=[p.(x.1)] +proc map(p:proc,x:tuple2d)=[p.(x.1),p.(x.2)] +proc map(p:proc,x:tuple3d)=[p.(x.1),p.(x.2),p.(x.3)] +proc map(p:proc,x:tuple4d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4)] +proc map(p:proc,x:tuple5d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5)] +proc map(p:proc,x:tuple6d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6)] +proc map(p:proc,x:tuple7d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6),p.(x.7)] +proc map(p:proc,x:tuple,y:tuple)=compile_error("Number of dimensions does not match") +proc map(p:proc,x:tuple1d,y:tuple1d)=[p.(x.1,y.1)] +proc map(p:proc,x:tuple2d,y:tuple2d)=[p.(x.1,y.1),p.(x.2,y.2)] +proc map(p:proc,x:tuple3d,y:tuple3d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3)] +proc map(p:proc,x:tuple4d,y:tuple4d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4)] +proc map(p:proc,x:tuple5d,y:tuple5d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5)] +proc map(p:proc,x:tuple6d,y:tuple6d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6)] +proc map(p:proc,x:tuple7d,y:tuple7d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6),p.(x.7,y.7)] +proc map(p:proc,x:tuple,y:tuple,z:tuple)=error_type() :compile_error("Number of dimensions does not match") +proc map(p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=[p.(x.1,y.1,z.1)] +proc map(p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2)] +proc map(p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3)] +proc map(p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4)] +proc map(p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5)] +proc map(p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6)] +proc map(p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6),p.(x.7,y.7,z.7)] + +proc map(p:proc,w:tuple,x:tuple,y:tuple,z:tuple)=error_type() :compile_error("Number of dimensions does not match") +proc map(p:proc,w:tuple1d,x:tuple1d,y:tuple1d,z:tuple1d)=[p.(w.1,x.1,y.1,z.1)] +proc map(p:proc,w:tuple2d,x:tuple2d,y:tuple2d,z:tuple2d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2)] +proc map(p:proc,w:tuple3d,x:tuple3d,y:tuple3d,z:tuple3d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3)] +proc map(p:proc,w:tuple4d,x:tuple4d,y:tuple4d,z:tuple4d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4)] +proc map(p:proc,w:tuple5d,x:tuple5d,y:tuple5d,z:tuple5d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5)] +proc map(p:proc,w:tuple6d,x:tuple6d,y:tuple6d,z:tuple6d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6)] +proc map(p:proc,w:tuple7d,x:tuple7d,y:tuple7d,z:tuple7d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6),p.(w.7,x.7,y.7,z.7)] + +proc map(p:proc,x:tuple1d,y:tuple1d)=[u1],[v1]where u1,v1=p.(x.1,y.1) +proc map(p:proc,x:tuple2d,y:tuple2d)=[u1,u2],[v1,v2]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2) +proc map(p:proc,x:tuple3d,y:tuple3d)=[u1,u2,u3],[v1,v2,v3]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3) +proc map(p:proc,x:tuple4d,y:tuple4d)=[u1,u2,u3,u4],[v1,v2,v3,v4]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4) +proc map(p:proc,x:tuple5d,y:tuple5d)=[u1,u2,u3,u4,u5],[v1,v2,v3,v4,v5]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5) +proc map(p:proc,x:tuple6d,y:tuple6d)=[u1,u2,u3,u4,u5,u6],[v1,v2,v3,v4,v5,v6]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),u6,v6=p.(x.6,y.6) +proc map(p:proc,x:tuple7d,y:tuple7d)=[u1,u2,u3,u4,u5,u6,u7],[v1,v2,v3,v4,v5,v6,v7]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),u6,v6=p.(x.6,y.6),u7,v7=p.(x.7,y.7) + +proc map_const(p:proc,x:tuple1d,y)=[p.(x.1,y)] +proc map_const(p:proc,x:tuple2d,y)=[p.(x.1,y),p.(x.2,y)] +proc map_const(p:proc,x:tuple3d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y)] +proc map_const(p:proc,x:tuple4d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y)] +proc map_const(p:proc,x:tuple5d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y)] +proc map_const(p:proc,x:tuple6d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y),p.(x.6,y)] +proc map_const(p:proc,x:tuple7d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y),p.(x.6,y),p.(x.7,y)] + +proc map_reduce(q:proc,p:proc,x:tuple1d)=q.(x.1) +proc map_reduce(q:proc,p:proc,x:tuple2d)=p.(q.(x.2),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d)=p.(p.(q.(x.3),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d)=p.(p.(p.(q.(x.4),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d)=p.(p.(p.(p.(q.(x.5),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d)=p.(p.(p.(p.(p.(q.(x.6),q.(x.5)),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7),q.(x.6)),q.(x.5)),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) + +proc map_reduce(q:proc,p:proc,x:tuple,y:tuple)=error_type() :compile_error("Number of dimensions does not match") +proc map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d)=q.(x.1,y.1) +proc map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d)=p.(q.(x.2,y.2),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d)=p.(p.(q.(x.3,y.3),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d)=p.(p.(p.(q.(x.4,y.4),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d)=p.(p.(p.(p.(q.(x.5,y.5),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d)=p.(p.(p.(p.(p.(q.(x.6,y.6),q.(x.5,y.5)),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7,y.7),q.(x.6,y.6)),q.(x.5,y.5)),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) + +proc map_reduce(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type() :compile_error("Number of dimensions does not match") +proc map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=q.(x.1,y.1,z.1) +proc map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=p.(q.(x.2,y.2,z.2),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=p.(p.(q.(x.3,y.3,z.3),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=p.(p.(p.(q.(x.4,y.4,z.4),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=p.(p.(p.(p.(q.(x.5,y.5,z.5),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=p.(p.(p.(p.(p.(q.(x.6,y.6,z.6),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7,y.7,z.7),q.(x.6,y.6,z.6)),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) + +proc apply(p:proc,x:tuple1d)=p.(x.1) +proc apply(p:proc,x:tuple2d)=p.(x.1,x.2) +proc apply(p:proc,x:tuple3d)=p.(x.1,x.2,x.3) +proc apply(p:proc,x:tuple4d)=p.(x.1,x.2,x.3,x.4) +proc apply(p:proc,x:tuple5d)=p.(x.1,x.2,x.3,x.4,x.5) +proc apply(p:proc,x:tuple6d)=p.(x.1,x.2,x.3,x.4,x.5,x.6) +proc apply(p:proc,x:tuple7d)=p.(x.1,x.2,x.3,x.4,x.5,x.6,x.7) + +proc map_apply(q:proc,p:proc,x:tuple1d)=p.(q.(x.1)) +proc map_apply(q:proc,p:proc,x:tuple2d)=p.(q.(x.1),q.(x.2)) +proc map_apply(q:proc,p:proc,x:tuple3d)=p.(q.(x.1),q.(x.2),q.(x.3)) +proc map_apply(q:proc,p:proc,x:tuple4d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4)) +proc map_apply(q:proc,p:proc,x:tuple5d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5)) +proc map_apply(q:proc,p:proc,x:tuple6d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5),q.(x.6)) +proc map_apply(q:proc,p:proc,x:tuple7d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5),q.(x.6),q.(x.7)) + +proc map_apply(q:proc,p:proc,x:tuple,y:tuple)=error_type():compile_error("Number of dimensions does not match") +proc map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d)=p.(q.(x.1,y.1)) +proc map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d)=p.(q.(x.1,y.1),q.(x.2,y.2)) +proc map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3)) +proc map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4)) +proc map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5)) +proc map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5),q.(x.6,y.6)) +proc map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5),q.(x.6,y.6),q.(x.7,y.7)) + +proc map_apply(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type() :compile_error("Number of dimensions does not match") +proc map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=p.(q.(x.1,y.1,z.1)) +proc map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2)) +proc map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3)) +proc map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4)) +proc map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5)) +proc map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5),q.(x.6,y.6,z.6)) +proc map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5),q.(x.6,y.6,z.6),q.(x.7,y.7,z.7)) + +proc scan(p:proc,x:tuple1d)=x.1 +proc scan(p:proc,x:tuple2d)=[x.1,p.(x.1,x.2)] +proc scan(p:proc,x:tuple3d)=[x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple4d)=[x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple5d)=[x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple6d)=[x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple7d)=[x.1,x2,x3,x4,x5,x6,p.(x6,x.7)] where x6=p.(x5,x.6) where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) + +proc pre_scan(p:proc,x:tuple1d,x0)=x0 +proc pre_scan(p:proc,x:tuple2d,x0)=[x0,x.1] +proc pre_scan(p:proc,x:tuple3d,x0)=[x0,x.1,p.(x.1,x.2)] +proc pre_scan(p:proc,x:tuple4d,x0)=[x0,x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple5d,x0)=[x0,x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple6d,x0)=[x0,x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple7d,x0)=[x0,x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) + +type empty_head is unique{empty_head} + +proc head(x:null)=empty_head +proc head(x:tuple)=x.1 + +proc tail(x:null)=null +proc tail(x:tuple1d)=null +proc tail(x:tuple2d)=[x.2] +proc tail(x:tuple3d)=[x.2,x.3] +proc tail(x:tuple4d)=[x.2,x.3,x.4] +proc tail(x:tuple5d)=[x.2,x.3,x.4,x.5] +proc tail(x:tuple6d)=[x.2,x.3,x.4,x.5,x.6] +proc tail(x:tuple7d)=[x.2,x.3,x.4,x.5,x.6,x.7] + +proc prepend(y,x:null)=[y] +proc prepend(y,x:tuple1d)=[y,x.1] +proc prepend(y,x:tuple2d)=[y,x.1,x.2] +proc prepend(y,x:tuple3d)=[y,x.1,x.2,x.3] +proc prepend(y,x:tuple4d)=[y,x.1,x.2,x.3,x.4] +proc prepend(y,x:tuple5d)=[y,x.1,x.2,x.3,x.4,x.5] +proc prepend(y,x:tuple6d)=[y,x.1,x.2,x.4,x.4,x.5,x.6] +proc prepend(y,x:tuple7d)=error_type() :compile_error("Cannot add dimension to 7d tuple") + +proc append(x:null,y)=[y] +proc append(x:tuple1d,y)=[x.1,y] +proc append(x:tuple2d,y)=[x.1,x.2,y] +proc append(x:tuple3d,y)=[x.1,x.2,x.3,y] +proc append(x:tuple4d,y)=[x.1,x.2,x.3,x.4,y] +proc append(x:tuple5d,y)=[x.1,x.2,x.3,x.4,x.5,y] +proc append(x:tuple6d,y)=[x.1,x.2,x.4,x.4,x.5,x.6,y] +proc append(y,x:tuple7d)=error_type() :compile_error( "Cannot add dimension to 7d tuple") + +proc elems(x:tuple1d)=x.1 +proc elems(x:tuple2d)=x.1,x.2 +proc elems(x:tuple3d)=x.1,x.2,x,3 +proc elems(x:tuple4d)=x.1,x.2,x.3,x.4 +proc elems(x:tuple5d)=x.1,x.2,x.3,x.4,x.5 +proc elems(x:tuple6d)=x.1,x.2,x.3,x.4,x.5,x.6 +proc elems(x:tuple7d)=x.1,x.2,x.3,x.4,x.5,x.6,x.7 + +proc replace(x:tuple1d,y:literal(1),z)=[z] +proc replace(x:tuple2d,y:literal(1),z)=[z,x.2] +proc replace(x:tuple3d,y:literal(1),z)=[z,x.2,x.3] +proc replace(x:tuple4d,y:literal(1),z)=[z,x.2,x.3,x.4] +proc replace(x:tuple5d,y:literal(1),z)=[z,x.2,x.3,x.4,x.5] +proc replace(x:tuple6d,y:literal(1),z)=[z,x.2,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:literal(1),z)=[z,x.2,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple2d,y:literal(2),z)=[x.1,z] +proc replace(x:tuple3d,y:literal(2),z)=[x.1,z,x.3] +proc replace(x:tuple4d,y:literal(2),z)=[x.1,z,x.3,x.4] +proc replace(x:tuple5d,y:literal(2),z)=[x.1,z,x.3,x.4,x.5] +proc replace(x:tuple6d,y:literal(2),z)=[x.1,z,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:literal(2),z)=[x.1,z,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple3d,y:literal(3),z)=[x.1,x.2,z] +proc replace(x:tuple4d,y:literal(3),z)=[x.1,x.2,z,x.4] +proc replace(x:tuple5d,y:literal(3),z)=[x.1,x.2,z,x.4,x.5] +proc replace(x:tuple6d,y:literal(3),z)=[x.1,x.2,z,x.4,x.5,x.6] +proc replace(x:tuple7d,y:literal(3),z)=[x.1,x.2,z,x.4,x.5,x.6,x.7] +proc replace(x:tuple4d,y:literal(4),z)=[x.1,x.2,x.3,z] +proc replace(x:tuple5d,y:literal(4),z)=[x.1,x.2,x.3,z,x.5] +proc replace(x:tuple6d,y:literal(4),z)=[x.1,x.2,x.3,z,x.5,x.6] +proc replace(x:tuple7d,y:literal(4),z)=[x.1,x.2,x.3,z,x.5,x.6,x.7] +proc replace(x:tuple5d,y:literal(5),z)=[x.1,x.2,x.3,x.4,z] +proc replace(x:tuple6d,y:literal(5),z)=[x.1,x.2,x.3,x.4,z,x.6] +proc replace(x:tuple7d,y:literal(5),z)=[x.1,x.2,x.3,x.4,z,x.6,x.7] +proc replace(x:tuple6d,y:literal(6),z)=[x.1,x.2,x.3,x.4,x.5,z] +proc replace(x:tuple7d,y:literal(6),z)=[x.1,x.2,x.3,x.4,x.5,z,x.7] +proc replace(x:tuple7d,y:literal(7),z)=[x.1,x.2,x.3,x.4,x.5,x.6,z] + +proc spread(x,y:tuple1d or literal(1))=[x] +proc spread(x,y:tuple2d or literal(2))=[x,x] +proc spread(x,y:tuple3d or literal(3))=[x,x,x] +proc spread(x,y:tuple4d or literal(4))=[x,x,x,x] +proc spread(x,y:tuple5d or literal(5))=[x,x,x,x,x] +proc spread(x,y:tuple6d or literal(6))=[x,x,x,x,x,x] +proc spread(x,y:tuple7d or literal(7))=[x,x,x,x,x,x,x] + +proc +(x:tuple(num),y:tuple(num))=map($+,x,y) + +proc -(x:tuple(num),y:tuple(num))=map($-,x,y) +proc *(x:tuple(num),y:tuple(num))=map($*,x,y) +proc /(x:tuple(num),y:tuple(num))=map($/,x,y) +proc **(x:tuple(num),y:tuple(num))=map($**,x,y) +proc mod(x:tuple(num),y:tuple(num))=map($mod,x,y) +proc +(x:tuple(num),y:num)=map_const($+,x,y) +proc -(x:tuple(num),y:num)=map_const($-,x,y) +proc *(x:tuple(num),y:num)=map_const($*,x,y) +proc /(x:tuple(num),y:num)=map_const($/,x,y) +proc **(x:tuple(num),y:num)=map_const($**,x,y) +proc mod(x:tuple(num),y:num)=map_const($mod,x,y) +proc max(x:tuple(real_num),y:tuple(real_num))=map($max,x,y) +proc min(x:tuple(real_num),y:tuple(real_num))=map($min,x,y) +proc max(x:tuple(real_num))=reduce($max,x) +proc min(x:tuple(real_num))=reduce($min,x) +proc sum(x:tuple(num))=reduce($+,x) +proc prod(x:tuple(num))=reduce($*,x) +proc sint(x:tuple(num))=map($sint,x) +proc int(x:tuple(num))=map($int,x) +proc sreal(x:tuple(num))=map($sreal,x) +proc real(x:tuple(num))=map($real,x) + +proc string(x:tuple1d)="[ "++x.1++" ]" +proc string(x:tuple2d)="[ "++x.1++", "++x.2++" ]" +proc string(x:tuple3d)="[ "++x.1++", "++x.2++", "++x.3++" ]" +proc string(x:tuple4d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++" ]" +proc string(x:tuple5d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++" ]" +proc string(x:tuple6d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++" ]" +proc string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++", "++x.7++" ]" + +// ***************************************************** +// RANGES AND SEQUENCES +// ***************************************************** + +// Partial ranges and sequences for slicing +type underscore is unique{PM__underscore} +type _subscript is any_int,range(any_int),seq(any_int,any_int),underscore,range_below(any_int),range_above(any_int),seq_above(any_int,any_int), seq_below(any_int,any_int), seq_stride(any_int) +type subscript is _subscript or tuple(_subscript) +type extent(ndim:dimension_number) is tuple(range(int),ndim) +proc size(x:extent)=map_reduce($size,$*,x) + +proc complete(x:extent,y:subscript)=_complete(x,y) check "Subscript "++y++" is out of bounds "++x=>y in x +proc _complete(x:tuple1d,y:_subscript)=_complete(x.1,y) +proc _complete(x:range(int),y:any_int)=int(y) +proc _complete(x:range(int),y:range(any_int))=int(y) +proc _complete(x:range(int),y:seq(any_int,any_int))=int(y) +proc _complete(x:range(int),y:underscore)=x +proc _complete(x:range(int),y:range_below(any_int))=low(x)..int(y._t) +proc _complete(x:range(int),y:range_above(any_int))=int(y._t)..high(x) +proc _complete(x:range(int),y:seq_below(any_int))=low(x)..int(y._t) by int(y._st) +proc _complete(x:range(int),y:seq_above(any_int))=int(y._t)..high(x) by int(y._st) +proc _complete(x:range(int),y:seq_step(any_int))=x by int(y._st) +proc _complete(x,y)=map($_complete,x,y) check "Subscript has incorrect rank"=>rank(x)==rank(y) + +type range_below(x:range_base) is rec {_t:x} +type range_above(x:range_base) is rec {_t:x} +type seq_below(x:range_base,s:step_base) is rec {_t:x,_st:step_base} +type seq_above(x:range_base,s:step_base) is rec {_t:x,_st:step_base} +type seq_step(x:step_base) is rec {_st:step_base} +proc ..(x:underscore,y:range_base)=rec range_below{_t=x} +proc ..(x:range_base,y:underscore)=rec range_above{_t=x} +proc by(x:range_below,y:step_base)=rec seq_below{_t=x,_st=y} +proc by(x:range_above,y:step_base)=rec seq_above{_t=x,_st=y} +proc by(x:underscore,y:step_base)=rec seq_step{_st=y} +proc string(x:range_below)="_.."++x._t +proc string(x:range_above)=x._t++".._" +proc string(x:seq_below)="_.."++x._t++" by "++x._st +proc string(x:seq_above)=x._t++".._ by "++x._st +proc string(x:seq_step)="_ by "++x._st +proc low(x:range_below or seq_below or seq_step)=_ +proc high(x:range_above or seq_above or seq_step)=_ +proc step(x:range_above or range_below)=literal(1) +proc low(x:range_above or seq_above)=x._t +proc high(x:range_below or seq_below)=x._t +proc step(x:seq_above or seq_below or seq_step)=x._st + +// Not in operator +proc notin(x,y)=not(x in y) + +// not inc operator +proc notinc(x,y)=not(x inc y) + +// Treat null as empty sequence in some cases +proc in(x,y:null)=false +proc in(x:null,y:null)=true + +// Range base type (might later expand to interface) +type range_base is real_num +type step_base is real_num + +// Range types +type range(t:range_base,hi:range_base) is rec {_lo:t,_hi:hi,_n:int} +proc ..(x:range_base,y:range_base)=rec range { + _lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) +proc ..(x:literal(int),y:literal(int))=literal(rec range{_lo=xx,_hi=yy,_n=max(0,yy-xx)+1}) where xx=fix(x),yy=fix(y) +proc low(x:range)=x._lo +proc high(x:range)=x._hi +proc step(x:range)=convert(1,x._lo) +proc width(x:range)=literal(1) +proc norm(x:range)=x +proc #'(x:range(int))=[0..x._n-1] +proc dims(x:range(int))=[x._n] +proc size(x:range(int))=x._n +proc +(x:range,y:range_base)=rec range { + _lo=x._lo+y,_hi=x._hi+y,_n=x._n +} +proc -(x:range,y:range_base)=rec range { + _lo=x._lo-y,_hi=x._hi-y,_n=x._n +} +proc _arb(x:range)=low(x) +proc in(x:range_base,y:range())=x>=y._lo and x<=y._hi +proc convert(x:range,y:range_base)=rec range { + _lo=convert(x._lo,y),_hi=convert(x._hi,y),_n=x._n +} +proc sint(x:range)=rec range { + _lo=sint(x._lo),_hi=sint(x._hi),_n=x._n +} +proc int(x:range)=rec range { + _lo=int(x._lo),_hi=int(x._hi),_n=x._n +} +proc sreal(x:range)=rec range { + _lo=sreal(x._lo),_hi=sreal(x._hi) +} +proc real(x:range)=rec range { + _lo=real(x._lo),_hi=real(x._hi),_n=x._n +} +proc inc(x:range,y:seq())= low(y)>=x._lo and high(y)<=x._hi +proc element(x:range(any_int),y:int)=x._lo+convert(y,x._lo) +proc element(x:range(any_int),y:[int])=x._lo+convert(y.1,x._lo) +proc element(x:range(any_int),y:range(int))=element(x,y._lo)..element(x,y._hi) +proc element(x:range(any_int),y:seq(int))=element(x,y._lo)..element(x,y._hi) by y._st +proc element(x:range(any_int),y:null)=x +proc element(x:range(any_int),y:any_seq)=y+x._lo +proc #'(y:range(any_int),x:int)=int(x-y._lo) +proc #'(y:range(any_int),x:range(int))=int(x._lo-y._lo)..int(x._hi-y._lo) +proc #'(y:range(any_int),x:seq(int))=_intseq(int(x._lo-y._lo),int(x._hi-y._lo), x._st) +proc #'(y:range(any_int),x:range_below(int))=0..int(x._t-y._lo) +proc #'(y:range(any_int),x:range_above(int))=int(x._t-y._lo)..size(y)-1 +proc #'(y:range(any_int),x:seq_below(int))=_intseq(0,int(x._t-y._lo),x._st) +proc #'(y:range(any_int),x:seq_above(int))=_intseq(int(x._t-y._lo),size(y)-1,int(x._st)) +proc #'(y:range(any_int),x:seq_step(int))=_intseq(0,size(y),int(x._st)) +proc #'(y:range(any_int),x:null)=0..size(y) +proc intersect(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)..min(y._hi,x._hi) +proc overlap(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)-x._lo..min(y._hi,x._hi)-x._lo +proc expand(x:range,y:range)=x._lo+y._lo..x._hi+y._hi +proc contract(x:range,y:range)=x._lo-y._lo..x._hi-y._hi +proc empty(x:range)=rec range { + _lo=x._hi,_hi=x._lo,_n=0 +} +proc string(x:range)=string(x._lo)++".."++(x._hi) + +// Sequence (strided range) types +type seq(t:range_base,s:step_base) is rec {_lo:t,_hi:t,_st:s,_n:int} +proc _seq(lo,hi,st)=rec seq { +_lo=lo,_hi=lo+(n-1)*st,_st=st,_n=n}check "Zero step size in strided range"=>st/=0 where n=max(0,1+_rdiv(int((hi-lo)),int(st))) +proc by(x:range(int),y:range_base)=_seq(lo,hi,st) where hi=convert(x._hi,lo) where lo,st=balance(x._lo,y) +proc by(x:seq,y:range_base)=_seq(lo,hi,st) where lo=convert(x._lo,st),hi=convert(x._hi,st) where st=x._st*y +proc _intseq(x:int,y:int,st:int)= rec seq { +_lo=x,_hi=x+n*s,_st=s,_n=n} where s=if(x>y=>-abs(st),abs(st)) where n=abs((y-x)/st) +proc low(x:seq)=x._lo +proc high(x:seq)=x._hi +proc step(x:seq)=x._st +proc size(x:seq)=x._n +proc width(x:seq)=literal(1) +proc norm(x:seq)=min(lo,hi)..max(lo,hi) by abs(x._st)where hi=lo+(x._n-1)*x._st where lo=x._lo +proc align(x:seq)=literal(0) +proc #'(x:seq)=[0..x._n-1] +proc dims(x:seq)=[x._n] +proc +(x:seq,y:range_base)=rec seq { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_n=x._n +} +proc -(x:seq,y:range_base)=rec seq { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_n=x._n +} +proc _arb(x:seq)=x._lo +proc convert(x:seq,y:range_base)=rec seq { + _lo=convert(x._lo,y),_hi=convert(x._hi,y),_st=convert(x._st,y),_n=x._n +} +proc sint(x:seq)=rec seq { + _lo=sint(x._lo),_hi=sint(x._hi),_st=sint(x._st),_n=x._n +} +proc int(x:seq)=rec seq { + _lo=int(x._lo),_hi=int(x._hi),_st=int(x._st),_n=x._n +} +proc sreal(x:seq)=rec seq { + _lo=sreal(x._lo),_hi=sreal(x._hi),_st=sreal(x._st),_n=x._n +} +proc real(x:seq)=rec seq { + _lo=real(x._lo),_hi=real(x._hi),_st=real(x._st),_n=x._n +} +proc in(x:int,y:seq(int))=y._lo<=x and x<=y._hi and (x-y._lo) mod y._st==0 +proc inc(x:seq(int),y:seq(int))=y._lo in x and y._hi in x and (y._n==1 or y._lo+y._st in x) +proc inc(x:seq(int),y:range(int))=x inc low(y)..high(y) by 1 +proc #'(y:seq,x:range_base)=int((x-y._lo)/y._st) +proc #'(y:seq,x:range)=y#x._lo..y#x._hi +proc #'(y:seq,x:seq)=_intseq(lo,hi,int(x._st)) where lo=y#x._lo,hi=y#x._hi +proc #'(y:seq,x:range_below)=0..y#x._t +proc #'(y:seq,x:range_above)=y#x._t..size(y)-1 +proc #'(y:seq,x:seq_below)=_intseq(0,y#x._t,int((x._st+y._st/2)/y._st)) +proc #'(y:seq,x:seq_above)=_intseq(y#x._t,size(y)-1,int((x._st+y._st/2)/y._st)) +proc #'(y:seq,x:seq_step)=_intseq(0,size(y),int((x._st+y._st/2)/y._st)) +proc #'(y:seq,x:null)=0..size(y)-1 +proc string(x:seq)=x._lo++".."++x._hi++" by "++x._st +proc element(x:seq,y:int)=x._lo+convert(y,x._lo)*x._st +proc element(x:seq,y:range(int))=_seq(element(x,y._lo),element(x,y._hi),x._st) +proc element(x:seq,y:seq(int))=_seq(element(x,y._lo),element(x,y._hi),convert(st*y._st,st)) where st=x._st +proc element(x:seq,y:null)=x +proc overlap(x:seq(any_int),y:range(any_int))= max(0,(y._lo-x._lo+x._st-1)/x._st)..min(x._n,(y._hi-x._lo)/x._st) +proc overlap(x:range(any_int),y:seq(any_int))=max((-d+y._st-1)/y._st*y._st+d,d)..min(x._n,y._hi-x._lo) by y._st where d=y._lo-x._lo +proc intersect(x:seq(any_int),y:range(any_int))=x._lo+max(convert(0,n1),n1)*x._st..x._lo+min(convert(x._n,n2),n2)*x._st by x._st where n1=(y._lo-x._lo+x._st-1)/x._st,n2=(y._hi-x._lo)/x._st +proc intersect(x:range(any_int),y:seq(any_int))=intersect(y,x) +PM__intrinsic _intersect_seq(int,int,int,int,int,int,int,int)->(int,int,int,int) : "intersect_seq" +proc intersect(x:seq(any_int),y:seq(any_int))=rec seq { +_lo=lo,_hi=hi,_st=st,_n=n}where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),int(y._lo),int(y._hi),int(y._st),int(y._n)) +proc overlap(x:seq(any_int),y:seq(any_int))=rec seq { +_lo=(lo-x._lo)/x._st,_hi=(hi-x._lo)/x._st,_st=if(sst/=0=>sst,1),_n=n} where sst=st/x._st where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n), int(y._lo),int(y._hi),int(y._st),int(y._n)) +proc empty(x:seq(any_int))=rec seq { + _lo=x._hi,_hi=x._lo,_st=x._st,_n=0 +} + +// Block sequence +type block_seq is rec { _lo:int,_hi:int,_st:int,_b:int,_n:int,_align:int} +proc block_seq(lo:int,hi:int,st:int,b:int,align:int){ + test "Block sequence width must be non-negative: "++b=>b>=0 + test "Block sequence width must be less than step: "++b++">="++st=>b<=st + test "Block sequence alignment must be less that width: "++align++">="++b=>align1..0,x._lo..x._lo-x._align+x._b-1) +proc last_block(x:block_seq)=low..min(low+x._b,x._hi) where low=x._lo-x._align+nb*x._st where nb=(x._hi-x._lo+x._align+x._st-x._b+1)/x._st +proc middle_blocks(x:block_seq)=rec block_seq { +_lo=low,_hi=low+nb*x._st-1,_st=x._st,_b=x._b,_n=nb*x._b,_align=0}where nb=(x._hi-low+x._st-x._b+1)/x._st where low=if(x._align==0=>x._lo,x._lo-x._align+x._st) +proc string(x:block_seq)=x._lo++".."++x._hi++" by "++x._st++" width "++x._b++" align "++x._align +proc low(x:block_seq)=x._lo +proc high(x:block_seq)=x._hi +proc step(x:block_seq)=x._st +proc width(x:block_seq)=x._b +proc norm(x:block_seq)=x +proc align(x:block_seq)=x._align +proc #'(x:block_seq)=[0..x._n-1] +proc dims(x:block_seq)=x._n +proc size(x:block_seq)=x._n +proc +(x:block_seq,y:int)=rec block_seq { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc -(x:block_seq,y:int)=rec block_seq { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc _arb(x:block_seq)=x._lo +proc in(x:int,y:block_seq)=x>=y._lo and x<=y._hi and (x-y._lo+y._align) mod y._st=x._b:lo=nblo+x._st + if hi-nbhi>=x._b:hi=nbhi+x._b-1 + let align=base-(base/x._st)*x._st where base=lo-oldbase + return block_seq(lo,hi,x._st,x._b,align) +} + +proc intersect(x:range(any_int),y:block_seq)=intersect(y,x) +proc overlap(x:range(any_int),y:block_seq) { + let z=intersect(y,x) + return block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) +} +proc overlap(x:block_seq,y:range(any_int)) { + let z=intersect(x,y) + return start..start+size(z)-1 where start=z#z._lo +} +proc overlap(x:block_seq,y:range(any_int)) { + let z=intersect(x,y) + return start..start+size(z)-1, block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) where start=z#z._lo +} +proc overlap(x:range(any_int),y:block_seq)=xx,yy where yy,xx=overlap(y,x) +proc empty(x:block_seq)=block_seq(1,0,1,1,0) + +/* +// Mapped sequence +type map_seq(t:array(int)) is rec {array:t} +proc map_seq(x:any_seq){ + var a=array(0,#x) + forall i in a,j in x:i=j + return rec map_seq{ + array=a + } +} +proc map_seq(x:array(int,mshape1d))=rec map_seq { +array=x} check "Array for ""map_seq"" must be strictly increasing or stricly decreasing"=>_mono(x) +proc _mono(x) { + /* + xs=#x + var ok=true + if x[low(xs.1)]x[i-1]:sync ok=false + } + return ok +*/ +} +proc map_seq(x:map_seq)=x +proc #'(x:map_seq)=#'(x.array) +proc dims(x:map_seq)=size(x.array) +proc size(x:map_seq)=size(x.array) +proc +(x:map_seq,y:range_base)=rec map_seq{ + array=x.array+y +} +proc -(x:map_seq,y:range_base)=rec map_seq{ + array=x.array-y +} +proc _arb(x:map_seq)=_arb(x.array) +proc element(x:map_seq,y:int)=element(x.array,y) +PM__intrinsic _intersect_aseq(&any,any,any,any,any,&any): "intersect_aseq" +PM__intrinsic _overlap_aseq(&any,any,any,any,any,&any): "intersect_aseq"(1) +PM__intrinsic _overlap_aseq2(&any,any,any,any,any,&any,&any): "intersect_aseq"(2) +PM__intrinsic _expand_aseq(&any,any,any,&any,any,any): "expand_aseq" +PM__intrinsic _intersect_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq" +PM__intrinsic _overlap_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(1) +PM__intrinsic _overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(2) +PM__intrinsic _includes_aseq(any,any,any,any)->(bool) : "includes_aseq" +PM__intrinsic _index_aseq(any,any,any)->(int) : "index_aseq" +PM__intrinsic _in_aseq(any,any,any)->(bool) : "in_aseq" +proc intersect(x:block_seq,y:block_seq)=intersect(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=overlap(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=v,w where v,w=overlap(map_seq(x),map_seq(y)) +proc intersect(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _intersect_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=rec map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=rec map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var b=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq2(&n,x.array,size(x.array),y.array,size(y.array),&a,&b) + ns=[0..n-1] + v=rec map_seq { + array=a[ns] + } + w=rec map_seq { + array=b[ns] + } + return v,w +} +proc overlap(x:seq,y:seq)=overlap(x,y),overlap(y,x) +proc expand(t:map_seq,i:range(any_int)) { + var a=array(0,[0..max(1,size(t)*max(1,size(i))-1)]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i)) + v=rec map_seq { + array=a[0..m-1] + } + return v +} +proc inc(x:map_seq,y:map_seq)=_includes_aseq(x.array,size(x.array),y.array,size(y.array)) +proc inc(x:map_seq,y:seq or block_seq)=x inc map_seq(y) +proc inc(x:block_seq,y:block_seq)=map_seq(x) inc map_seq(y) +proc inc(x:seq or block_seq,y:map_seq)=map_seq(x) inc y +proc in(y:any_int,x:map_seq)=_in_aseq(x.array,size(x.array),int(y)) +proc #'(x:map_seq,y:any_int)=_index_aseq(x.array,size(x.array),int(y)) +proc empty(x:map_seq) { + a=array(0,[1..0]) + return rec map_seq { + array=a + } +} +*/ +proc map_seq(x)=x +proc _rdiv(x,y)=if(y<0=>if(x<0=>x/y,(y-x+1)/y),x>0=>x/y,(x-y+1)/y) + + +type any_seq is range(int),seq(int,int),block_seq // , map_seq + +// Grids (tuples of sequences) +type _gdim is any_seq or int +type grid1d(t1:_gdim) is [t1] except [int] +type grid2d(t1:_gdim,t2:_gdim) is [t1,t2] except [int,int] +type grid3d(t1:_gdim,t2:_gdim,t3:_gdim) is [t1,t2,t3] except [int,int,int] +type grid4d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim) is [t1,t2,t3,t4] except [int,int,int,int] +type grid5d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim,t5:_gdim) is [t1,t2,t3,t4,t5] except [int,int,int,int,int] +type grid6d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim,t5:_gdim,t6:_gdim) is [t1,t2,t3,t4,t5,t6] except [int,int,int,int,int,int] +type grid7d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim,t5:_gdim,t6:_gdim,t7:_gdim) is [t1,t2,t3,t4,t5,t6,t7] except [int,int,int,int,int,int,int] +type grid(ndim:dimension_number) is tuple(_gdim,ndim) except tuple(int,ndim) + +PM__intrinsic _shp(x:int)->(PM__tinyint) : "miss_arg" +proc _shp(x)=0..size(x)-1 +proc _sliceit(...)=tuple(...) +proc #'(x:grid)=map_apply($_shp,$_sliceit,x) +PM__intrinsic _size(x:int)->(PM__tinyint) : "miss_arg" +proc _size(x)=size(x) +proc extent(x:grid)=map_apply($_shp,$_sliceit,x) +proc dims(x:grid)=map_apply($_size,$_sliceit,x) +proc low(x:grid)=map($low,x) +proc high(x:grid)=map($high,x) +proc +(x:grid,y:tuple(range_base))=map($+,x,y) +proc -(x:grid,y:tuple(range_base))=map($-,x,y) +proc empty(x:grid)=map($empty,x) +proc element(x:tuple(any_seq),y)=map($element,x,y) +proc element(x:grid,y)=_gel(head(x),tail(x),head(y),tail(y)) +proc _gel(x:_gdim,xx,y,yy)=prepend(element(x,y),_gel(head(xx),tail(xx),head(yy),tail(yy))) +proc _gel(x:int,xx,y,yy)=prepend(x,_gel(head(xx),tail(xx),y,yy)) +proc _gel(x:empty_head,xx,y:empty_head,yy)=null +proc _gel(x:empty_head,xx,y,yy)=error_type():compile_error("Rank mismatch") + + + +// ************************************** +// ARRAYS +// ************************************** + +/* +// Array types +type array(e,d:shape) is varray(e,d),farray(e,d) +type varray(e,d:shape) is e^var d,array_template(e,d,fix(true)) +type farray(e,d:shape) is e^let d,e^invar d,e^fix d,array_template(e,d,fix(false)) +type farray(e,d:mshape) is ..., + array_slice(e^let any),array_slice(e^var any),array_slice(e^invar any),array_slice(e^fix any) + +// Array operations +proc _arb(x:any^mshape)=_get_aelem(x,0) +PM__if_compiling +proc size(x:any^mshape)=size(#x) +PM__else +PM__intrinsic size(x:any^mshape)->(int) : "get_size" +PM__endif + +*/ + +PM__intrinsic<> _array(x:any,y:any,z:any)->(=x) : "array" +PM__intrinsic<> _varray(x:any,y:any,z:any)->(=x) : "var_array" + + +PM__intrinsic _array_mshape(x:any^any)->(=x) : "get_dom" +PM__intrinsic _get_aelem(x:any^any,y:int)->(=x) : "array_get_elem" +PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" +PM__intrinsic PM__setmaelem(&x:any^any,y:int,z:any): "array_set_multi_elem" +proc array(x,d:extent)=_array(x,_mshape(d),size(d)) +proc #'(x:any^any)=_array_mshape(x)._extent +proc _get_array_element(a:any^any,t:tuple(int))=_get_aelem(a,_point2index(_array_mshape(a),t)) +proc _set_array_element(&a:any^any,t:tuple(int),v):PM__setaelem(&a,_point2index(_array_mshape(a),t),v) +proc _set_array_multi_element(&a:any^any,t:tuple(int),v):PM__setmaelem(&a,_point2index(_array_mshape(PM__import(a)),t),v) +proc _get_array_elementz(a:any^any,t:tuple(int))=_get_aelem(a,_point2index(#(a),t)) +proc _set_array_elementz(&a:any^any,t:tuple(int),v):PM__setaelem(&a,_point2index(#(a),t),v) +proc _set_array_multi_elementz(&a:any^any,t:tuple(int),v):PM__setmaelem(&a,_point2index(PM__import(#a),t),v) + +/* +PM__intrinsic<> _redim(x:any^any,y:any)->(=x) : "redim" +PM__intrinsic<> PM__dim_noinit(x:any,y:any,z:any)->(=x) : "array_noinit" +proc #%(x:invar any^any)=_array_shape(x <>) +proc #%(x)=_get_shape(x) +proc _get_shape(x)=#x +proc #'(x:any^any)=_array_shape(x) +PM__intrinsic _array_shape(x:any^any)->(=x) : "get_dom" +proc dims(x:any^mshape)=dims(#x) +PM__intrinsic PM__extractelm(x:any^any)->(=x) : "extractelm" +proc element(a:any^mshape,t:index)=_get_aelem(a,index(#(a),t)) +proc _set_elem(&a:any^mshape,v,t:index){ + PM__setaelem(&a,index(#(a),t),v) +} + + +PM__intrinsic _get_aelem(x:any^any,y:int)->(=x) : "array_get_elem" +PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" + +*/ + +proc _make_subref(a:any^any,t:tuple(int))=_make_subref(a,_point2index(_array_mshape(a),t)) +PM__intrinsic _make_subref(a:any^any,i:int)->(=a) : "make_rf" + +type _mshape(ndim:dimension_number,contig:literal(bool)) is rec {_extent:extent(ndim),_m:tuple(int,ndim),_n:int,_o:int,_c:contig} +proc _mshape(g:extent(1))=rec _mshape{_extent=g,_m=[1],_n=size(g.1),_o=o,_c=true} where o=-_point2index(dims(g),low(g)) +proc _mshape(g:extent(2))=rec _mshape{_extent=g,_m=[1,s1],_n=s1*size(g.2),_o=o,_c=true} where s1=size(g.1) where o=-_point2index(dims(g),low(g)) +proc _mshape(g:extent(3))=rec _mshape{_extent=g,_m=[1,s1,s2],_n=s2*size(g.3),_o=o,_c=true} where s2=s1*size(g.2) where s1=size(g.1) where o=-_point2index(dims(g),low(g)) +proc _mshape(g:extent(4))=rec _mshape{_extent=g,_m=[1,s1,s3,s3],_n=s3*size(g.4),_o=o,_c=true} where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) where o=-_point2index(dims(g),low(g)) +proc _mshape(g:extent(5))=rec _mshape{_extent=g,_m=[1,s1,s2,s3,s4],_n=s4*size(g.5),_o=o,_c=true} where s4=s3*size(g.4) where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) where o=-_point2index(dims(g),low(g)) +proc _mshape(g:extent(6))=rec _mshape{_extent=g,_m=[1,s1,s2,s3,s4,s5],_n=s5*size(g.6),_o=o,_c=true} where s5=s4*size(g.5) where s4=s3*size(g.4) where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) where o=-_point2index(dims(g),low(g)) +proc _mshape(g:extent(7))=rec _mshape{_extent=g,_m=[1,s1,s2,s3,s4,s5,s6],_n=s6*size(g.7),_o=o,_c=true} where s6=s5*size(g.6) where s5=s4*size(g.5) where s4=s3*size(g.4) where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) where o=-_point2index(dims(g),low(g)) + + +// Linear index of mshape (zero base,unit stride) +proc _point2index(g:_mshape,p:tuple(any_int))=_point2index(g,int(p)) +proc _point2index(g:_mshape(1,literal(true)),p:tuple(int,1))=g._o+g._m.1*p.1 +proc _point2index(g:_mshape(2,literal(true)),p:tuple(int,2))=g._o+g._m.1*p.1+g._m.2*p.2 +proc _point2index(g:_mshape(3,literal(true)),p:tuple(int,3))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3 +proc _point2index(g:_mshape(4,literal(true)),p:tuple(int,4))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4 +proc _point2index(g:_mshape(5,literal(true)),p:tuple(int,5))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5 +proc _point2index(g:_mshape(6,literal(true)),p:tuple(int,6))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6 +proc _point2index(g:_mshape(7,literal(true)),p:tuple(int,7))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6+g._m.7*p.7 +proc _point2index(g:_mshape(1,literal(false)),p:tuple(int,1))=g._o+p.1 +proc _point2index(g:_mshape(2,literal(false)),p:tuple(int,2))=g._o+p.1+g._m.2*p.2 +proc _point2index(g:_mshape(3,literal(false)),p:tuple(int,3))=g._o+p.1+g._m.2*p.2+g._m.3*p.3 +proc _point2index(g:_mshape(4,literal(false)),p:tuple(int,4))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4 +proc _point2index(g:_mshape(5,literal(false)),p:tuple(int,5))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5 +proc _point2index(g:_mshape(6,literal(false)),p:tuple(int,6))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6 +proc _point2index(g:_mshape(7,literal(false)),p:tuple(int,7))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6+g._m.7*p.7 +proc _point2index(g:_mshape,p:tuple(int))=0: compile_error("Rank mismatch in index") + +// Linear index of tuple of ranges or ints (zero base) +proc _indx(g:range(int),s)=int(s) +proc _indx(g:any_int,s)=int(s) +proc _sz(x:int)=x +proc _sz(x:range(int))=x._n +proc _point2index(g:tuple(int,1) or extent(1),s:any_int)=int(_indx(g.1,s)) +proc _point2index(g:tuple(int,1) or extent(1),s:tuple(any_int,1))=int(_indx(g.1,s.1)) +proc _point2index(g:tuple(int,2) or extent(2),s:tuple(any_int,2))=int(_indx(g.1,s.1)+_sz(g.1)*_indx(g.2,s.2)) +proc _point2index(g:tuple(int,3) or extent(3),s:tuple(any_int,3))=int(_indx(g.1,s.1)+_sz(g.1)*(_indx(g.2,s.2)+_sz(g.2)*_indx(g.3,s.3))) +proc _point2index(g:tuple(int,4) or extent(4),s:tuple(any_int,4))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* _indx(g.4,s.4)))) +proc _point2index(g:tuple(int,5) or extent(5),s:tuple(any_int,5))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* _indx(g.5,s.5))))) +proc _point2index(g:tuple(int,6) or extent(6),s:tuple(any_int,6))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* _indx(g.6,s.6)))))) +proc _point2index(g:tuple(int,7) or extent(7),s:tuple(any_int,7))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* (_indx(g.6,s.6)+_sz(g.6)* (_indx(g.7,s.7)))))))) + +proc _index2point(i:int,s:range(int))=[i+s._lo] +proc _index2point(i:int,s:int)=[i] +proc _index2point(i:int,s:tuple(int,1))=[i] +proc _index2point(i:int,s:tuple(int,2))=[i1,i2] where i1=i-i2*_sz(s.1) where i2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,3))=[i1,i2,i3] where i1=i-j2*_sz(s.1) where i2=j2-i3*_sz(s.2) where i3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,4))=[i1,i2,i3,i4] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-i4*_sz(s.3) where i4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,5))=[i1,i2,i3,i4,i5] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-i5*_sz(s.4) where i5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,6))=[i1,i2,i3,i4,i5,i6] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-i6*_sz(s.5) where i6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,7))=[i1,i2,i3,i4,i5,i6,i7] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-j6*_sz(s.5) where i6=j6-i7*_sz(s.6) where i7=j6/_sz(s.6) where j6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) + +/* +// Numeric array operations +proc -(x:num^any)={ + -xx:xx in x +} +proc +(x:num^any,y:num)={ + xx+y:xx in x +} +proc -(x:num^any,y:num)={ + xx-y:xx in x +} +proc *(x:num^any,y:num)={ + xx*y:xx in x +} +proc *(x:num,y:num^any)={ + x*yy:yy in y +} +proc /(x:num^any,y:num)={ + xx/y:xx in x +} +*/ + + +// *************************************************** +// LOOPS AND PARALLEL STATEMENTS +// *************************************************** + +proc PM__for_stmt'(&PM__inout_a,PM__in_a,PM__star_a,shape) yield(&any,any,any) <> { + PM__for size(shape) { + let here_in_tile=PM__generate(shape,size(shape)) + PM__context PM__topology,PM__outer,PM__region,PM__schedule,here_in_tile,PM__mask { + PM__ref inouts=PM__import(PM__inouts) + var inout_a=PM__get_elem(PM__import(PM__inout_a),here_in_tile) + PM__block_proc.'(&inouts, + PM__import(PM__ins), + &inout_a, + PM__get_elem(PM__import(PM__in_a),here_in_tile), + PM__get_elem(PM__import(PM__star_a),here_in_tile) <>) + PM__export(&PM__inouts,inouts) + PM__set_multi_elem(&PM__inout_a,inout_a,here_in_tile <>) + } + } +} + +proc PM__foreach_stmt'(&PM__inout_a,PM__in_a,shape:extent(1)) yield(&any,any) <> { + var index=low(shape.1) + while index<=high(shape.1) { + var inout_a=PM__get_elem(PM__inout_a,[index]) + PM__block_proc.'(&PM__inouts, + PM__ins, + &inout_a, + PM__get_elem(PM__in_a,[index]) <>) + PM__set_elem(&PM__inout_a,inout_a,[index]) + index=index+1 + } +} + +proc PM__foreach_stmt'(&PM__inout_a,PM__in_a,shape:extent(2)) yield(&any,any) <> { + var index2=low(shape.2) + while index2<=high(shape.2) { + var index1=low(shape.1) + while index1<=high(shape.1) { + var inout_a=PM__get_elem(PM__inout_a,[index1,index2]) + PM__block_proc.'(&PM__inouts, + PM__ins, + &inout_a, + PM__get_elem(PM__in_a,[index1,index2]) <>) + PM__set_elem(&PM__inout_a,inout_a,[index1,index2]) + index1=index1+1 + } + index2=index2+1 + } +} + +proc PM__par_stmt'(num) yield() <> { yield() } +proc PM__check_task'(num)=true + +proc PM__chan_stmt'() yield() { yield() } +proc PM__over_stmt'(x) yield() { yield() } + +proc PM__check_iter(x){} +proc PM__check_iter_amp(x){} +proc PM__check_iter_star(x){} +proc PM__check_iter(x,y){} +proc PM__check_iter_amp(x,y){} +proc PM__check_iter_star(x,y){} + +proc PM__get_elem(x:PM__list,h)=PM__each_index(i in num_elements(x):PM__get_elem(x.{i},h)) +proc PM__get_elem(x:any^any,h)=_get_array_elementz(x,h) +proc PM__get_elem(x,h)=element(x,h) +proc PM__set_elem(&x:PM__list,y,h):PM__each_index i in num_elements(x){PM__set_elem(&x.{i},y.{i},h <>)} +proc PM__set_elem(&x:any^any,y,h) {_set_array_elementz(&x,h,y)} +proc PM__set_multi_elem(&x:PM__list,y,h):PM__each_index i in num_elements(x){PM__set_multi_elem(&x.{i},y.{i},h <>)} +proc PM__set_multi_elem(&x:any^any,y,h) {_set_array_multi_elementz(&x,h,y)} + +proc PM__import(x:PM__list)=PM__each_index(i in num_elements(x):PM__import(x.{i})) +PM__intrinsic PM__import(x:any)->(=x) : "import_val" +proc PM__export(&x:PM__list,y:PM__list) {PM__each_index i in num_elements(x){PM__export(&x.{i},y.{i})}} +PM__intrinsic PM__export(&x:any,y:any): "export" + +proc PM__generate(x,n)=_elts(x,1,n) +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->(int) : "iota" +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,first:int,trunc:int,totsiz:int)->(int) : "iota" +proc _n(x:int)=x +proc _elts(x:int,siz,tot)=_iota(siz,0,x,1,tot) +proc _elts(x:range(int),siz,tot)=_iota(siz,0,size(x),1,tot) +proc _elts(x:tuple1d,siz,tot)=tuple(_elts(x.1,siz,tot)) +proc _elts(x:tuple2d,siz,tot)=tuple(_elts(x.1,siz,tot),_elts(x.2,siz*_n(x.1),tot) ) +proc _elts(x:tuple3d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts( x.3, s1*_n(x.2), tot)) where s1=siz*_n(x.1) +proc _elts(x:tuple4d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s2*_n(x.3),tot)) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple5d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s3*_n(x.4), tot)) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple6d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s4*_n(x.5), tot)) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple7d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s5,tot),_elts(x.7,s5*_n(x.6), tot)) where s5=s4*_n(x.5) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) + +// ************************************************** +// SUPPORT FOR OTHER LANGUAGE FEATURES +// ************************************************** + +// Keyword arguments +proc PM__getkey(x:any,y:any)=convert(x,y) +proc PM__getkey(x:null,y:any)=y + +// Switch statement +proc PM__checkcase(x:literal,y:literal)=match_switch_case(x,y) +proc PM__checkcase(x,y)=match_switch_case(x,y) +proc match_switch_case(x:literal,y:literal)=x==y +proc match_switch_case(x:fix(any),y:fix(any))=x==y +proc match_switch_case(x,y)=x==y +proc match_switch_case(x:real_num,y:range(real_num))=x>=y._lo and x<=y._hi +proc match_switch_case(x:literal(int),y:range(literal(int),literal(int)))=(x>=y._lo and x<=y._hi) +proc match_switch_case(x:literal(int),y:range(fix(int),fix(int)))=(x>=y._lo and x<=y._hi) +proc match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:,y:)=y inc x + +// Conditional operators +proc PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> same_type(y,z) { + var r=z + if x { + r=y + } + return r +} + +proc PM__if(x:fix(true),y,z)=y +proc PM__if(x:fix(false),y,z)=z +proc PM__if(x:fix(true),y:literal,z)=y +proc PM__if(x:fix(false),y,z:literal)=z +proc PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> same_type(y,z) { + var r=z + if match(w,x) { + r=y + } + return r +} + +proc PM__switch(w:fix(int),x:fix(int),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z) +proc PM__switch(w,x,y,...)=PM__switch(w,x,y,PM__switch(w,...)) + + +proc PM__assign_op(&a:any,b:any,c:proc) { + compile_error("Not a recognised assignment operator") +} + +PM__intrinsic _assign_element(&any,any): "assign" + +proc PM__assign(&a:any,b:any) { + PM__assign_var(&a,c) where c=convert(b,a) +} + +proc PM__assign(&a:any^any,b:any,j:tuple(int)) { + _set_array_element(&a,j,b) +} + +proc PM__assign(&a:a_rec,b:any,j:literal(string or int)) { + PM__assign(*a.{j},b) +} + +proc PM__assign(&a:any^any,b:any,j:tuple(int),...) { + PM__assign(&a.^_make_subref(j),b,...) +} + +proc PM__assign(&a:a_rec,b:any,j:literal(string or int),...) { + PM__assign(&a.{j},b,...) +} + +proc PM__assign_var(&a:any,b:any) { + test "Cannot assign values"=>same_type(a,b) + _assign_element(&a,b) +} + +proc PM__assign_var(&a:a_rec,b:a_rec) { + test "Cannot assign different records"=>same_rec(a,b) + PM__each_index i in num_elements(a) { + PM__assign(&a.^_element_at_index(i),b.{i}) + } +} + +proc PM__assign(&a:literal,b:literal) { + test "Cannot assign values"=>same_type(a,b) +} +proc PM__assign(&a:fix,b:fix) { + test "Cannot assign values"=>same_type(a,b) +} + +PM__intrinsic PM__get_ref(x:any)->(=x) : "get_rf" +proc PM__get_ref'(x)=PM__get_ref(x) +proc PM__get_ref'(x,...)=PM__get_ref(x,...) +proc PM__get_ref(x:a_rec,j:literal(int or string) or a_unique)=x.{j} +proc PM__get_ref(x:any^any,j:tuple(int))=_get_array_element(x,j) +proc PM__get_ref(x:a_rec,j:literal(int or string) or a_unique,...)=PM__get_ref(x.{j},...) +proc PM__get_ref(x:any^any,j:tuple(int),...)=PM__get_ref(_get_array_element(x,j),...) + +proc PM__subs(x,...)=tuple(x,...) +proc PM__subs(x:tuple)=x + +PM__intrinsic PM__clone(x:any)->(=x) : "clone" +PM__intrinsic PM__make_var(x:any)->(=x) : "clone" priv +PM__intrinsic PM__make_var'(x:priv)->(=x) : "clone_var" priv +PM__intrinsic PM__make_var'(x:any)->(=x) : "clone" priv +PM__intrinsic PM__make_const'(x:any)->(=x) : "clone_var" +PM__intrinsic PM__make_const(x:any)->(=x) : "clone_var" +proc PM__init_var(x:any,y:any)=PM__make_var(x,y) +proc PM__init_const(x:any,y:any)=PM__make_const(x,y) +proc PM__init_var'(x:any,y:any)=PM__make_var'(x,y) +proc PM__init_const'(x:any,y:any)=PM__make_const'(x,y) +proc PM__make_var(x,y)=PM__make_var(x as y) +proc PM__make_const(x,y)=PM__make_const(x as y) +PM__intrinsic PM__dechan'(x:any)->(=x): "clone_var" +PM__intrinsic same_type(x:any,y:any)->(==x,y) : "same_type_fold" +PM__intrinsic same_rec(x:any,y:any)->(==x,y) : "same_rec_fold" + +proc ==(x:a_rec,y:a_rec) { + test "Cannot apply ""=="" to different records"=> same_rec(x,y) + var ok=true + _eq(x,y,&ok) + return ok +} +proc /=(x:any,y:any) { + test "Cannot apply ""/="" to different records"=> same_rec(x,y) + var ok=true + _eq(x,y,&ok) + return not ok +} +proc _eq(x,y,&ok) <> { + PM__each_index i in num_elements(x) { + ok=ok and x.{i}==y.{i} + } +} + + +proc PM__valref(x)=x +proc PM__check_alias(...){} + +PM__intrinsic PM__copy_out(x:any)->(=x) : "clone" +PM__intrinsic PM__copy_back(x:any)->(=x) : "assign" +proc next_enum(x:int)=x+convert(1,x) +proc next_enum(x:int,y:int)=x+convert(y,x) + +PM__intrinsic<> .element_at_index(&x:any,y:fix(int))->(|x):"elem" +PM__intrinsic<> _element_at_index(x:any,y:fix(int))->(|x):"elem" + + +// Type values +PM__intrinsic<> typeof(x:any)->(type x) : "make_type_val" +proc is(x,t)=t inc typeof(x) +proc isnot(x,t)=not(x is t) +proc as(x,t:)...=PM__cast(x,t) +proc as(x,t)=convert(x,t) +proc convert(x,t:a_poly or proc)=PM__cast(x,typeof(t)) +proc convert(x,t)=x +PM__intrinsic<> inc(x:,y:)->( inc x,y) : "type_include_fold" +proc ==(x:,y:)=x inc y and y inc x +PM__intrinsic error_type()->(=1) : "error_type" + +// Debugging +PM__intrinsic<> _dump(any,any): "new_dump" +proc PM__dump'(x)<>:_dump("Value:",x) +proc PM__dump'(y,x)<>:if y:_dump("Value:",x) + +PM__intrinsic<> old_dump(any): "dump" +proc old_dumpit(a) { + old_dump(a) + return a +} + +PM__intrinsic<> old_dump_id(any): "dump_id" + +proc PM__filesys()=1234 { + let junk= +} + +proc PM__check_alias(a,b) {} +proc PM__lhs_and_val(a)=a +proc PM__rhs_and_val(a)=a +proc PM__copy_in(a)=a +proc PM__copy_out(&a,b):a=b + +proc PM__for_in(a)=a +proc PM__for_var(a)=a + +proc PM__import_param'(x)=x +proc PM__export_param'(x)=x +proc PM__import_param'(&x,y){} + +proc PM__make_over'(a)=a + +PM__intrinsic<> PM__list_concat(x:PM__list,y:PM__list)->(=x):"list_concat" +PM__intrinsic<> PM__list_splice(x:PM__list,y:PM__list,i:literal(int),j:literal(int))->(=x):"list_splice" + +proc compile_error(mess:literal(string)): test mess=>false + +type PM__fix_tuple is tuple(fix(int) or range(fix(int),fix(int))) diff --git a/pm/Makefile b/pm/Makefile index ed92415..aed0496 100755 --- a/pm/Makefile +++ b/pm/Makefile @@ -24,12 +24,12 @@ # THE SOFTWARE. FC=gfortran PC=mpifort -FFLAGS= -g -I../src -fbounds-check -fcheck=mem # -Wall +FFLAGS= -g -I../src -fbounds-check -fcheck=mem # -Wall PFLAGS= -g -I../src -fbounds-check -fcheck=mem -PMCODE= sysdep.o kinds.o pcomp.o memory.o hash.o opts.o lib.o symbol.o types.o parser.o linker.o vmdefs.o sysdefs.o codegen.o infer.o wcoder.o array.o parlib.o vm.o main.o +PMCODE= sysdep.o kinds.o pcomp.o memory.o hash.o opts.o lib.o symbol.o types.o ast.o parser.o linker.o vmdefs.o cnodes.o codegen.o infer.o wcoder.o array.o parlib.o vm.o main.o -PMCODE2= ../config/sysdep.f90 ../src/kinds.f90 ../src/pcomp.f90 ../src/memory.f90 ../src/hash.f90 ../src/opts.f90 ../src/lib.f90 ../src/symbol.f90 ../src/types.f90 ../src/parser.f90 ../src/linker.f90 ../src/vmdefs.f90 ../src/sysdefs.f90 ../src/codegen.f90 ../src/infer.f90 ../src/wcoder.f90 ../src/array.f90 ../src/parlib.f90 ../src/vm.f90 ../src/main.f90 +PMCODE2= ../config/sysdep.f90 ../src/kinds.f90 ../src/pcomp.f90 ../src/memory.f90 ../src/hash.f90 ../src/opts.f90 ../src/lib.f90 ../src/symbol.f90 ../src/types.f90 ../src/ast.f90 ../src/parser.f90 ../src/linker.f90 ../src/vmdefs.f90 ../src/sysdefs.f90 ../src/cnodes.f90 ../src/codegen.f90 ../src/infer.f90 ../src/wcoder.f90 ../src/array.f90 ../src/parlib.f90 ../src/vm.f90 ../src/main.f90 @@ -65,40 +65,43 @@ symbol.o : ../src/symbol.f90 opts.o hash.o memory.o kinds.o pcomp.o sysdep.o lib.o : ../src/lib.f90 symbol.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -vmdefs.o : ../src/vmdefs.f90 symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +types.o : ../src/types.f90 symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -parser.o : ../src/parser.f90 types.o vmdefs.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +vmdefs.o : ../src/vmdefs.f90 types.o lib.o symbol.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -types.o : ../src/types.f90 symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +ast.o : ../src/ast.f90 types.o vmdefs.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o + $(FC) $(FFLAGS) -c $< + +parser.o : ../src/parser.f90 ast.o types.o vmdefs.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -array.o : ../src/array.f90 types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +array.o : ../src/array.f90 types.o lib.o symbol.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -parlib.o : ../src/parlib.f90 array.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +parlib.o : ../src/parlib.f90 array.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(PC) $(PFLAGS) -c $< -linker.o : ../src/linker.f90 parser.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +linker.o : ../src/linker.f90 parser.o ast.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -sysdefs.o : ../src/sysdefs.f90 vmdefs.o parser.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +cnodes.o : ../src/cnodes.f90 ast.o symbol.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -codegen.o : ../src/codegen.f90 parser.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +codegen.o : ../src/codegen.f90 cnodes.o ast.o symbol.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -infer.o : ../src/infer.f90 codegen.o parser.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +infer.o : ../src/infer.f90 codegen.o cnodes.o ast.o symbol.o vmdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -wcoder.o : ../src/wcoder.f90 array.o infer.o codegen.o parser.o symbol.o sysdefs.o vmdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +wcoder.o : ../src/wcoder.f90 array.o infer.o cnodes.o ast.o symbol.o vmdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -vm.o : ../src/vm.f90 parlib.o array.o sysdefs.o types.o symbol.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +vm.o : ../src/vm.f90 parlib.o array.o types.o symbol.o lib.o vmdefs.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(FFLAGS) -c $< -main.o : ../src/main.f90 vm.o parlib.o array.o wcoder.o infer.o codegen.o linker.o parser.o symbol.o sysdefs.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o +main.o : ../src/main.f90 vm.o parlib.o array.o wcoder.o infer.o codegen.o linker.o parser.o symbol.o types.o lib.o opts.o hash.o memory.o kinds.o pcomp.o sysdep.o $(FC) $(PFLAGS) -c $< diff --git a/pm/lib/sys/pm.pmm b/pm/lib/sys/pm.pmm new file mode 100644 index 0000000..8ab1921 --- /dev/null +++ b/pm/lib/sys/pm.pmm @@ -0,0 +1,1872 @@ +/* + PM (Parallel Models) Programming Language + + Released under the MIT License (MIT) + Copyright (c) Tim Bellerby, 2025 + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. +*/ + + +PM__intrinsic num_elements(any)->(literal(int)) : "num_elems_fold" + +PM__intrinsic mod(literal(int),literal(int))->(literal(int)) : "mod_fold" +PM__intrinsic ==(literal(int),literal(int))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(int),literal(int))->(literal(bool)) : "ne_fold" +PM__intrinsic >=(literal(int),literal(int))->(literal(bool)) : "ge_fold" +PM__intrinsic >(literal(int),literal(int))->(literal(bool)) : "gt_fold" +PM__intrinsic +(literal(int),literal(int))->(literal(int)) : "add_fold" +PM__intrinsic -(literal(int),literal(int))->(literal(int)) : "sub_fold" +PM__intrinsic *(literal(int),literal(int))->(literal(int)) : "mult_fold" +PM__intrinsic /(literal(int),literal(int))->(literal(int)) : "divide_fold" +PM__intrinsic **(literal(int),literal(int))->(literal(int)) : "pow_fold" +PM__intrinsic max(literal(int),literal(int))->(literal(int)) : "max_fold" +PM__intrinsic min(literal(int),literal(int))->(literal(int)) : "min_fold" +PM__intrinsic -(literal(int))->(literal(int)) : "uminus_fold" +PM__intrinsic string(literal(int))->(literal(string)) : "string_fold" +PM__intrinsic abs(literal(int))->(literal(int)) : "abs_fold" +PM__intrinsic ~(literal(int))->(literal(int)) : "bnot_fold" +PM__intrinsic &(literal(int),literal(int))->(literal(int)) : "band_fold" +PM__intrinsic |(literal(int),literal(int))->(literal(int)) : "bor_fold" +PM__intrinsic ~(literal(int),literal(int))->(literal(int)) : "bxor_fold" +PM__intrinsic shift(literal(int),literal(int))->(literal(int)) : "bshift_fold" +PM__intrinsic pdiff(literal(int),literal(int))->(literal(int)) : "pdiff_fold" +PM__intrinsic sign(literal(int),literal(int))->(literal(int)) : "sign_fold" +PM__intrinsic rem(literal(int),literal(int))->(literal(int)) : "modulo_fold" +PM__intrinsic and(literal(bool),literal(bool))->(literal(bool)) : "and_fold" +PM__intrinsic or(literal(bool),literal(bool))->(literal(bool)) : "or_fold" +PM__intrinsic except(literal(bool),literal(bool))->(literal(bool)) : "except_fold" +PM__intrinsic ==(literal(bool),literal(bool))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(bool),literal(bool))->(literal(bool)) : "ne_fold" +PM__intrinsic ==(literal(string),literal(string))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(string),literal(string))->(literal(bool)) : "ne_fold" +PM__intrinsic ==(literal(real),literal(real))->(literal(bool)) : "eq_fold" +PM__intrinsic /=(literal(real),literal(real))->(literal(bool)) : "ne_fold" +PM__intrinsic ++(literal(string),literal(string))->(literal(string)) : "concat_fold" +PM__intrinsic mod(fix(int),fix(int))->(fix(int)) : "mod_fold" +PM__intrinsic ==(fix(int),fix(int))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(int),fix(int))->(fix(bool)) : "ne_fold" +PM__intrinsic >=(fix(int),fix(int))->(fix(bool)) : "ge_fold" +PM__intrinsic >(fix(int),fix(int))->(fix(bool)) : "gt_fold" +PM__intrinsic +(fix(int),fix(int))->(fix(int)) : "add_fold" +PM__intrinsic -(fix(int),fix(int))->(fix(int)) : "sub_fold" +PM__intrinsic *(fix(int),fix(int))->(fix(int)) : "mult_fold" +PM__intrinsic /(fix(int),fix(int))->(fix(int)) : "divide_fold" +PM__intrinsic **(fix(int),fix(int))->(fix(int)) : "pow_fold" +PM__intrinsic max(fix(int),fix(int))->(fix(int)) : "max_fold" +PM__intrinsic min(fix(int),fix(int))->(fix(int)) : "min_fold" +PM__intrinsic -(fix(int))->(fix(int)) : "uminus_fold" +PM__intrinsic string(fix(int))->(fix(string)) : "string_fold" +PM__intrinsic abs(fix(int))->(fix(int)) : "abs_fold" +PM__intrinsic ~(fix(int))->(fix(int)) : "bnot_fold" +PM__intrinsic &(fix(int),fix(int))->(fix(int)) : "band_fold" +PM__intrinsic |(fix(int),fix(int))->(fix(int)) : "bor_fold" +PM__intrinsic ~(fix(int),fix(int))->(fix(int)) : "bxor_fold" +PM__intrinsic shift(fix(int),fix(int))->(fix(int)) : "bshift_fold" +PM__intrinsic pdiff(fix(int),fix(int))->(fix(int)) : "pdiff_fold" +PM__intrinsic sign(fix(int),fix(int))->(fix(int)) : "sign_fold" +PM__intrinsic rem(fix(int),fix(int))->(fix(int)) : "modulo_fold" +PM__intrinsic and(fix(bool),fix(bool))->(fix(bool)) : "and_fold" +PM__intrinsic or(fix(bool),fix(bool))->(fix(bool)) : "or_fold" +PM__intrinsic except(fix(bool),fix(bool))->(fix(bool)) : "except_fold" +PM__intrinsic ==(fix(bool),fix(bool))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(bool),fix(bool))->(fix(bool)) : "ne_fold" +PM__intrinsic ==(fix(string),fix(string))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(string),fix(string))->(fix(bool)) : "ne_fold" +PM__intrinsic ==(fix(real),fix(real))->(fix(bool)) : "eq_fold" +PM__intrinsic /=(fix(real),fix(real))->(fix(bool)) : "ne_fold" +PM__intrinsic ++(fix(string),fix(string))->(fix(string)) : "concat_fold" + +// ************************************** +// BASIC TYPES +// ************************************** + +// String type +PM__intrinsic<> print(string): "print" + +proc print(x) { + print(string(x)) +} + +PM__intrinsic<> print_all(string): "print"(1) + +proc print_all(x) { + print_all(string(x)) +} + +PM__intrinsic ++(string,string)->(string) : "concat" + +proc ++(x:string,y)=$++.(x,string(y)) +proc ++(x,y)=$++.(string(x),string(y)) +proc string(x:string)=x +proc string(x:null)="null" +proc fmt(x,y)=x:test """fmt"" operator not yet implmented"=>fix(false) + +// sint type +PM__intrinsic PM__assign_var(&sint,sint): "assign_i" +PM__intrinsic mod(sint,sint)->(sint) : "mod_i" +PM__intrinsic ==(sint,sint)->(bool) : "eq_i" +PM__intrinsic /=(sint,sint)->(bool) : "ne_i" +PM__intrinsic >=(sint,sint)->(bool) : "ge_i" +PM__intrinsic >(sint,sint)->(bool) : "gt_i" +PM__intrinsic +(sint,sint)->(sint) : "add_i" +PM__intrinsic -(sint,sint)->(sint) : "sub_i" +PM__intrinsic *(sint,sint)->(sint) : "mult_i" +PM__intrinsic /(sint,sint)->(sint) : "divide_i" +PM__intrinsic **(sint,sint)->(sint) : "pow_i" +PM__intrinsic max(sint,sint)->(sint) : "max_i" +PM__intrinsic min(sint,sint)->(sint) : "min_i" +PM__intrinsic -(sint)->(sint) : "uminus_i" +PM__intrinsic string(sint)->(string) : "string_i" +PM__intrinsic int(sint)->(int) : "long_i" +PM__intrinsic sreal(sint)->(sreal) : "real_i" +PM__intrinsic real(sint)->(real) : "double_i" +proc sint(x:sint)=x +PM__intrinsic abs(sint)->(sint) : "abs_i" +PM__intrinsic bit_not(sint)->(sint) : "bnot_i" +PM__intrinsic &(sint,sint)->(sint) : "band_i" +PM__intrinsic |(sint,sint)->(sint) : "bor_i" +PM__intrinsic ~(sint,sint)->(sint) : "bxor_i" +PM__intrinsic shift(sint,sint)->(sint) : "bshift_i" +PM__intrinsic pdiff(sint,sint)->(sint) : "pdiff_i" +PM__intrinsic sign(sint,sint)->(sint) : "sign_i" +PM__intrinsic rem(sint,sint)->(sint) : "modulo_i" +PM__intrinsic int8(sint)->(int8) : "i8_i" +PM__intrinsic int16(sint)->(int16) : "i16_i" +PM__intrinsic int32(sint)->(int32) : "i32_i" +PM__intrinsic int64(sint)->(int64) : "i64_i" +PM__intrinsic lint(sint)->(lint) : "offset_i" + +// int type +PM__intrinsic PM__assign_var(&int,int): "assign_ln" +PM__intrinsic mod(int,int)->(int) : "mod_ln" +PM__intrinsic ==(int,int)->(bool) : "eq_ln" +PM__intrinsic /=(int,int)->(bool) : "ne_ln" +PM__intrinsic >=(int,int)->(bool) : "ge_ln" +PM__intrinsic >(int,int)->(bool) : "gt_ln" +PM__intrinsic +(int,int)->(int) : "add_ln" +PM__intrinsic -(int,int)->(int) : "sub_ln" +PM__intrinsic *(int,int)->(int) : "mult_ln" +proc *(x:int,y:fix(1))=x +PM__intrinsic /(int,int)->(int) : "divide_ln" +proc /(x:int,y:fix(1))=x +PM__intrinsic **(int,int)->(int) : "pow_ln" +PM__intrinsic max(int,int)->(int) : "max_ln" +PM__intrinsic min(int,int)->(int) : "min_ln" +PM__intrinsic -(int)->(int) : "uminus_ln" +PM__intrinsic string(int)->(string) : "string_ln" +PM__intrinsic sint(int)->(sint) : "int_ln" +PM__intrinsic sreal(int)->(sreal) : "real_ln" +PM__intrinsic real(int)->(real) : "double_ln" +proc int(x:int)=x +PM__intrinsic abs(int)->(int) : "abs_ln" +PM__intrinsic ~(int)->(int) : "bnot_ln" +PM__intrinsic &(int,int)->(int) : "band_ln" +PM__intrinsic |(int,int)->(int) : "bor_ln" +PM__intrinsic ~(int,int)->(int) : "bxor_ln" +PM__intrinsic shift(int,int)->(int) : "bshift_ln" +PM__intrinsic pdiff(int,int)->(int) : "pdiff_ln" +PM__intrinsic sign(int,int)->(int) : "sign_ln" +PM__intrinsic rem(int,int)->(int) : "modulo_ln" +PM__intrinsic int8(int)->(int8) : "i8_ln" +PM__intrinsic int16(int)->(int16) : "i16_ln" +PM__intrinsic int32(int)->(int32) : "i32_ln" +PM__intrinsic int64(int)->(int64) : "i64_ln" +PM__intrinsic lint(int)->(lint) : "offset_ln" + +// lint type +PM__intrinsic PM__assign_var(&lint,lint): "assign_offset" +PM__intrinsic mod(lint,lint)->(lint) : "mod_offset" +PM__intrinsic ==(lint,lint)->(bool) : "eq_offset" +PM__intrinsic /=(lint,lint)->(bool) : "ne_offset" +PM__intrinsic >=(lint,lint)->(bool) : "ge_offset" +PM__intrinsic >(lint,lint)->(bool) : "gt_offset" +PM__intrinsic +(lint,lint)->(lint) : "add_offset" +proc +(x:lint,y:fix(0))=x +proc +(x:fix(0),y:lint)=y +PM__intrinsic -(lint,lint)->(lint) : "sub_offset" +proc -(x:lint,y:fix(0))=x +PM__intrinsic *(lint,lint)->(lint) : "mult_offset" +proc *(x:lint,y:fix(1))=x +proc *(x:fix(1),y:lint)=y +PM__intrinsic /(lint,lint)->(lint) : "divide_offset" +proc /(x:lint,y:fix(1))=x +PM__intrinsic **(lint,lint)->(lint) : "pow_offset" +proc **(x:lint,y:fix(0))=1 +proc **(x:lint,y:fix(1))=x +proc **(x:lint,y:fix(2))=x*x +PM__intrinsic max(lint,lint)->(lint) : "max_offset" +PM__intrinsic min(lint,lint)->(lint) : "min_offset" +PM__intrinsic -(lint)->(lint) : "uminus_offset" +PM__intrinsic string(lint)->(string) : "string_offset" +PM__intrinsic sint(lint)->(sint) : "int_offset" +PM__intrinsic sreal(lint)->(sreal) : "real_offset" +PM__intrinsic real(lint)->(real) : "double_offset" +proc lint(x:lint)=x +PM__intrinsic abs(lint)->(lint) : "abs_offset" +PM__intrinsic ~(lint)->(lint) : "bnot_offset" +PM__intrinsic &(lint,lint)->(lint) : "band_offset" +PM__intrinsic |(lint,lint)->(lint) : "bor_offset" +PM__intrinsic ~(lint,lint)->(lint) : "bxor_offset" +PM__intrinsic shift(lint,lint)->(lint) : "bshift_offset" +PM__intrinsic pdiff(lint,lint)->(lint) : "pdiff_offset" +PM__intrinsic sign(lint,lint)->(lint) : "sign_offset" +PM__intrinsic rem(lint,lint)->(lint) : "modulo_offset" +PM__intrinsic int8(lint)->(int8) : "i8_offset" +PM__intrinsic int16(lint)->(int16) : "i16_offset" +PM__intrinsic int32(lint)->(int32) : "i32_offset" +PM__intrinsic int64(lint)->(int64) : "i64_offset" +PM__intrinsic int(lint)->(int) : "long_offset" + +// int8 type +PM__intrinsic PM__assign_var(&int8,int8): "assign_i8" +PM__intrinsic mod(int8,int8)->(int8) : "mod_i8" +PM__intrinsic ==(int8,int8)->(bool) : "eq_i8" +PM__intrinsic /=(int8,int8)->(bool) : "ne_i8" +PM__intrinsic >=(int8,int8)->(bool) : "ge_i8" +PM__intrinsic >(int8,int8)->(bool) : "gt_i8" +PM__intrinsic +(int8,int8)->(int8) : "add_i8" +proc +(x:int8,y:fix(0))=x +proc +(x:fix(0),y:int8)=y +PM__intrinsic -(int8,int8)->(int8) : "sub_i8" +proc -(x:int8,y:fix(0))=x +PM__intrinsic *(int8,int8)->(int8) : "mult_i8" +proc *(x:int8,y:fix(1))=x +proc *(x:fix(1),y:int8)=y +PM__intrinsic /(int8,int8)->(int8) : "divide_i8" +proc /(x:int8,y:fix(1))=x +PM__intrinsic **(int8,int8)->(int8) : "pow_i8" +proc **(x:int8,y:fix(0))=1 +proc **(x:int8,y:fix(1))=x +proc **(x:int8,y:fix(2))=x*x +PM__intrinsic max(int8,int8)->(int8) : "max_i8" +PM__intrinsic min(int8,int8)->(int8) : "min_i8" +PM__intrinsic -(int8)->(int8) : "uminus_i8" +PM__intrinsic sint(int8)->(sint) : "int_i8" +PM__intrinsic sreal(int8)->(sreal) : "real_i8" +PM__intrinsic real(int8)->(real) : "double_i8" +proc int8(x:int8)=x +PM__intrinsic abs(int8)->(int8) : "abs_i8" +PM__intrinsic ~(int8)->(int8) : "bnot_i8" +PM__intrinsic &(int8,int8)->(int8) : "band_i8" +PM__intrinsic |(int8,int8)->(int8) : "bor_i8" +PM__intrinsic ~(int8,int8)->(int8) : "bxor_i8" +PM__intrinsic shift(int8,int8)->(int8) : "bshift_i8" +PM__intrinsic pdiff(int8,int8)->(int8) : "pdiff_i8" +PM__intrinsic sign(int8,int8)->(int8) : "sign_i8" +PM__intrinsic rem(int8,int8)->(int8) : "modulo_i8" +PM__intrinsic int16(int8)->(int16) : "i16_i8" +PM__intrinsic int32(int8)->(int32) : "i32_i8" +PM__intrinsic int64(int8)->(int64) : "i64_i8" +PM__intrinsic int(int8)->(int) : "long_i8" +PM__intrinsic lint(int8)->(lint) : "offset_i8" + +// int16 type +PM__intrinsic PM__assign_var(&int16,int16): "assign_i16" +PM__intrinsic mod(int16,int16)->(int16) : "mod_i16" +PM__intrinsic ==(int16,int16)->(bool) : "eq_i16" +PM__intrinsic /=(int16,int16)->(bool) : "ne_i16" +PM__intrinsic >=(int16,int16)->(bool) : "ge_i16" +PM__intrinsic >(int16,int16)->(bool) : "gt_i16" +PM__intrinsic +(int16,int16)->(int16) : "add_i16" +proc +(x:int16,y:fix(0))=x +proc +(x:fix(0),y:int16)=y +PM__intrinsic -(int16,int16)->(int16) : "sub_i16" +proc -(x:int16,y:fix(0))=x +PM__intrinsic *(int16,int16)->(int16) : "mult_i16" +proc *(x:int16,y:fix(1))=x +proc *(x:fix(1),y:int16)=y +PM__intrinsic /(int16,int16)->(int16) : "divide_i16" +proc /(x:int16,y:fix(1))=x +PM__intrinsic **(int16,int16)->(int16) : "pow_i16" +proc **(x:int16,y:fix(0))=1 +proc **(x:int16,y:fix(1))=x +proc **(x:int16,y:fix(2))=x*x +PM__intrinsic max(int16,int16)->(int16) : "max_i16" +PM__intrinsic min(int16,int16)->(int16) : "min_i16" +PM__intrinsic -(int16)->(int16) : "uminus_i16" +PM__intrinsic sint(int16)->(sint) : "int_i16" +PM__intrinsic sreal(int16)->(sreal) : "real_i16" +PM__intrinsic real(int16)->(real) : "double_i16" +proc int16(x:int16)=x +PM__intrinsic abs(int16)->(int16) : "abs_i16" +PM__intrinsic ~(int16)->(int16) : "bnot_i16" +PM__intrinsic &(int16,int16)->(int16) : "band_i16" +PM__intrinsic |(int16,int16)->(int16) : "bor_i16" +PM__intrinsic ~(int16,int16)->(int16) : "bxor_i16" +PM__intrinsic shift(int16,int16)->(int16) : "bshift_i16" +PM__intrinsic pdiff(int16,int16)->(int16) : "pdiff_i16" +PM__intrinsic sign(int16,int16)->(int16) : "sign_i16" +PM__intrinsic rem(int16,int16)->(int16) : "modulo_i16" +PM__intrinsic int8(int16)->(int16) : "i8_i16" +PM__intrinsic int32(int16)->(int32) : "i32_i16" +PM__intrinsic int64(int16)->(int64) : "i64_i16" +PM__intrinsic int(int16)->(int) : "long_i16" +PM__intrinsic lint(int16)->(lint) : "offset_i16" + +// int32 type +PM__intrinsic PM__assign_var(&int32,int32): "assign_i32" +PM__intrinsic mod(int32,int32)->(int32) : "mod_i32" +PM__intrinsic ==(int32,int32)->(bool) : "eq_i32" +PM__intrinsic /=(int32,int32)->(bool) : "ne_i32" +PM__intrinsic >=(int32,int32)->(bool) : "ge_i32" +PM__intrinsic >(int32,int32)->(bool) : "gt_i32" +PM__intrinsic +(int32,int32)->(int32) : "add_i32" +proc +(x:int32,y:fix(0))=x +proc +(x:fix(0),y:int32)=y +PM__intrinsic -(int32,int32)->(int32) : "sub_i32" +proc -(x:int32,y:fix(0))=x +PM__intrinsic *(int32,int32)->(int32) : "mult_i32" +proc *(x:int32,y:fix(1))=x +proc *(x:fix(1),y:int32)=y +PM__intrinsic /(int32,int32)->(int32) : "divide_i32" +proc /(x:int32,y:fix(1))=x +PM__intrinsic **(int32,int32)->(int32) : "pow_i32" +proc **(x:int32,y:fix(0))=1 +proc **(x:int32,y:fix(1))=x +proc **(x:int32,y:fix(2))=x*x +PM__intrinsic max(int32,int32)->(int32) : "max_i32" +PM__intrinsic min(int32,int32)->(int32) : "min_i32" +PM__intrinsic -(int32)->(int32) : "uminus_i32" +PM__intrinsic sint(int32)->(sint) : "int_i32" +PM__intrinsic sreal(int32)->(sreal) : "real_i32" +PM__intrinsic real(int32)->(real) : "double_i32" +proc int32(x:int32)=x +PM__intrinsic abs(int32)->(int32) : "abs_i32" +PM__intrinsic ~(int32)->(int32) : "bnot_i32" +PM__intrinsic &(int32,int32)->(int32) : "band_i32" +PM__intrinsic |(int32,int32)->(int32) : "bor_i32" +PM__intrinsic ~(int32,int32)->(int32) : "bxor_i32" +PM__intrinsic shift(int32,int32)->(int32) : "bshift_i32" +PM__intrinsic pdiff(int32,int32)->(int32) : "pdiff_i32" +PM__intrinsic sign(int32,int32)->(int32) : "sign_i32" +PM__intrinsic rem(int32,int32)->(int32) : "modulo_i32" +PM__intrinsic int8(int32)->(int32) : "i8_i32" +PM__intrinsic int16(int32)->(int32) : "i16_i32" +PM__intrinsic int64(int32)->(int64) : "i64_i32" +PM__intrinsic int(int32)->(int) : "long_i32" +PM__intrinsic lint(int32)->(lint) : "offset_i32" + +// int64 type +PM__intrinsic PM__assign_var(&int64,int64): "assign_i64" +PM__intrinsic mod(int64,int64)->(int64) : "mod_i64" +PM__intrinsic ==(int64,int64)->(bool) : "eq_i64" +PM__intrinsic /=(int64,int64)->(bool) : "ne_i64" +PM__intrinsic >=(int64,int64)->(bool) : "ge_i64" +PM__intrinsic >(int64,int64)->(bool) : "gt_i64" +PM__intrinsic +(int64,int64)->(int64) : "add_i64" +proc +(x:int64,y:fix(0))=x +proc +(x:fix(0),y:int64)=y +PM__intrinsic -(int64,int64)->(int64) : "sub_i64" +proc -(x:int64,y:fix(0))=x +PM__intrinsic *(int64,int64)->(int64) : "mult_i64" +proc *(x:int64,y:fix(1))=x +proc *(x:fix(1),y:int64)=y +PM__intrinsic /(int64,int64)->(int64) : "divide_i64" +proc /(x:int64,y:fix(1))=x +PM__intrinsic **(int64,int64)->(int64) : "pow_i64" +proc **(x:int64,y:fix(0))=1 +proc **(x:int64,y:fix(1))=x +proc **(x:int64,y:fix(2))=x*x +PM__intrinsic max(int64,int64)->(int64) : "max_i64" +PM__intrinsic min(int64,int64)->(int64) : "min_i64" +PM__intrinsic -(int64)->(int64) : "uminus_i64" +PM__intrinsic string(int64)->(string) : "string_i64" +PM__intrinsic sint(int64)->(sint) : "int_i64" +PM__intrinsic sreal(int64)->(sreal) : "real_i64" +PM__intrinsic real(int64)->(real) : "double_i64" +proc int64(x:int64)=x +PM__intrinsic abs(int64)->(int64) : "abs_i64" +PM__intrinsic ~(int64)->(int64) : "bnot_i64" +PM__intrinsic &(int64,int64)->(int64) : "band_i64" +PM__intrinsic |(int64,int64)->(int64) : "bor_i64" +PM__intrinsic ~(int64,int64)->(int64) : "bxor_i64" +PM__intrinsic shift(int64,int64)->(int64) : "bshift_i64" +PM__intrinsic pdiff(int64,int64)->(int64) : "pdiff_i64" +PM__intrinsic sign(int64,int64)->(int64) : "sign_i64" +PM__intrinsic rem(int64,int64)->(int64) : "modulo_i64" +PM__intrinsic int8(int64)->(int64) : "i8_i64" +PM__intrinsic int16(int64)->(int64) : "i16_i64" +PM__intrinsic int32(int64)->(int64) : "i32_i64" +PM__intrinsic int(int64)->(int) : "long_i64" +PM__intrinsic lint(int64)->(lint) : "offset_i64" + +// sreal type +PM__intrinsic PM__assign_var(&sreal,sreal): "assign_r" +PM__intrinsic mod(sreal,sreal)->(sreal) : "mod_r" +PM__intrinsic ==(sreal,sreal)->(bool) : "eq_r" +PM__intrinsic /=(sreal,sreal)->(bool) : "ne_r" +PM__intrinsic >=(sreal,sreal)->(bool) : "ge_r" +PM__intrinsic >(sreal,sreal)->(bool) : "gt_r" +PM__intrinsic +(sreal,sreal)->(sreal) : "add_r" +PM__intrinsic -(sreal,sreal)->(sreal) : "sub_r" +PM__intrinsic *(sreal,sreal)->(sreal) : "mult_r" +PM__intrinsic /(sreal,sreal)->(sreal) : "divide_r" +PM__intrinsic **(sreal,sreal)->(sreal) : "pow_r" +PM__intrinsic max(sreal,sreal)->(sreal) : "max_r" +PM__intrinsic min(sreal,sreal)->(sreal) : "min_r" +PM__intrinsic -(sreal)->(sreal) : "uminus_r" +PM__intrinsic string(sreal)->(string) : "string_r" +PM__intrinsic strunc(sreal)->(sint) : "int_r" +PM__intrinsic trunc(sreal)->(int) : "long_r" +PM__intrinsic ltrunc(sreal)->(lint) : "offset_r" +PM__intrinsic real(sreal)->(real) : "double_r" +proc sreal(x:sreal)=x +PM__intrinsic abs(sreal)->(sreal) : "abs_r" +PM__intrinsic acos(sreal)->(sreal) : "acos_r" +PM__intrinsic asin(sreal)->(sreal) : "asin_r" +PM__intrinsic atan(sreal)->(sreal) : "atan_r" +PM__intrinsic atan2(sreal,sreal)->(sreal) : "atan2_r" +PM__intrinsic cos(sreal)->(sreal) : "cos_r" +PM__intrinsic cosh(sreal)->(sreal) : "cosh_r" +PM__intrinsic exp(sreal)->(sreal) : "exp_r" +PM__intrinsic log(sreal)->(sreal) : "log_r" +PM__intrinsic log10(sreal)->(sreal) : "log10_r" +PM__intrinsic sin(sreal)->(sreal) : "sin_r" +PM__intrinsic sinh(sreal)->(sreal) : "sinh_r" +PM__intrinsic sqrt(sreal)->(sreal) : "sqrt_r" +PM__intrinsic tan(sreal)->(sreal) : "tan_r" +PM__intrinsic tanh(sreal)->(sreal) : "tanh_r" +PM__intrinsic floor(sreal)->(sreal) : "floor_r" +PM__intrinsic ceil(sreal)->(sreal) : "ceil_r" +PM__intrinsic rem(sreal,sreal)->(sreal) : "modulo_r" +PM__intrinsic sign(sreal,sreal)->(sreal) : "sign_r" +PM__intrinsic pdiff(sreal,sreal)->(sreal) : "pdiff_r" +PM__intrinsic lint(sreal)->(lint) : "offset_r" +PM__intrinsic scpx(sreal)->(scpx) : "complex_r" +PM__intrinsic _scpx2(sreal,sreal)->(scpx) : "complex2_r" +proc scpx(x:any_real,y:any_real)=_scpx2(sreal(x),sreal(y)) + +// real type +PM__intrinsic PM__assign_var(&real,real): "assign_d" +PM__intrinsic mod(real,real)->(real) : "mod_d" +PM__intrinsic ==(real,real)->(bool) : "eq_d" +PM__intrinsic /=(real,real)->(bool) : "ne_d" +PM__intrinsic >=(real,real)->(bool) : "ge_d" +PM__intrinsic >(real,real)->(bool) : "gt_d" +PM__intrinsic +(real,real)->(real) : "add_d" +PM__intrinsic -(real,real)->(real) : "sub_d" +PM__intrinsic *(real,real)->(real) : "mult_d" +PM__intrinsic /(real,real)->(real) : "divide_d" +PM__intrinsic **(real,real)->(real) : "pow_d" +PM__intrinsic max(real,real)->(real) : "max_d" +PM__intrinsic min(real,real)->(real) : "min_d" +PM__intrinsic -(real)->(real) : "uminus_d" +PM__intrinsic string(real)->(string) : "string_d" +PM__intrinsic strunc(real)->(sint) : "int_d" +PM__intrinsic trunc(real)->(int) : "long_d" +PM__intrinsic ltrunc(real)->(lint) : "offset_d" +PM__intrinsic sreal(real)->(sreal) : "real_d" +proc real(x:real)=x +PM__intrinsic abs(real)->(real) : "abs_d" +PM__intrinsic acos(real)->(real) : "acos_d" +PM__intrinsic asin(real)->(real) : "asin_d" +PM__intrinsic atan(real)->(real) : "atan_d" +PM__intrinsic atan2(real,real)->(real) : "atan2_d" +PM__intrinsic cos(real)->(real) : "cos_d" +PM__intrinsic cosh(real)->(real) : "cosh_d" +PM__intrinsic exp(real)->(real) : "exp_d" +PM__intrinsic log(real)->(real) : "log_d" +PM__intrinsic log10(real)->(real) : "log10_d" +PM__intrinsic sin(real)->(real) : "sin_d" +PM__intrinsic sinh(real)->(real) : "sinh_d" +PM__intrinsic sqrt(real)->(real) : "sqrt_d" +PM__intrinsic tan(real)->(real) : "tan_d" +PM__intrinsic tanh(real)->(real) : "tanh_d" +PM__intrinsic floor(real)->(real) : "floor_d" +PM__intrinsic ceil(real)->(real) : "ceil_d" +PM__intrinsic rem(real,real)->(real) : "modulo_d" +PM__intrinsic sign(real,real)->(real) : "sign_d" +PM__intrinsic pdiff(real,real)->(real) : "pdiff_d" +PM__intrinsic lint(real)->(lint) : "offset_d" +PM__intrinsic cpx(real)->(cpx) : "complex_d" +PM__intrinsic _cpx2(real,real)->(cpx) : "complex2_d" +proc cpx(x:real_num,y:real_num)=_cpx2(real(x),real(y)) + +// scpx type +PM__intrinsic PM__assign_var(&scpx,scpx): "assign_c" +PM__intrinsic +(scpx,scpx)->(scpx) : "add_c" +PM__intrinsic -(scpx,scpx)->(scpx) : "sub_c" +PM__intrinsic *(scpx,scpx)->(scpx) : "mult_c" +PM__intrinsic /(scpx,scpx)->(scpx) : "divide_c" +PM__intrinsic **(scpx,sreal)->(scpx) : "rpow_c" +PM__intrinsic **(scpx,scpx)->(scpx) : "pow_c" +PM__intrinsic -(scpx)->(scpx) : "uminus_c" +PM__intrinsic ==(scpx,scpx)->(bool) : "eq_c" +PM__intrinsic /=(scpx,scpx)->(bool) : "ne_c" +PM__intrinsic re(scpx)->(sreal) : "real_c" +PM__intrinsic abs(scpx)->(scpx) : "abs_c" +PM__intrinsic acos(scpx)->(scpx) : "acos_c" +PM__intrinsic asin(scpx)->(scpx) : "asin_c" +PM__intrinsic atan(scpx)->(scpx) : "atan_c" +PM__intrinsic atan2(scpx,scpx)->(scpx) : "atan2_c" +PM__intrinsic cos(scpx)->(scpx) : "cos_c" +PM__intrinsic cosh(scpx)->(scpx) : "cosh_c" +PM__intrinsic exp(scpx)->(scpx) : "exp_c" +PM__intrinsic log(scpx)->(scpx) : "log_c" +PM__intrinsic sin(scpx)->(scpx) : "sin_c" +PM__intrinsic sinh(scpx)->(scpx) : "sinh_c" +PM__intrinsic sqrt(scpx)->(scpx) : "sqrt_c" +PM__intrinsic tan(scpx)->(scpx) : "tan_c" +PM__intrinsic tanh(scpx)->(scpx) : "tanh_c" +PM__intrinsic im(scpx)->(sreal) : "imag_c" +PM__intrinsic conj(scpx)->(scpx) : "conj_c" + +// cpx type +PM__intrinsic PM__assign_var(&cpx,cpx): "assign_dc" +PM__intrinsic +(cpx,cpx)->(cpx) : "add_dc" +PM__intrinsic -(cpx,cpx)->(cpx) : "sub_dc" +PM__intrinsic *(cpx,cpx)->(cpx) : "mult_dc" +PM__intrinsic /(cpx,cpx)->(cpx) : "divide_dc" +PM__intrinsic **(cpx,real)->(cpx) : "dpow_dc" +proc **(x:cpx,y:sreal)=x**real(y) +PM__intrinsic **(cpx,cpx)->(cpx) : "pow_dc" +PM__intrinsic -(cpx)->(cpx) : "uminus_dc" +PM__intrinsic ==(cpx,cpx)->(bool) : "eq_dc" +PM__intrinsic /=(cpx,cpx)->(bool) : "ne_dc" +PM__intrinsic re(cpx)->(real) : "real_dc" +PM__intrinsic abs(cpx)->(cpx) : "abs_dc" +PM__intrinsic acos(cpx)->(cpx) : "acos_dc" +PM__intrinsic asin(cpx)->(cpx) : "asin_dc" +PM__intrinsic atan(cpx)->(cpx) : "atan_dc" +PM__intrinsic atan2(cpx,cpx)->(cpx) : "atan2_dc" +PM__intrinsic cos(cpx)->(cpx) : "cos_dc" +PM__intrinsic cosh(cpx)->(cpx) : "cosh_dc" +PM__intrinsic exp(cpx)->(cpx) : "exp_dc" +PM__intrinsic log(cpx)->(cpx) : "log_dc" +PM__intrinsic sin(cpx)->(cpx) : "sin_dc" +PM__intrinsic sinh(cpx)->(cpx) : "sinh_dc" +PM__intrinsic sqrt(cpx)->(cpx) : "sqrt_dc" +PM__intrinsic tan(cpx)->(cpx) : "tan_dc" +PM__intrinsic tanh(cpx)->(cpx) : "tanh_dc" +PM__intrinsic im(cpx)->(real) : "imag_dc" +PM__intrinsic conj(cpx)->(cpx) : "conj_dc" + +// Cannot convert real to int (must use nint or trunc) +proc sint(x:any_real)=sint(0) :test "Cannot convert real to integer" => fix(false) +proc int(x:any_real)=0 :test "Cannot convert real to integer" => fix(false) +proc lint(x:any_real)=lint(0) :test "Cannot convert real to integer" => fix(false) + +// Some numeric conversions not hard-coded +proc cpx(x:real_num)=cpx(real(x)) +proc scpx(x:real_num)=cpx(sreal(x)) +proc string(x:any_int)=string(int64(x)) +proc string(x:any_cpx)= string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x) +proc int(x:fix(int))=x + + +// Abstract numeric types +type any_int is sint,int,lint,int8,int16,int32,int64 +type any_real is sreal,real +type any_cpx is scpx,cpx +type int_num is any_int +type real_num is int_num, any_real +type cpx_num is real_num,any_cpx +type num is cpx_num + +// Numeric type conversion +proc convert(x,y)=x +proc convert(x:int_num,y:sint)=sint(x) +proc convert(x:int_num,y:int)=int(x) +proc convert(x:int_num,y:lint)=lint(x) +proc convert(x:int_num,y:int8)=int8(x) +proc convert(x:int_num,y:int16)=int16(x) +proc convert(x:int_num,y:int32)=int32(x) +proc convert(x:int_num,y:int64)=int64(x) +proc convert(x:int_num,y:sreal)=sreal(x) +proc convert(x:int_num,y:real)=real(x) +proc convert(x:real_num,y:cpx)=cpx(x) +proc convert(x:real_num,y:scpx)=scpx(x) +proc as(x:int_num,y:)=sint(x) +proc as(x:int_num,y:)=int(x) +proc as(x:int_num,y:)=lint(x) +proc as(x:int_num,y:)=int8(x) +proc as(x:int_num,y:)=int16(x) +proc as(x:int_num,y:)=int32(x) +proc as(x:int_num,y:)=int64(x) +proc as(x:real_num,y:)=sreal(x) +proc as(x:real_num,y:)=real(x) +proc as(x:real_num,y:)=scpx(x) +proc as(x:real_num,y:)=cpx(x) + +// Auto-conversion on assignment +proc PM__assign(&x:num,y:num) { + _assign_element(&x,convert(y,x)) +} + +proc PM__assign_var(&x:num,y:num) { + PM__assign(&x,convert(y,x)) +} + +// Mixed arithmatic +type _to_sint is int +type _to_lint is sint,int +type _to_int8 is sint,int,lint +type _to_int16 is sint,int,lint,int8 +type _to_int32 is sint,int,lint,int8,int16 +type _to_int64 is sint,int,lint,int8,int16,int32 +type _to_real is any_int +type _to_sreal is any_int,real +type _to_cpx is real_num +type _to_scpx is real_num,cpx +proc balance(x:sint,y:sint)=x,y +proc balance(x:int,y:int)=x,y +proc balance(x:lint,y:lint)=x,y +proc balance(x:int8,y:int8)=x,y +proc balance(x:int16,y:int16)=x,y +proc balance(x:int32,y:int32)=x,y +proc balance(x:int64,y:int64)=x,y +proc balance(x:sreal,y:sreal)=x,y +proc balance(x:real,y:real)=x,y +proc balance(x:scpx,y:scpx)=x,y +proc balance(x:cpx,y:cpx)=x,y +proc balance(x:sint,y:_to_sint)=x,sint(y) +proc balance(x:lint,y:_to_lint)=x,lint(y) +proc balance(x:int8,y:_to_int8)=x,int8(y) +proc balance(x:int16,y:_to_int16)=x,int16(y) +proc balance(x:int32,y:_to_int32)=x,int32(y) +proc balance(x:int64,y:_to_int64)=x,int64(y) +proc balance(x:sreal,y:_to_sreal)=x,sreal(y) +proc balance(x:real,y:_to_real)=x,real(y) +proc balance(x:scpx,y:_to_scpx)=x,scpx(y) +proc balance(x:cpx,y:_to_cpx)=x,cpx(y) +proc balance(x:_to_sint,y:sint)=sint(x),y +proc balance(x:_to_lint,y:lint)=lint(x),y +proc balance(x:_to_int8,y:int8)=int8(x),y +proc balance(x:_to_int16,y:int16)=int16(x),y +proc balance(x:_to_int32,y:int32)=int32(x),y +proc balance(x:_to_int64,y:int64)=int64(x),y +proc balance(x:_to_sreal,y:sreal)=sreal(x),y +proc balance(x:_to_real,y:real)=real(x),y +proc balance(x:_to_scpx,y:scpx)=scpx(x),y +proc balance(x:_to_cpx,y:cpx)=cpx(x),y +proc div(x:any_int,y:any_int)=if(sz=>r,-1-r) where r=if(sz=>x,abs(x)-1)/if(sz=>y,abs(y))where sz=sign(x,y)==x +proc _divz(x:any_int,y:any_int)=z { + var z,_=balance(x,y) + if(sign(x,y)==x):z=x/y else: z=-1-(abs(x)-1)/abs(y) +} +proc mod(x:real_num,y:real_num)=xx mod yy where xx,yy=balance(x,y) +proc ==(x:num,y:num)=xx==yy where xx,yy=balance(x,y) +proc /=(x:num,y:num)=xx/=yy where xx,yy=balance(x,y) +proc >=(x:real_num,y:real_num)=xx>=yy where xx,yy=balance(x,y) +proc >(x:real_num,y:real_num)=xx>yy where xx,yy=balance(x,y) +proc +(x:num,y:num)=xx+yy where xx,yy=balance(x,y) +proc -(x:num,y:num)=xx-yy where xx,yy=balance(x,y) +proc *(x:num,y:num)=xx*yy where xx,yy=balance(x,y) +proc /(x:num,y:num)=xx/yy where xx,yy=balance(x,y) +proc **(x:num,y:num)=xx**yy where xx,yy=balance(x,y) +proc &(x:num,y:num)=xx&yy where xx,yy=balance(x,y) +proc |(x:num,y:num)=xx|yy where xx,yy=balance(x,y) +proc ~(x:num,y:num)=xx ~ yy where xx,yy=balance(x,y) +proc shift(x:num,y:num)=xx shift yy where xx,yy=balance(x,y) +proc max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y) +proc min(x:num,y:num)=min(xx,yy) where xx,yy=balance(x,y) + +// Indexed arithmetic +proc +'(x,y)=$+.(x,y) +proc -'(x,y)=$-.(x,y) +proc *'(x,y)=$*.(x,y) +proc /'(x,y)=$/.(x,y) +proc -'(x)=$-.(x) + +// bool type +PM__intrinsic PM__assign_var(&bool,bool): "assign_l" +PM__intrinsic string(bool)->(string) : "string_l" +PM__intrinsic and(bool,bool)->(bool) : "and" +PM__intrinsic or(bool,bool)->(bool) : "or" +PM__intrinsic not(bool)->(bool) : "not" +PM__intrinsic ==(bool,bool)->(bool) : "eq_l" +PM__intrinsic /=(bool,bool)->(bool) : "ne_l" + + +// val function having null effect +proc val(x)=x + + +// ******************************************** +// TUPLES +// ******************************************** + +// Tuple types + +type tuple1d(t1) is rec {PM__d1:t1} +type tuple2d(t1,t2) is rec {PM__d1:t1,PM__d2:t2} +type tuple3d(t1,t2,t3) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3} +type tuple4d(t1,t2,t3,t4) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4} +type tuple5d(t1,t2,t3,t4,t5) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5} +type tuple6d(t1,t2,t3,t4,t5,t6) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6} +type tuple7d(t1,t2,t3,t4,t5,t6,t7) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6,PM__d7:t7} + +type dimension_number is 1,2,3,4,5,6,7 +type tuple(t,r:dimension_number) +type tuple(t,r:1) is ...,tuple1d(t) +type tuple(t,r:2) is ...,tuple2d(t,t) +type tuple(t,r:3) is ...,tuple3d(t,t,t) +type tuple(t,r:4) is ...,tuple4d(t,t,t,t) +type tuple(t,r:5) is ...,tuple5d(t,t,t,t,t) +type tuple(t,r:6) is ...,tuple6d(t,t,t,t,t,t) +type tuple(t,r:7) is ...,tuple7d(t,t,t,t,t,t,t) + +proc tuple(x)=rec tuple1d { + PM__d1=x +} +proc tuple(x,y)=rec tuple2d { + PM__d1=x,PM__d2=y +} +proc tuple(x,y,z)=rec tuple3d { + PM__d1=x,PM__d2=y,PM__d3=z +} +proc tuple(x,y,z,t)=rec tuple4d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t +} +proc tuple(x,y,z,t,u)=rec tuple5d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u +} +proc tuple(x,y,z,t,u,v)=rec tuple6d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v +} +proc tuple(x,y,z,t,u,v,w)=rec tuple7d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,PM__d7=w +} + +proc dim(t:tuple1d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple2d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple3d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple4d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple5d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple6d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple7d,n:literal(1) or [literal(1)])=t.1 +proc dim(t:tuple2d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple3d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple4d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple5d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple6d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple7d,n:literal(2) or [literal(2)])=t.2 +proc dim(t:tuple3d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple4d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple5d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple6d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple7d,n:literal(3) or [literal(3)])=t.3 +proc dim(t:tuple4d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple5d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple6d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple7d,n:literal(4) or [literal(4)])=t.4 +proc dim(t:tuple5d,n:literal(5) or [literal(5)])=t.5 +proc dim(t:tuple6d,n:literal(5) or [literal(5)])=t.5 +proc dim(t:tuple7d,n:literal(5) or [literal(5)])=t.5 +proc dim(t:tuple6d,n:literal(6) or [literal(6)])=t.6 +proc dim(t:tuple7d,n:literal(6) or [literal(6)])=t.6 +proc dim(t:tuple7d,n:literal(7) or [literal(7)])=t.7 + +proc indices(x:tuple1d)=[literal(1)] +proc indices(x:tuple2d)=[literal(1),literal(2)] +proc indices(x:tuple3d)=[literal(1),literal(2),literal(3)] +proc indices(x:tuple4d)=[literal(1),literal(2),literal(3),literal(4)] +proc indices(x:tuple5d)=[literal(1),literal(2),literal(3),literal(4),literal(5)] +proc indices(x:tuple6d)=[literal(1),literal(2),literal(3),literal(4),literal(5),literal(6)] +proc indices(x:tuple7d)=[literal(1),literal(2),literal(3),literal(4),literal(5),literal(6),literal(7)] + +proc full_rank(x:tuple1d)=1 +proc full_rank(x:tuple2d)=2 +proc full_rank(x:tuple3d)=3 +proc full_rank(x:tuple4d)=4 +proc full_rank(x:tuple5d)=5 +proc full_rank(x:tuple6d)=6 +proc full_rank(x:tuple7d)=7 +proc rank(x:tuple)=full_rank(x) + +proc reduce(p:proc,x:tuple1d)=x.1 +proc reduce(p:proc,x:tuple2d)=p.(x.2,x.1) +proc reduce(p:proc,x:tuple3d)=p.(p.(x.3,x.2),x.1) +proc reduce(p:proc,x:tuple4d)=p.(p.(p.(x.4,x.3),x.2),x.1) +proc reduce(p:proc,x:tuple5d)=p.(p.(p.(p.(x.5,x.4),x.3),x.2),x.1) +proc reduce(p:proc,x:tuple6d)=p.(p.(p.(p.(p.(x.6,x.5),x.4),x.3),x.2),x.1) +proc reduce(p:proc,x:tuple7d)=p.(p.(p.(p.(p.(p.(x.7,x.6),x.5),x.4),x.3),x.2),x.1) + +proc map(p:proc,x:tuple1d)=[p.(x.1)] +proc map(p:proc,x:tuple2d)=[p.(x.1),p.(x.2)] +proc map(p:proc,x:tuple3d)=[p.(x.1),p.(x.2),p.(x.3)] +proc map(p:proc,x:tuple4d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4)] +proc map(p:proc,x:tuple5d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5)] +proc map(p:proc,x:tuple6d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6)] +proc map(p:proc,x:tuple7d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6),p.(x.7)] +proc map(p:proc,x:tuple,y:tuple)=error_type() :test "Number of dimensions does not match" => fix(false) +proc map(p:proc,x:tuple1d,y:tuple1d)=[p.(x.1,y.1)] +proc map(p:proc,x:tuple2d,y:tuple2d)=[p.(x.1,y.1),p.(x.2,y.2)] +proc map(p:proc,x:tuple3d,y:tuple3d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3)] +proc map(p:proc,x:tuple4d,y:tuple4d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4)] +proc map(p:proc,x:tuple5d,y:tuple5d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5)] +proc map(p:proc,x:tuple6d,y:tuple6d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6)] +proc map(p:proc,x:tuple7d,y:tuple7d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6),p.(x.7,y.7)] +proc map(p:proc,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => fix(false) +proc map(p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=[p.(x.1,y.1,z.1)] +proc map(p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2)] +proc map(p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3)] +proc map(p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4)] +proc map(p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5)] +proc map(p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6)] +proc map(p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6),p.(x.7,y.7,z.7)] + +proc map(p:proc,w:tuple,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => fix(false) +proc map(p:proc,w:tuple1d,x:tuple1d,y:tuple1d,z:tuple1d)=[p.(w.1,x.1,y.1,z.1)] +proc map(p:proc,w:tuple2d,x:tuple2d,y:tuple2d,z:tuple2d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2)] +proc map(p:proc,w:tuple3d,x:tuple3d,y:tuple3d,z:tuple3d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3)] +proc map(p:proc,w:tuple4d,x:tuple4d,y:tuple4d,z:tuple4d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4)] +proc map(p:proc,w:tuple5d,x:tuple5d,y:tuple5d,z:tuple5d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5)] +proc map(p:proc,w:tuple6d,x:tuple6d,y:tuple6d,z:tuple6d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6)] +proc map(p:proc,w:tuple7d,x:tuple7d,y:tuple7d,z:tuple7d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6),p.(w.7,x.7,y.7,z.7)] + +proc map(p:proc,x:tuple1d,y:tuple1d)=[u1],[v1]where u1,v1=p.(x.1,y.1) +proc map(p:proc,x:tuple2d,y:tuple2d)=[u1,u2],[v1,v2]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2) +proc map(p:proc,x:tuple3d,y:tuple3d)=[u1,u2,u3],[v1,v2,v3]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3) +proc map(p:proc,x:tuple4d,y:tuple4d)=[u1,u2,u3,u4],[v1,v2,v3,v4]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4) +proc map(p:proc,x:tuple5d,y:tuple5d)=[u1,u2,u3,u4,u5],[v1,v2,v3,v4,v5]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5) +proc map(p:proc,x:tuple6d,y:tuple6d)=[u1,u2,u3,u4,u5,u6],[v1,v2,v3,v4,v5,v6]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),u6,v6=p.(x.6,y.6) +proc map(p:proc,x:tuple7d,y:tuple7d)=[u1,u2,u3,u4,u5,u6,u7],[v1,v2,v3,v4,v5,v6,v7]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),u6,v6=p.(x.6,y.6),u7,v7=p.(x.7,y.7) + +proc map_const(p:proc,x:tuple1d,y)=[p.(x.1,y)] +proc map_const(p:proc,x:tuple2d,y)=[p.(x.1,y),p.(x.2,y)] +proc map_const(p:proc,x:tuple3d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y)] +proc map_const(p:proc,x:tuple4d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y)] +proc map_const(p:proc,x:tuple5d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y)] +proc map_const(p:proc,x:tuple6d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y),p.(x.6,y)] +proc map_const(p:proc,x:tuple7d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y),p.(x.6,y),p.(x.7,y)] + +proc map_reduce(q:proc,p:proc,x:tuple1d)=q.(x.1) +proc map_reduce(q:proc,p:proc,x:tuple2d)=p.(q.(x.2),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d)=p.(p.(q.(x.3),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d)=p.(p.(p.(q.(x.4),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d)=p.(p.(p.(p.(q.(x.5),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d)=p.(p.(p.(p.(p.(q.(x.6),q.(x.5)),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7),q.(x.6)),q.(x.5)),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) + +proc map_reduce(q:proc,p:proc,x:tuple,y:tuple)=error_type() :test "Number of dimensions does not match" => fix(false) +proc map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d)=q.(x.1,y.1) +proc map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d)=p.(q.(x.2,y.2),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d)=p.(p.(q.(x.3,y.3),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d)=p.(p.(p.(q.(x.4,y.4),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d)=p.(p.(p.(p.(q.(x.5,y.5),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d)=p.(p.(p.(p.(p.(q.(x.6,y.6),q.(x.5,y.5)),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7,y.7),q.(x.6,y.6)),q.(x.5,y.5)),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) + +proc map_reduce(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => fix(false) +proc map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=q.(x.1,y.1,z.1) +proc map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=p.(q.(x.2,y.2,z.2),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=p.(p.(q.(x.3,y.3,z.3),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=p.(p.(p.(q.(x.4,y.4,z.4),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=p.(p.(p.(p.(q.(x.5,y.5,z.5),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=p.(p.(p.(p.(p.(q.(x.6,y.6,z.6),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7,y.7,z.7),q.(x.6,y.6,z.6)),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) + +proc apply(p:proc,x:tuple1d)=p.(x.1) +proc apply(p:proc,x:tuple2d)=p.(x.1,x.2) +proc apply(p:proc,x:tuple3d)=p.(x.1,x.2,x.3) +proc apply(p:proc,x:tuple4d)=p.(x.1,x.2,x.3,x.4) +proc apply(p:proc,x:tuple5d)=p.(x.1,x.2,x.3,x.4,x.5) +proc apply(p:proc,x:tuple6d)=p.(x.1,x.2,x.3,x.4,x.5,x.6) +proc apply(p:proc,x:tuple7d)=p.(x.1,x.2,x.3,x.4,x.5,x.6,x.7) + +proc map_apply(q:proc,p:proc,x:tuple1d)=p.(q.(x.1)) +proc map_apply(q:proc,p:proc,x:tuple2d)=p.(q.(x.1),q.(x.2)) +proc map_apply(q:proc,p:proc,x:tuple3d)=p.(q.(x.1),q.(x.2),q.(x.3)) +proc map_apply(q:proc,p:proc,x:tuple4d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4)) +proc map_apply(q:proc,p:proc,x:tuple5d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5)) +proc map_apply(q:proc,p:proc,x:tuple6d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5),q.(x.6)) +proc map_apply(q:proc,p:proc,x:tuple7d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5),q.(x.6),q.(x.7)) + +proc map_apply(q:proc,p:proc,x:tuple,y:tuple)=error_type():test "Number of dimensions does not match" => fix(false) +proc map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d)=p.(q.(x.1,y.1)) +proc map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d)=p.(q.(x.1,y.1),q.(x.2,y.2)) +proc map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3)) +proc map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4)) +proc map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5)) +proc map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5),q.(x.6,y.6)) +proc map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5),q.(x.6,y.6),q.(x.7,y.7)) + +proc map_apply(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => fix(false) +proc map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=p.(q.(x.1,y.1,z.1)) +proc map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2)) +proc map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3)) +proc map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4)) +proc map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5)) +proc map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5),q.(x.6,y.6,z.6)) +proc map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5),q.(x.6,y.6,z.6),q.(x.7,y.7,z.7)) + +proc scan(p:proc,x:tuple1d)=x.1 +proc scan(p:proc,x:tuple2d)=[x.1,p.(x.1,x.2)] +proc scan(p:proc,x:tuple3d)=[x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple4d)=[x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple5d)=[x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple6d)=[x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple7d)=[x.1,x2,x3,x4,x5,x6,p.(x6,x.7)] where x6=p.(x5,x.6) where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) + +proc pre_scan(p:proc,x:tuple1d,x0)=x0 +proc pre_scan(p:proc,x:tuple2d,x0)=[x0,x.1] +proc pre_scan(p:proc,x:tuple3d,x0)=[x0,x.1,p.(x.1,x.2)] +proc pre_scan(p:proc,x:tuple4d,x0)=[x0,x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple5d,x0)=[x0,x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple6d,x0)=[x0,x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple7d,x0)=[x0,x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) + +type empty_head is unique{empty_head} + +proc head(x:null)=empty_head +proc head(x:tuple)=x.1 + +proc tail(x:null)=null +proc tail(x:tuple1d)=null +proc tail(x:tuple2d)=[x.2] +proc tail(x:tuple3d)=[x.2,x.3] +proc tail(x:tuple4d)=[x.2,x.3,x.4] +proc tail(x:tuple5d)=[x.2,x.3,x.4,x.5] +proc tail(x:tuple6d)=[x.2,x.3,x.4,x.5,x.6] +proc tail(x:tuple7d)=[x.2,x.3,x.4,x.5,x.6,x.7] + +proc prepend(y,x:null)=[y] +proc prepend(y,x:tuple1d)=[y,x.1] +proc prepend(y,x:tuple2d)=[y,x.1,x.2] +proc prepend(y,x:tuple3d)=[y,x.1,x.2,x.3] +proc prepend(y,x:tuple4d)=[y,x.1,x.2,x.3,x.4] +proc prepend(y,x:tuple5d)=[y,x.1,x.2,x.3,x.4,x.5] +proc prepend(y,x:tuple6d)=[y,x.1,x.2,x.4,x.4,x.5,x.6] +proc prepend(y,x:tuple7d)=error_type() :test "Cannot add dimension to 7d tuple" => fix(false) + +proc append(x:null,y)=[y] +proc append(x:tuple1d,y)=[x.1,y] +proc append(x:tuple2d,y)=[x.1,x.2,y] +proc append(x:tuple3d,y)=[x.1,x.2,x.3,y] +proc append(x:tuple4d,y)=[x.1,x.2,x.3,x.4,y] +proc append(x:tuple5d,y)=[x.1,x.2,x.3,x.4,x.5,y] +proc append(x:tuple6d,y)=[x.1,x.2,x.4,x.4,x.5,x.6,y] +proc append(y,x:tuple7d)=error_type() :test "Cannot add dimension to 7d tuple" => fix(false) + +proc elems(x:tuple1d)=x.1 +proc elems(x:tuple2d)=x.1,x.2 +proc elems(x:tuple3d)=x.1,x.2,x,3 +proc elems(x:tuple4d)=x.1,x.2,x.3,x.4 +proc elems(x:tuple5d)=x.1,x.2,x.3,x.4,x.5 +proc elems(x:tuple6d)=x.1,x.2,x.3,x.4,x.5,x.6 +proc elems(x:tuple7d)=x.1,x.2,x.3,x.4,x.5,x.6,x.7 + +proc replace(x:tuple1d,y:literal(1),z)=[z] +proc replace(x:tuple2d,y:literal(1),z)=[z,x.2] +proc replace(x:tuple3d,y:literal(1),z)=[z,x.2,x.3] +proc replace(x:tuple4d,y:literal(1),z)=[z,x.2,x.3,x.4] +proc replace(x:tuple5d,y:literal(1),z)=[z,x.2,x.3,x.4,x.5] +proc replace(x:tuple6d,y:literal(1),z)=[z,x.2,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:literal(1),z)=[z,x.2,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple2d,y:literal(2),z)=[x.1,z] +proc replace(x:tuple3d,y:literal(2),z)=[x.1,z,x.3] +proc replace(x:tuple4d,y:literal(2),z)=[x.1,z,x.3,x.4] +proc replace(x:tuple5d,y:literal(2),z)=[x.1,z,x.3,x.4,x.5] +proc replace(x:tuple6d,y:literal(2),z)=[x.1,z,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:literal(2),z)=[x.1,z,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple3d,y:literal(3),z)=[x.1,x.2,z] +proc replace(x:tuple4d,y:literal(3),z)=[x.1,x.2,z,x.4] +proc replace(x:tuple5d,y:literal(3),z)=[x.1,x.2,z,x.4,x.5] +proc replace(x:tuple6d,y:literal(3),z)=[x.1,x.2,z,x.4,x.5,x.6] +proc replace(x:tuple7d,y:literal(3),z)=[x.1,x.2,z,x.4,x.5,x.6,x.7] +proc replace(x:tuple4d,y:literal(4),z)=[x.1,x.2,x.3,z] +proc replace(x:tuple5d,y:literal(4),z)=[x.1,x.2,x.3,z,x.5] +proc replace(x:tuple6d,y:literal(4),z)=[x.1,x.2,x.3,z,x.5,x.6] +proc replace(x:tuple7d,y:literal(4),z)=[x.1,x.2,x.3,z,x.5,x.6,x.7] +proc replace(x:tuple5d,y:literal(5),z)=[x.1,x.2,x.3,x.4,z] +proc replace(x:tuple6d,y:literal(5),z)=[x.1,x.2,x.3,x.4,z,x.6] +proc replace(x:tuple7d,y:literal(5),z)=[x.1,x.2,x.3,x.4,z,x.6,x.7] +proc replace(x:tuple6d,y:literal(6),z)=[x.1,x.2,x.3,x.4,x.5,z] +proc replace(x:tuple7d,y:literal(6),z)=[x.1,x.2,x.3,x.4,x.5,z,x.7] +proc replace(x:tuple7d,y:literal(7),z)=[x.1,x.2,x.3,x.4,x.5,x.6,z] + +proc spread(x,y:tuple1d or literal(1))=[x] +proc spread(x,y:tuple2d or literal(2))=[x,x] +proc spread(x,y:tuple3d or literal(3))=[x,x,x] +proc spread(x,y:tuple4d or literal(4))=[x,x,x,x] +proc spread(x,y:tuple5d or literal(5))=[x,x,x,x,x] +proc spread(x,y:tuple6d or literal(6))=[x,x,x,x,x,x] +proc spread(x,y:tuple7d or literal(7))=[x,x,x,x,x,x,x] + +proc +(x:tuple(num),y:tuple(num))=map($+,x,y) + +proc -(x:tuple(num),y:tuple(num))=map($-,x,y) +proc *(x:tuple(num),y:tuple(num))=map($*,x,y) +proc /(x:tuple(num),y:tuple(num))=map($/,x,y) +proc **(x:tuple(num),y:tuple(num))=map($**,x,y) +proc mod(x:tuple(num),y:tuple(num))=map($mod,x,y) +proc +(x:tuple(num),y:num)=map_const($+,x,y) +proc -(x:tuple(num),y:num)=map_const($-,x,y) +proc *(x:tuple(num),y:num)=map_const($*,x,y) +proc /(x:tuple(num),y:num)=map_const($/,x,y) +proc **(x:tuple(num),y:num)=map_const($**,x,y) +proc mod(x:tuple(num),y:num)=map_const($mod,x,y) +proc max(x:tuple(real_num),y:tuple(real_num))=map($max,x,y) +proc min(x:tuple(real_num),y:tuple(real_num))=map($min,x,y) +proc max(x:tuple(real_num))=reduce($max,x) +proc min(x:tuple(real_num))=reduce($min,x) +proc sum(x:tuple(num))=reduce($+,x) +proc prod(x:tuple(num))=reduce($*,x) +proc sint(x:tuple(num))=map($sint,x) +proc int(x:tuple(num))=map($int,x) +proc sreal(x:tuple(num))=map($sreal,x) +proc real(x:tuple(num))=map($real,x) + +proc string(x:tuple1d)="[ "++x.1++" ]" +proc string(x:tuple2d)="[ "++x.1++", "++x.2++" ]" +proc string(x:tuple3d)="[ "++x.1++", "++x.2++", "++x.3++" ]" +proc string(x:tuple4d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++" ]" +proc string(x:tuple5d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++" ]" +proc string(x:tuple6d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++" ]" +proc string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++", "++x.7++" ]" + +// ***************************************************** +// RANGES AND SEQUENCES +// ***************************************************** + +// Partial ranges and sequences for slicing +type underscore is unique{PM__underscore} +type _subscript is any_int,range(any_int),seq(any_int,any_int),underscore,range_below(any_int),range_above(any_int),seq_above(any_int,any_int), seq_below(any_int,any_int), seq_stride(any_int) +type subscript is _subscript or tuple(subscript) +type extent(ndim:dimension_number) is tuple(range(int),dimension_number) + +proc complete(x:extent,y:subscript)=_complete(x,y) check "Subscript "++y++" is out of bounds "++x=>y in x +proc _complete(x:tuple1d,y:_subscript)=_complete(x.1,y) +proc _complete(x:range(int),y:any_int)=int(y) +proc _complete(x:range(int),y:range(any_int))=int(y) +proc _complete(x:range(int),y:seq(any_int,any_int))=int(y) +proc _complete(x:range(int),y:underscore)=x +proc _complete(x:range(int),y:range_below(any_int))=low(x)..int(y._t) +proc _complete(x:range(int),y:range_above(any_int))=int(y._t)..high(x) +proc _complete(x:range(int),y:seq_below(any_int))=low(x)..int(y._t) by int(y._st) +proc _complete(x:range(int),y:seq_above(any_int))=int(y._t)..high(x) by int(y._st) +proc _complete(x:range(int),y:seq_step(any_int))=x by int(y._st) +proc _complete(x,y)=map($_complete,x,y) check "Subscript has incorrect rank"=>rank(x)==rank(y) + +type range_below(x:range_base) is rec {_t:x} +type range_above(x:range_base) is rec {_t:x} +type seq_below(x:range_base,s:step_base) is rec {_t:x,_st:step_base} +type seq_above(x:range_base,s:step_base) is rec {_t:x,_st:step_base} +type seq_step(x:step_base) is rec {_st:step_base} +proc ..(x:underscore,y:range_base)=rec range_below{_t=x} +proc ..(x:range_base,y:underscore)=rec range_above{_t=x} +proc by(x:range_below,y:step_base)=rec seq_below{_t=x,_st=y} +proc by(x:range_above,y:step_base)=rec seq_above{_t=x,_st=y} +proc by(x:underscore,y:step_base)=rec seq_step{_st=y} +proc string(x:range_below)="_.."++x._t +proc string(x:range_above)=x._t++".._" +proc string(x:seq_below)="_.."++x._t++" by "++x._st +proc string(x:seq_above)=x._t++".._ by "++x._st +proc string(x:seq_step)="_ by "++x._st +proc low(x:range_below or seq_below or seq_step)=_ +proc high(x:range_above or seq_above or seq_step)=_ +proc step(x:range_above or range_below)=literal(1) +proc low(x:range_above or seq_above)=x._t +proc high(x:range_below or seq_below)=x._t +proc step(x:seq_above or seq_below or seq_step)=x._st + +// Not in operator +proc notin(x,y)=not(x in y) + +// not inc operator +proc notinc(x,y)=not(x inc y) + +// Treat null as empty sequence in some cases +proc in(x,y:null)=literal(false) +proc in(x:null,y:null)=literal(true) + +// Range base type (might later expand to interface) +type range_base is real_num +type step_base is real_num + +// Range types +type range(t:range_base) is rec {_lo:t,_hi:t,_n:t} +proc ..(x:range_base,y:range_base)=rec range { +_lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) +proc low(x:range)=x._lo +proc high(x:range)=x._hi +proc step(x:range)=convert(1,x._lo) +proc width(x:range)=literal(1) +proc norm(x:range)=x +proc #'(x:range(int))=[0..x._n-1] +proc dims(x:range(int))=[x._n] +proc size(x:range(int))=x._n +proc +(x:range,y:range_base)=rec range { + _lo=x._lo+y,_hi=x._hi+y,_n=x._n +} +proc -(x:range,y:range_base)=rec range { + _lo=x._lo-y,_hi=x._hi-y,_n=x._n +} +proc _arb(x:range)=low(x) +proc in(x:range_base,y:range())=x>=y._lo and x<=y._hi +proc convert(x:range,y:range_base)=rec range { + _lo=convert(x._lo,y),_hi=convert(x._hi,y),_n=x._n +} +proc sint(x:range)=rec range { + _lo=sint(x._lo),_hi=sint(x._hi),_n=x._n +} +proc int(x:range)=rec range { + _lo=int(x._lo),_hi=int(x._hi),_n=x._n +} +proc sreal(x:range)=rec range { + _lo=sreal(x._lo),_hi=sreal(x._hi) +} +proc real(x:range)=rec range { + _lo=real(x._lo),_hi=real(x._hi),_n=x._n +} +proc inc(x:range,y:seq())= low(y)>=x._lo and high(y)<=x._hi +proc element(x:range(any_int),y:int)=x._lo+convert(y,x._lo) +proc element(x:range(any_int),y:range(int))=element(x,y._lo)..element(x,y._hi) +proc element(x:range(any_int),y:seq(int))=element(x,y._lo)..element(x,y._hi) by y._st +proc element(x:range(any_int),y:null)=x +proc element(x:range(any_int),y:any_seq)=y+x._lo +proc #'(y:range(any_int),x:int)=int(x-y._lo) +proc #'(y:range(any_int),x:range(int))=int(x._lo-y._lo)..int(x._hi-y._lo) +proc #'(y:range(any_int),x:seq(int))=_intseq(int(x._lo-y._lo),int(x._hi-y._lo), x._st) +proc #'(y:range(any_int),x:range_below(int))=0..int(x._t-y._lo) +proc #'(y:range(any_int),x:range_above(int))=int(x._t-y._lo)..size(y)-1 +proc #'(y:range(any_int),x:seq_below(int))=_intseq(0,int(x._t-y._lo),x._st) +proc #'(y:range(any_int),x:seq_above(int))=_intseq(int(x._t-y._lo),size(y)-1,int(x._st)) +proc #'(y:range(any_int),x:seq_step(int))=_intseq(0,size(y),int(x._st)) +proc #'(y:range(any_int),x:null)=0..size(y) +proc intersect(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)..min(y._hi,x._hi) +proc overlap(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)-x._lo..min(y._hi,x._hi)-x._lo +proc expand(x:range,y:range)=x._lo+y._lo..x._hi+y._hi +proc contract(x:range,y:range)=x._lo-y._lo..x._hi-y._hi +proc empty(x:range)=rec range { + _lo=x._hi,_hi=x._lo,_n=0 +} +proc string(x:range)=string(x._lo)++".."++(x._hi) + +// Sequence (strided range) types +type seq(t:range_base,s:step_base) is rec {_lo:t,_hi:t,_st:s,_n:int} +proc _seq(lo,hi,st)=rec seq { +_lo=lo,_hi=lo+(n-1)*st,_st=st,_n=n}check "Zero step size in strided range"=>st/=0 where n=max(0,1+_rdiv(int((hi-lo)),int(st))) +proc by(x:range(int),y:range_base)=_seq(lo,hi,st) where hi=convert(x._hi,lo) where lo,st=balance(x._lo,y) +proc by(x:seq,y:range_base)=_seq(lo,hi,st) where lo=convert(x._lo,st),hi=convert(x._hi,st) where st=x._st*y +proc _intseq(x:int,y:int,st:int)= rec seq { +_lo=x,_hi=x+n*s,_st=s,_n=n} where s=if(x>y=>-abs(st),abs(st)) where n=abs((y-x)/st) +proc low(x:seq)=x._lo +proc high(x:seq)=x._hi +proc step(x:seq)=x._st +proc size(x:seq)=x._n +proc width(x:seq)=literal(1) +proc norm(x:seq)=min(lo,hi)..max(lo,hi) by abs(x._st)where hi=lo+(x._n-1)*x._st where lo=x._lo +proc align(x:seq)=literal(0) +proc #'(x:seq)=[0..x._n-1] +proc dims(x:seq)=[x._n] +proc +(x:seq,y:range_base)=rec seq { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_n=x._n +} +proc -(x:seq,y:range_base)=rec seq { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_n=x._n +} +proc _arb(x:seq)=x._lo +proc convert(x:seq,y:range_base)=rec seq { + _lo=convert(x._lo,y),_hi=convert(x._hi,y),_st=convert(x._st,y),_n=x._n +} +proc sint(x:seq)=rec seq { + _lo=sint(x._lo),_hi=sint(x._hi),_st=sint(x._st),_n=x._n +} +proc int(x:seq)=rec seq { + _lo=int(x._lo),_hi=int(x._hi),_st=int(x._st),_n=x._n +} +proc sreal(x:seq)=rec seq { + _lo=sreal(x._lo),_hi=sreal(x._hi),_st=sreal(x._st),_n=x._n +} +proc real(x:seq)=rec seq { + _lo=real(x._lo),_hi=real(x._hi),_st=real(x._st),_n=x._n +} +proc in(x:int,y:seq(int))=y._lo<=x and x<=y._hi and (x-y._lo) mod y._st==0 +proc inc(x:seq(int),y:seq(int))=y._lo in x and y._hi in x and (y._n==1 or y._lo+y._st in x) +proc inc(x:seq(int),y:range(int))=x inc low(y)..high(y) by 1 +proc #'(y:seq,x:range_base)=int((x-y._lo)/y._st) +proc #'(y:seq,x:range)=y#x._lo..y#x._hi +proc #'(y:seq,x:seq)=_intseq(lo,hi,int(x._st)) where lo=y#x._lo,hi=y#x._hi +proc #'(y:seq,x:range_below)=0..y#x._t +proc #'(y:seq,x:range_above)=y#x._t..size(y)-1 +proc #'(y:seq,x:seq_below)=_intseq(0,y#x._t,int((x._st+y._st/2)/y._st)) +proc #'(y:seq,x:seq_above)=_intseq(y#x._t,size(y)-1,int((x._st+y._st/2)/y._st)) +proc #'(y:seq,x:seq_step)=_intseq(0,size(y),int((x._st+y._st/2)/y._st)) +proc #'(y:seq,x:null)=0..size(y)-1 +proc string(x:seq)=x._lo++".."++x._hi++" by "++x._st +proc element(x:seq,y:int)=x._lo+convert(y,x._lo)*x._st +proc element(x:seq,y:range(int))=_seq(element(x,y._lo),element(x,y._hi),x._st) +proc element(x:seq,y:seq(int))=_seq(element(x,y._lo),element(x,y._hi),convert(st*y._st,st)) where st=x._st +proc element(x:seq,y:null)=x +proc overlap(x:seq(any_int),y:range(any_int))= max(0,(y._lo-x._lo+x._st-1)/x._st)..min(x._n,(y._hi-x._lo)/x._st) +proc overlap(x:range(any_int),y:seq(any_int))=max((-d+y._st-1)/y._st*y._st+d,d)..min(x._n,y._hi-x._lo) by y._st where d=y._lo-x._lo +proc intersect(x:seq(any_int),y:range(any_int))=x._lo+max(convert(0,n1),n1)*x._st..x._lo+min(convert(x._n,n2),n2)*x._st by x._st where n1=(y._lo-x._lo+x._st-1)/x._st,n2=(y._hi-x._lo)/x._st +proc intersect(x:range(any_int),y:seq(any_int))=intersect(y,x) +PM__intrinsic _intersect_seq(int,int,int,int,int,int,int,int)->(int,int,int,int) : "intersect_seq" +proc intersect(x:seq(any_int),y:seq(any_int))=rec seq { +_lo=lo,_hi=hi,_st=st,_n=n}where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),int(y._lo),int(y._hi),int(y._st),int(y._n)) +proc overlap(x:seq(any_int),y:seq(any_int))=rec seq { +_lo=(lo-x._lo)/x._st,_hi=(hi-x._lo)/x._st,_st=if(sst/=0=>sst,1),_n=n} where sst=st/x._st where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n), int(y._lo),int(y._hi),int(y._st),int(y._n)) +proc empty(x:seq(any_int))=rec seq { + _lo=x._hi,_hi=x._lo,_st=x._st,_n=0 +} + +// Block sequence +type block_seq is rec { _lo:int,_hi:int,_st:int,_b:int,_n:int,_align:int} +proc block_seq(lo:int,hi:int,st:int,b:int,align:int){ + test "Block sequence width must be non-negative: "++b=>b>=0 + test "Block sequence width must be less than step: "++b++">="++st=>b<=st + test "Block sequence alignment must be less that width: "++align++">="++b=>align1..0,x._lo..x._lo-x._align+x._b-1) +proc last_block(x:block_seq)=low..min(low+x._b,x._hi) where low=x._lo-x._align+nb*x._st where nb=(x._hi-x._lo+x._align+x._st-x._b+1)/x._st +proc middle_blocks(x:block_seq)=rec block_seq { +_lo=low,_hi=low+nb*x._st-1,_st=x._st,_b=x._b,_n=nb*x._b,_align=0}where nb=(x._hi-low+x._st-x._b+1)/x._st where low=if(x._align==0=>x._lo,x._lo-x._align+x._st) +proc string(x:block_seq)=x._lo++".."++x._hi++" by "++x._st++" width "++x._b++" align "++x._align +proc low(x:block_seq)=x._lo +proc high(x:block_seq)=x._hi +proc step(x:block_seq)=x._st +proc width(x:block_seq)=x._b +proc norm(x:block_seq)=x +proc align(x:block_seq)=x._align +proc #'(x:block_seq)=[0..x._n-1] +proc dims(x:block_seq)=x._n +proc size(x:block_seq)=x._n +proc +(x:block_seq,y:int)=rec block_seq { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc -(x:block_seq,y:int)=rec block_seq { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc _arb(x:block_seq)=x._lo +proc in(x:int,y:block_seq)=x>=y._lo and x<=y._hi and (x-y._lo+y._align) mod y._st=x._b:lo=nblo+x._st + if hi-nbhi>=x._b:hi=nbhi+x._b-1 + let align=base-(base/x._st)*x._st where base=lo-oldbase + return block_seq(lo,hi,x._st,x._b,align) +} + +proc intersect(x:range(any_int),y:block_seq)=intersect(y,x) +proc overlap(x:range(any_int),y:block_seq) { + let z=intersect(y,x) + return block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) +} +proc overlap(x:block_seq,y:range(any_int)) { + let z=intersect(x,y) + return start..start+size(z)-1 where start=z#z._lo +} +proc overlap(x:block_seq,y:range(any_int)) { + let z=intersect(x,y) + return start..start+size(z)-1, block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) where start=z#z._lo +} +proc overlap(x:range(any_int),y:block_seq)=xx,yy where yy,xx=overlap(y,x) +proc empty(x:block_seq)=block_seq(1,0,1,1,0) + +/* +// Mapped sequence +type map_seq(t:array(int)) is rec {array:t} +proc map_seq(x:any_seq){ + var a=array(0,#x) + forall i in a,j in x:i=j + return rec map_seq{ + array=a + } +} +proc map_seq(x:array(int,mshape1d))=rec map_seq { +array=x} check "Array for ""map_seq"" must be strictly increasing or stricly decreasing"=>_mono(x) +proc _mono(x) { + /* + xs=#x + var ok=true + if x[low(xs.1)]x[i-1]:sync ok=false + } + return ok +*/ +} +proc map_seq(x:map_seq)=x +proc #'(x:map_seq)=#'(x.array) +proc dims(x:map_seq)=size(x.array) +proc size(x:map_seq)=size(x.array) +proc +(x:map_seq,y:range_base)=rec map_seq{ + array=x.array+y +} +proc -(x:map_seq,y:range_base)=rec map_seq{ + array=x.array-y +} +proc _arb(x:map_seq)=_arb(x.array) +proc element(x:map_seq,y:int)=element(x.array,y) +PM__intrinsic _intersect_aseq(&any,any,any,any,any,&any): "intersect_aseq" +PM__intrinsic _overlap_aseq(&any,any,any,any,any,&any): "intersect_aseq"(1) +PM__intrinsic _overlap_aseq2(&any,any,any,any,any,&any,&any): "intersect_aseq"(2) +PM__intrinsic _expand_aseq(&any,any,any,&any,any,any): "expand_aseq" +PM__intrinsic _intersect_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq" +PM__intrinsic _overlap_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(1) +PM__intrinsic _overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(2) +PM__intrinsic _includes_aseq(any,any,any,any)->(bool) : "includes_aseq" +PM__intrinsic _index_aseq(any,any,any)->(int) : "index_aseq" +PM__intrinsic _in_aseq(any,any,any)->(bool) : "in_aseq" +proc intersect(x:block_seq,y:block_seq)=intersect(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=overlap(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=v,w where v,w=overlap(map_seq(x),map_seq(y)) +proc intersect(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _intersect_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=rec map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=rec map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var b=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq2(&n,x.array,size(x.array),y.array,size(y.array),&a,&b) + ns=[0..n-1] + v=rec map_seq { + array=a[ns] + } + w=rec map_seq { + array=b[ns] + } + return v,w +} +proc overlap(x:seq,y:seq)=overlap(x,y),overlap(y,x) +proc expand(t:map_seq,i:range(any_int)) { + var a=array(0,[0..max(1,size(t)*max(1,size(i))-1)]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i)) + v=rec map_seq { + array=a[0..m-1] + } + return v +} +proc inc(x:map_seq,y:map_seq)=_includes_aseq(x.array,size(x.array),y.array,size(y.array)) +proc inc(x:map_seq,y:seq or block_seq)=x inc map_seq(y) +proc inc(x:block_seq,y:block_seq)=map_seq(x) inc map_seq(y) +proc inc(x:seq or block_seq,y:map_seq)=map_seq(x) inc y +proc in(y:any_int,x:map_seq)=_in_aseq(x.array,size(x.array),int(y)) +proc #'(x:map_seq,y:any_int)=_index_aseq(x.array,size(x.array),int(y)) +proc empty(x:map_seq) { + a=array(0,[1..0]) + return rec map_seq { + array=a + } +} +*/ +proc map_seq(x)=x +proc _rdiv(x,y)=if(y<0=>if(x<0=>x/y,(y-x+1)/y),x>0=>x/y,(x-y+1)/y) + + +type any_seq is range(int),seq(int,int),block_seq // , map_seq + +// Grids (tuples of sequences) +type _gdim is any_seq or int +type grid1d(t1:_gdim) is [t1] except [int] +type grid2d(t1:_gdim,t2:_gdim) is [t1,t2] except [int,int] +type grid3d(t1:_gdim,t2:_gdim,t3:_gdim) is [t1,t2,t3] except [int,int,int] +type grid4d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim) is [t1,t2,t3,t4] except [int,int,int,int] +type grid5d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim,t5:_gdim) is [t1,t2,t3,t4,t5] except [int,int,int,int,int] +type grid6d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim,t5:_gdim,t6:_gdim) is [t1,t2,t3,t4,t5,t6] except [int,int,int,int,int,int] +type grid7d(t1:_gdim,t2:_gdim,t3:_gdim,t4:_gdim,t5:_gdim,t6:_gdim,t7:_gdim) is [t1,t2,t3,t4,t5,t6,t7] except [int,int,int,int,int,int,int] +type grid(ndim:dimension_number) is tuple(_gdim,ndim) except tuple(int,ndim) + +PM__intrinsic _shp(x:int)->(PM__tinyint) : "miss_arg" +proc _shp(x)=0..size(x)-1 +proc _sliceit(...)=tuple(...) +proc #'(x:grid)=map_apply($_shp,$_sliceit,x) +PM__intrinsic _size(x:int)->(PM__tinyint) : "miss_arg" +proc _size(x)=x +proc dims(x:grid)=map_apply($_shp,$_sliceit,x) +proc +(x:grid,y:tuple(range_base))=map($+,x,y) +proc -(x:grid,y:tuple(range_base))=map($-,x,y) +proc empty(x:grid)=map($empty,x) +proc element(x:tuple(any_seq),y)=map($element,x,y) +proc element(x:grid,y)=_gel(head(x),tail(x),head(y),tail(y)) +proc _gel(x:_gdim,xx,y,yy)=prepend(element(x,y),_gel(head(xx),tail(xx),head(yy),tail(yy))) +proc _gel(x:int,xx,y,yy)=prepend(x,_gel(head(xx),tail(xx),y,yy)) +proc _gel(x:empty_head,xx,y:empty_head,yy)=null +proc _gel(x:empty_head,xx,y,yy)=error_type():test "Rank mismatch"=>fix(false) + + + +// ************************************** +// ARRAYS +// ************************************** + +/* +// Array types +type array(e,d:shape) is varray(e,d),farray(e,d) +type varray(e,d:shape) is e^var d,array_template(e,d,fix(true)) +type farray(e,d:shape) is e^let d,e^invar d,e^fix d,array_template(e,d,fix(false)) +type farray(e,d:mshape) is ..., + array_slice(e^let any),array_slice(e^var any),array_slice(e^invar any),array_slice(e^fix any) + +// Array operations +proc _arb(x:any^mshape)=_get_aelem(x,0) +PM__if_compiling +proc size(x:any^mshape)=size(#x) +PM__else +PM__intrinsic size(x:any^mshape)->(int) : "get_size" +PM__endif + +PM__intrinsic<> _array(x:any,y:any,z:any,v:fix(false))->(=x) : "array" +PM__intrinsic<> _array(x:any,y:any,z:any,v:fix(true))->(=x) : "var_array" +PM__intrinsic<> _redim(x:any^any,y:any)->(=x) : "redim" +PM__intrinsic<> PM__dim_noinit(x:any,y:any,z:any)->(=x) : "array_noinit" +proc #%(x:invar any^any)=_array_shape(x <>) +proc #%(x)=_get_shape(x) +proc _get_shape(x)=#x +proc #'(x:any^any)=_array_shape(x) +PM__intrinsic _array_shape(x:any^any)->(=x) : "get_dom" +proc dims(x:any^mshape)=dims(#x) +PM__intrinsic PM__extractelm(x:any^any)->(=x) : "extractelm" +proc element(a:any^mshape,t:index)=_get_aelem(a,index(#(a),t)) +proc _set_elem(&a:any^mshape,v,t:index){ + PM__setaelem(&a,index(#(a),t),v) +} + +proc _make_subref(a:any^mshape,t:index)=_make_subref(a,index(#(a),t)) +PM__intrinsic _make_subref(a:any^mshape,i:int)->(=a) : "make_rf" +PM__intrinsic _get_aelem(x:any^any,y:int)->(=x) : "array_get_elem" +PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" + +*/ + +type _mshape(ndim,contig:literal(bool)) is rec {_extent:extent(ndim),_m:tuple(int,ndim),_n:int,_o:int,_c:contig} + +proc _mshape(g:extent(1))=rec _mshape{_extent=g,_m=[1],_n=size(g.1),_o=0,_c=true} +proc _mshape(g:extent(2))=rec _mshape{_extent=g,_m=[1,s1],_n=s1*size(g.2),_o=0,_c=true} where s1=size(g.1) +proc _mshape(g:extent(3))=rec _mshape{_extent=g,_m=[1,s1,s2],_n=s2*size(g.3),_o=0,_c=true} where s2=s1*size(g.2) where s1=size(g.1) +proc _mshape(g:extent(4))=rec _mshape{_extent=g,_m=[1,s1,s3,s3],_n=s3*size(g.4),_o=0,_c=true} where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) +proc _mshape(g:extent(5))=rec _mshape{_extent=g,_m=[1,s1,s2,s3,s4],_n=s4*size(g.5),_o=0,_c=true} where s4=s3*size(g.4) where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) + +proc _mshape(g:extent(6))=rec _mshape{_extent=g,_m=[1,s1,s2,s3,s4,s5],_n=s5*size(g.6),_o=0,_c=true} where s5=s4*size(g.5) where s4=s3*size(g.4) where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) +proc _mshape(g:extent(7))=rec _mshape{_extent=g,_m=[1,s1,s2,s3,s4,s5,s6],_n=s6*size(g.7),_o=0,_c=true} where s6=s5*size(g.6) where s5=s4*size(g.5) where s4=s3*size(g.4) where s3=s2*size(g.3) where s2=s1*size(g.2) where s1=size(g.1) + +/* +proc _point2index(g:_mshape,p:tuple(any_int))=_point2index(g,int(p)) +proc _point2index(g:_mshape(1,true),p:tuple(int,1))=g._o+g._m.1*p.1 +proc _point2index(g:_mshape(2,true),p:tuple(int,2))=g._o+g._m.1*p.1+g._m.2*p.2 +proc _point2index(g:_mshape(3,true),p:tuple(int,3))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3 +proc _point2index(g:_mshape(4,true),p:tuple(int,4))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4 +proc _point2index(g:_mshape(5,true),p:tuple(int,5))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5 +proc _point2index(g:_mshape(6,true),p:tuple(int,6))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6 +proc _point2index(g:_mshape(7,true),p:tuple(int,7))=g._o+g._m.1*p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6+g._m.7*p.7 +proc _point2index(g:_mshape(1,false),p:tuple(int,1))=g._o+p.1 +proc _point2index(g:_mshape(2,false),p:tuple(int,2))=g._o+p.1+g._m.2*p.2 +proc _point2index(g:_mshape(3,false),p:tuple(int,3))=g._o+p.1+g._m.2*p.2+g._m.3*p.3 +proc _point2index(g:_mshape(4,false),p:tuple(int,4))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4 +proc _point2index(g:_mshape(5,false),p:tuple(int,5))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5 +proc _point2index(g:_mshape(6,false),p:tuple(int,6))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6 +proc _point2index(g:_mshape(7,false),p:tuple(int,7))=g._o+p.1+g._m.2*p.2+g._m.3*p.3+g._m.4*p.4+g._m.5*p.5+g._m.6*p.6+g._m.7*p.7 +proc _point2index(g:_mshape,p:tuple(int))=0 check "Rank mismatch in array index"=>fix(false) +*/ + +// Linear index of tuple mshape (zero base,unit stride) +proc _indx(g:range(int),s)=int(s) +proc _indx(g:any_int,s)=int(s) +proc _sz(x:int)=x +proc _sz(x:range(int))=x._n +proc _point2index(g:tuple(int,1) or extent(1),s:any_int)=int(_indx(g.1,s)) +proc _point2index(g:tuple(int,1) or extent(1),s:tuple(any_int,1))=int(_indx(g.1,s.1)) +proc _point2index(g:tuple(int,2) or extent(2),s:tuple(any_int,2))=int(_indx(g.1,s.1)+_sz(g.1)*_indx(g.2,s.2)) +proc _point2index(g:tuple(int,3) or extent(3),s:tuple(any_int,3))=int(_indx(g.1,s.1)+_sz(g.1)*(_indx(g.2,s.2)+_sz(g.2)*_indx(g.3,s.3))) +proc _point2index(g:tuple(int,4) or extent(4),s:tuple(any_int,4))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* _indx(g.4,s.4)))) +proc _point2index(g:tuple(int,5) or extent(5),s:tuple(any_int,5))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* _indx(g.5,s.5))))) +proc _point2index(g:tuple(int,6) or extent(6),s:tuple(any_int,6))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* _indx(g.6,s.6)))))) +proc _point2index(g:tuple(int,7) or extent(7),s:tuple(any_int,7))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* (_indx(g.6,s.6)+_sz(g.6)* (_indx(g.7,s.7)))))))) + +proc _index2point(i:int,s:range(int))=[i+s._lo] +proc _index2point(i:int,s:int)=[i] +proc _index2point(i:int,s:tuple(int,1))=[i] +proc _index2point(i:int,s:tuple(int,2))=[i1,i2] where i1=i-i2*_sz(s.1) where i2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,3))=[i1,i2,i3] where i1=i-j2*_sz(s.1) where i2=j2-i3*_sz(s.2) where i3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,4))=[i1,i2,i3,i4] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-i4*_sz(s.3) where i4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,5))=[i1,i2,i3,i4,i5] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-i5*_sz(s.4) where i5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,6))=[i1,i2,i3,i4,i5,i6] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-i6*_sz(s.5) where i6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc _index2point(i:int,s:tuple(int,7))=[i1,i2,i3,i4,i5,i6,i7] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-j6*_sz(s.5) where i6=j6-i7*_sz(s.6) where i7=j6/_sz(s.6) where j6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) + +/* +// Numeric array operations +proc -(x:num^any)={ + -xx:xx in x +} +proc +(x:num^any,y:num)={ + xx+y:xx in x +} +proc -(x:num^any,y:num)={ + xx-y:xx in x +} +proc *(x:num^any,y:num)={ + xx*y:xx in x +} +proc *(x:num,y:num^any)={ + x*yy:yy in y +} +proc /(x:num^any,y:num)={ + xx/y:xx in x +} + + +// ***************************************** +// ARRAY TEMPLATES +// ***************************************** +// Array templates +type array_template(a,d:mshape or dshape,v:fix(bool)) is rec {_a:a,_d:d,_s:int,_v:v} +proc array(a:any,s:dshape)=rec array_template { + _a=a,_d=s,_s=s._size,_v=fix(false) +} +proc array(a:any,s:mshape(tuple(range(int))))=rec array_template { + _a=a,_d=s,_s=size(s),_v=fix(false) +} +proc array(a:any,s:tuple(range(any_int)))=array(a,shape(s)) +proc varray(a:any,s:mshape or dshape)=rec array_template { + _a=a,_d=s,_s=size(s),_v=fix(true) +} +proc varray(a:any,s:tuple(range(any_int)))=varray(a,shape(s)) +proc _zero(x)=0 +proc varray(a:any,s:tuple(null))=varray(a,shape(map($_zero,s))) +// Treat a template as if it were an array +proc _arb(a:array_template)=a._a +proc #(a:array_template(,mshape,))=a._d +proc dims(a:array_template(,mshape,))=dims(a._d) +proc size(a:array_template)=a._s +proc redim(a:array_template,d:mshape)= rec array_template { +_a=a,_d=d,_s=size(d),_v=a._v} check "New dshape does not have same size in redim"=> size(d)==a._s +proc element(a:array_template,...:subs)=a._a +// Array creation from template + +proc PM__dup(a:array_template(,shape,))=_array(PM__dup(a._a),a._d,int(a._s),a._v) +proc PM__dup(a:array_template(,shape,fix(true)))=_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v) +proc PM__do_dim(a:any,d:mshape)=_array(a,d,size(d),fix(false)) + +*/ + +// *************************************************** +// LOOPS AND PARALLEL STATEMENTS +// *************************************************** + +proc PM__for_stmt'(&PM__inout_a,PM__in_a,PM__star_a,shape) yield(&any,any,any) <> { + PM__for shape { + here_in_tile=PM__generate(shape,shape) + PM__context PM__topology,PM__outer,PM__region,PM__schedule,here_in_tile,PM__mask { + var inouts=PM__import(PM__inouts) + var inout_a=PM__get_elem(PM__inout_a,here_in_tile) + PM__block_proc.'(&inouts, + PM__import(PM__ins), + &inout_a, + PM__get_elem(PM__in_a,here_in_tile), + PM__get_elem(PM__star_a,here_in_tile) <>) + PM__export(&PM__inouts,inouts) + PM__set_elem(&PM__inout_a,inout_a,here_in_tile) + } + } +} + +proc PM__par_stmt'(num) yield() <> { yield() } +proc PM__check_task'(num)=true + +proc PM__chan_stmt'() yield() { yield() } +proc PM__over_stmt'(x) yield() { yield() } + +proc #'(x)=x + +proc PM__check_iter(x){} +proc PM__check_iter_amp(x){} +proc PM__check_iter_star(x){} +proc PM__check_iter(x,y){} +proc PM__check_iter_amp(x,y){} +proc PM__check_iter_star(x,y){} + +proc PM__get_elem(x:PM__list,h)=PM__each_index(i in num_elements(x):h) +proc PM__get_elem(x,h)=h +proc PM__set_elem(&x,y,h) {} +proc PM__export(&x,y) {} + +proc PM__import(x:PM__list)=PM__each_index(i in num_elements(x):PM__import(element_at_index(x,i))) +PM__intrinsic PM__import(x:any)->(=x) : "import_val" + +proc PM__generate(x,n)=old_dumpit(_elts(x,1,n)) +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->(int) : "iota" +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,first:int,trunc:int,totsiz:int)->(int) : "iota" +proc _n(x:int)=x +proc _elts(x:int,siz,tot)=old_dumpit(_iota(siz,0,x,1,tot)) +proc _elts(x:tuple1d,siz,tot)=tuple(_elts(x.1,siz,tot)) +proc _elts(x:tuple2d,siz,tot)=tuple(_elts(x.1,siz,tot),_elts(x.2,siz*_n(x.1),tot) ) +proc _elts(x:tuple3d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts( x.3, s1*_n(x.2), tot)) where s1=siz*_n(x.1) +proc _elts(x:tuple4d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s2*_n(x.3),tot)) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple5d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s3*_n(x.4), tot)) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple6d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s4*_n(x.5), tot)) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple7d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s5,tot),_elts(x.7,s5*_n(x.6), tot)) where s5=s4*_n(x.5) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) + +// ************************************************** +// SUPPORT FOR OTHER LANGUAGE FEATURES +// ************************************************** + +// Keyword arguments +proc PM__getkey(x:any,y:any)=convert(x,y) +proc PM__getkey(x:null,y:any)=y + +// Switch statement +proc PM__checkcase(x:literal,y:literal)=match_switch_case(x,y) +proc PM__checkcase(x,y)=match_switch_case(x,y) +proc match_switch_case(x:literal,y:literal)=x==y +proc match_switch_case(x:fix(any),y:fix(any))=x==y +proc match_switch_case(x,y)=x==y +proc match_switch_case(x:real_num,y:range(real_num))=x>=y._lo and x<=y._hi +proc match_switch_case(x:real_num,y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:literal(int),y:_crange)=(x>=y._lo and x<=y._hi) as +proc match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:,y:)=y inc x +type _crange is rec{_lo,_hi} +proc PM__caserange(x,y)=x..y +proc PM__caserange(x:fix(int),y:fix(int))=rec _crange{ + _lo=x,_hi=y +} + +// Conditional operators +proc PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> same_type(y,z) { + var r=z + if x { + r=y + } + return r +} + +proc PM__if(x:fix(true),y,z)=y +proc PM__if(x:fix(false),y,z)=z +proc PM__if(x:fix(true),y:literal,z)=y +proc PM__if(x:fix(false),y,z:literal)=z +proc PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> same_type(y,z) { + var r=z + if match(w,x) { + r=y + } + return r +} + +proc PM__switch(w:fix(int),x:fix(int),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z) +proc PM__switch(w,x,y,...)=PM__switch(w,x,y,PM__switch(w,...)) + +/* +// Assignment +proc PM__assign_or_init(a,b)<>=a { + PM__assign_var(&^(a),b) +} +*/ + + +/* +type assignment_operator is $_just_assign,$+,$*,$&,$|,$~,$and,$or,$++,... + +proc PM__assign(&a:any,b:any,c:assignment_operator) { + PM__assign(&a,c.(a,b)) +} +*/ + +proc PM__assign(&a:any,b:any,c:proc) { + test "Not a recognised assignment operator"=>fix(false) +} + +proc check_assign_types(x,y){ + test "Type mismatch in assignment"=>same_type(x,y) +} +proc _assign(&a,b) { + _assign_element(&a,b) +} + +/* +proc _assign(&a:contains(farray),b) { + _assign_structure(&a,b) +} +*/ +/* +proc _assign_structure(&a,b)<>{ + _assign_element(&a,b) +} +proc _assign_structure(&a:farray,b){ + _array_assign(&a,b,fix(true)) +} +*/ +PM__intrinsic _assign_element(&any,any): "assign" + + +// Other variable operations + +proc PM__assign_or_init(&a:PM__assign_or_init,b)=PM__dup(b as a) + +proc PM__assign_or_init(&a,b)=a:PM__assign(&a,b) + +proc PM__init_const(&a:PM__assign_or_init,b)=PM__dup(b as a) + +proc PM__init_const(&a,b)=a check "Cannot initialise a constant twice"=>fix(false) + +proc PM__assign_var(&a,b) { + PM__assign(&a,b) +} + +proc PM__dup(x)=x + +proc PM__assign(&a:any,b:any) { + _assign(&a,c) where c=b as a +} + +PM__intrinsic PM__clone(x:any)->(=x) : "clone" +PM__intrinsic PM__make_var(x:any)->(=x) : "clone" +PM__intrinsic PM__make_var'(x:priv)->(=x) : "clone_var" priv +PM__intrinsic PM__make_var'(x:any)->(=x) : "clone" priv +PM__intrinsic PM__make_const'(x:any)->(=x) : "clone_var" +PM__intrinsic PM__make_const(x:any)->(=x) : "clone_var" +proc PM__init_var(x:any,y:any)=PM__make_var(x,y) +proc PM__init_const(x:any,y:any)=PM__make_const(x,y) +proc PM__init_var'(x:any,y:any)=PM__make_var'(x,y) +proc PM__init_const'(x:any,y:any)=PM__make_const'(x,y) +proc PM__make_var(x,y)=PM__make_var(x as y) +proc PM__make_const(x,y)=PM__make_const(x as y) +PM__intrinsic PM__dechan'(x:any)->(=x): "clone_var" +/* +PM__intrinsic PM__dup(x:fix(int))->(int) : "clone" +PM__intrinsic PM__dup(x:fix(real))->(real) : "clone" +PM__intrinsic PM__dup(x:fix(string))->(string) : "clone" +PM__intrinsic PM__dup(x:fix(bool))->(bool) : "clone" +PM__intrinsic PM__dup(x:literal(int))->(int) : "clone" +PM__intrinsic PM__dup(x:literal(real))->(real) : "clone" +PM__intrinsic PM__dup(x:literal(string))->(string) : "clone" +PM__intrinsic PM__dup(x:literal(bool))->(bool) : "clone" +*/ +PM__intrinsic PM__getref(x:any)->(=x) : "get_rf" +PM__intrinsic<> same_type(x:any,y:any)->(==x,y) : "logical_return" + +/* +proc ==(x:any,y:any) { + test "Cannot apply ""=="" to different types"=> same_type(x,y) + var ok=true + _eq(x,y,&ok) + return ok +} +proc /=(x:any,y:any) { + test "Cannot apply ""/="" to different types"=> same_type(x,y) + var ok=true + _eq(x,y,&ok) + return not ok +} +proc _eq(x:any,y:any,&ok) <> { + ok=ok and x==y +} +*/ + +proc PM__valref(x)=x +proc PM__check_alias(...){} + +PM__intrinsic PM__copy_out(x:any)->(=x) : "clone" +PM__intrinsic PM__copy_back(x:any)->(=x) : "assign" +proc next_enum(x:int)=x+convert(1,x) +proc next_enum(x:int,y:int)=x+convert(y,x) + +PM__intrinsic<> .element_at_index(&x:any,y:fix(int))->(|x):"elem" +PM__intrinsic<> element_at_index(x:any,y:fix(int))->(|x):"elem" + +proc elements(x)=_elements(x,1) +proc _elements(x,i:literal(int)) { + let e... + if fix(i==num_elements(x)) { + let ...e=_cons(PM__element_at(x,i),_list_end) + } else { + let ...e=_cons(PM__element_at(x,i),_elements(x,i+1)) + } + return e +} + +// Type values +PM__intrinsic<> typeof(x:any)->(type x) : "make_type_val" +proc is(x,t)=t inc typeof(x) +proc isnt(x,t)=not(x is t) +proc as(x,t:)...=PM__cast(x,t) +proc as(x,t)=PM__cast(x,typeof(t)) +PM__intrinsic<> inc(x:,y:)->( inc x,y) : "type_include_fold" +proc ==(x:,y:)=x inc y and y inc x +PM__intrinsic error_type()->(=1) : "error_type" + +// Debugging +PM__intrinsic<> _dump(any,any): "new_dump" +proc PM__dump(x)<>:_dump("Value:",x) +proc PM__dump(y,x)<>:if y:_dump("Value:",x) +/* +proc PM__dump%(x)<>{ + print("$"++here) + _dump(string(here),x) +} +proc PM__dump%(y:bool,x)<>{ + if y:_dump(string(here),x) +} +proc PM__dump%(y,x){ + test "Selection expression in ""$$dump"" not ""bool""" => fix(false) + $$infer_type(y) +} +*/ +PM__intrinsic<> old_dump(any): "dump" +proc old_dumpit(a) { + old_dump(a) + return a +} + +PM__intrinsic<> old_dump_id(any): "dump_id" + +proc PM__filesys()=1234 + +proc PM__check_alias(a,b) {} +proc PM__lhs_and_val(a)=a +proc PM__rhs_and_val(a)=a +proc PM__copy_in(a)=a +proc PM__copy_out(&a,b):a=b + +proc PM__for_in(a)=a +proc PM__for_var(a)=a + +proc PM__import_param'(x)=x +proc PM__export_param'(x)=x +proc PM__import_param'(&x,y){} + +proc PM__make_over'(a)=a + +PM__intrinsic<> PM__list_concat(x:PM__list,y:PM__list)->(=x):"list_concat" +PM__intrinsic<> PM__list_splice(x:PM__list,y:PM__list,i:literal(int),j:literal(int))->(=x):"list_splice" + +proc compile_error(mess:literal(string)): test mess=>false diff --git a/pm/lib/sys/pm_b4.pmm b/pm/lib/sys/pm_b4.pmm new file mode 100644 index 0000000..447efa4 --- /dev/null +++ b/pm/lib/sys/pm_b4.pmm @@ -0,0 +1,5268 @@ +/* + PM (Parallel Models) Programming Language + + Released under the MIT License (MIT) + Copyright (c) Tim Bellerby, 2024 + + Permission is hereby granted, free of charge, to any person obtaining a copy + of this software and associated documentation files (the "Software"), to deal + in the Software without restriction, including without limitation the rights + to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the Software is + furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in + all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + THE SOFTWARE. +*/ + + +/* +type int_literal is ^^^int +type real_literal is ^^^real +type bool_literal is ^^^bool +type string_literal is ^^^string +*/ + +type literal is ^^^any + +PM__intrinsic num_elements(any)->(int_literal) : "num_elems_fold" + +PM__intrinsic mod(int_literal,int_literal)->(int_literal) : "mod_fold" +PM__intrinsic ==(int_literal,int_literal)->(bool_literal) : "eq_fold" +PM__intrinsic /=(int_literal,int_literal)->(bool_literal) : "ne_fold" +PM__intrinsic >=(int_literal,int_literal)->(bool_literal) : "ge_fold" +PM__intrinsic >(int_literal,int_literal)->(bool_literal) : "gt_fold" +PM__intrinsic +(int_literal,int_literal)->(int_literal) : "add_fold" +PM__intrinsic -(int_literal,int_literal)->(int_literal) : "sub_fold" +PM__intrinsic *(int_literal,int_literal)->(int_literal) : "mult_fold" +PM__intrinsic /(int_literal,int_literal)->(int_literal) : "divide_fold" +PM__intrinsic **(int_literal,int_literal)->(int_literal) : "pow_fold" +PM__intrinsic max(int_literal,int_literal)->(int_literal) : "max_fold" +PM__intrinsic min(int_literal,int_literal)->(int_literal) : "min_fold" +PM__intrinsic -(int_literal)->(int_literal) : "uminus_fold" +PM__intrinsic string(int_literal)->(string_literal) : "string_fold" +PM__intrinsic abs(int_literal)->(int_literal) : "abs_fold" +PM__intrinsic ~(int_literal)->(int_literal) : "bnot_fold" +PM__intrinsic &(int_literal,int_literal)->(int_literal) : "band_fold" +PM__intrinsic |(int_literal,int_literal)->(int_literal) : "bor_fold" +PM__intrinsic xor(int_literal,int_literal)->(int_literal) : "bxor_fold" +PM__intrinsic shift(int_literal,int_literal)->(int_literal) : "bshift_fold" +PM__intrinsic pdiff(int_literal,int_literal)->(int_literal) : "pdiff_fold" +PM__intrinsic sign(int_literal,int_literal)->(int_literal) : "sign_fold" +PM__intrinsic rem(int_literal,int_literal)->(int_literal) : "modulo_fold" +PM__intrinsic and(bool_literal,bool_literal)->(bool_literal) : "and_fold" +PM__intrinsic or(bool_literal,bool_literal)->(bool_literal) : "or_fold" +PM__intrinsic except(bool_literal,bool_literal)->(bool_literal) : "except_fold" +PM__intrinsic ==(bool_literal,bool_literal)->(bool_literal) : "eq_fold" +PM__intrinsic /=(bool_literal,bool_literal)->(bool_literal) : "ne_fold" +PM__intrinsic ==(string_literal,string_literal)->(bool_literal) : "eq_fold" +PM__intrinsic /=(string_literal,string_literal)->(bool_literal) : "ne_fold" +PM__intrinsic ==(real_literal,real_literal)->(bool_literal) : "eq_fold" +PM__intrinsic /=(real_literal,real_literal)->(bool_literal) : "ne_fold" +PM__intrinsic ++(string_literal,string_literal)->(string_literal) : "concat_fold" +PM__intrinsic mod(fix int,fix int)->(fix int) : "mod_fold" +PM__intrinsic ==(fix int,fix int)->(fix bool) : "eq_fold" +PM__intrinsic /=(fix int,fix int)->(fix bool) : "ne_fold" +PM__intrinsic >=(fix int,fix int)->(fix bool) : "ge_fold" +PM__intrinsic >(fix int,fix int)->(fix bool) : "gt_fold" +PM__intrinsic +(fix int,fix int)->(fix int) : "add_fold" +PM__intrinsic -(fix int,fix int)->(fix int) : "sub_fold" +PM__intrinsic *(fix int,fix int)->(fix int) : "mult_fold" +PM__intrinsic /(fix int,fix int)->(fix int) : "divide_fold" +PM__intrinsic **(fix int,fix int)->(fix int) : "pow_fold" +PM__intrinsic max(fix int,fix int)->(fix int) : "max_fold" +PM__intrinsic min(fix int,fix int)->(fix int) : "min_fold" +PM__intrinsic -(fix int)->(fix int) : "uminus_fold" +PM__intrinsic string(fix int)->(fix string) : "string_fold" +PM__intrinsic abs(fix int)->(fix int) : "abs_fold" +PM__intrinsic ~(fix int)->(fix int) : "bnot_fold" +PM__intrinsic &(fix int,fix int)->(fix int) : "band_fold" +PM__intrinsic |(fix int,fix int)->(fix int) : "bor_fold" +PM__intrinsic xor(fix int,fix int)->(fix int) : "bxor_fold" +PM__intrinsic shift(fix int,fix int)->(fix int) : "bshift_fold" +PM__intrinsic pdiff(fix int,fix int)->(fix int) : "pdiff_fold" +PM__intrinsic sign(fix int,fix int)->(fix int) : "sign_fold" +PM__intrinsic rem(fix int,fix int)->(fix int) : "modulo_fold" +PM__intrinsic and(fix bool,fix bool)->(fix bool) : "and_fold" +PM__intrinsic or(fix bool,fix bool)->(fix bool) : "or_fold" +PM__intrinsic except(fix bool,fix bool)->(fix bool) : "except_fold" +PM__intrinsic ==(fix bool,fix bool)->(fix bool) : "eq_fold" +PM__intrinsic /=(fix bool,fix bool)->(fix bool) : "ne_fold" +PM__intrinsic ==(fix string,fix string)->(fix bool) : "eq_fold" +PM__intrinsic /=(fix string,fix string)->(fix bool) : "ne_fold" +PM__intrinsic ==(fix real,fix real)->(fix bool) : "eq_fold" +PM__intrinsic /=(fix real,fix real)->(fix bool) : "ne_fold" +PM__intrinsic ++(fix string,fix string)->(fix string) : "concat_fold" + +// ************************************** +// BASIC TYPES +// ************************************** + +// String type +PM__intrinsic<> print(string): "print" + +proc print(x) { + print(string(x)) +} + +PM__intrinsic<> print_all(string): "print"(1) + +proc print_all(x) { + print_all(string(x)) +} + +PM__intrinsic ++(string,string)->(string) : "concat" + +proc ++(x:string,y)=$++.(x,string(y)) +proc ++(x,y)=$++.(string(x),string(y)) +proc string(x:string)=x +proc string(x:null)="null" +proc fmt(x,y)=x:test """fmt"" operator not yet implmented"=>'false + +// sint type +PM__intrinsic PM__assign_var(&sint,sint): "assign_i" +PM__intrinsic mod(sint,sint)->(sint) : "mod_i" +PM__intrinsic ==(sint,sint)->(bool) : "eq_i" +PM__intrinsic /=(sint,sint)->(bool) : "ne_i" +PM__intrinsic >=(sint,sint)->(bool) : "ge_i" +PM__intrinsic >(sint,sint)->(bool) : "gt_i" +PM__intrinsic +(sint,sint)->(sint) : "add_i" +PM__intrinsic -(sint,sint)->(sint) : "sub_i" +PM__intrinsic *(sint,sint)->(sint) : "mult_i" +PM__intrinsic /(sint,sint)->(sint) : "divide_i" +PM__intrinsic **(sint,sint)->(sint) : "pow_i" +PM__intrinsic max(sint,sint)->(sint) : "max_i" +PM__intrinsic min(sint,sint)->(sint) : "min_i" +PM__intrinsic -(sint)->(sint) : "uminus_i" +PM__intrinsic string(sint)->(string) : "string_i" +PM__intrinsic int(sint)->(int) : "long_i" +PM__intrinsic sreal(sint)->(sreal) : "real_i" +PM__intrinsic real(sint)->(real) : "double_i" +proc sint(x:sint)=x +PM__intrinsic abs(sint)->(sint) : "abs_i" +PM__intrinsic bit_not(sint)->(sint) : "bnot_i" +PM__intrinsic &(sint,sint)->(sint) : "band_i" +PM__intrinsic |(sint,sint)->(sint) : "bor_i" +PM__intrinsic xor(sint,sint)->(sint) : "bxor_i" +PM__intrinsic shift(sint,sint)->(sint) : "bshift_i" +PM__intrinsic pdiff(sint,sint)->(sint) : "pdiff_i" +PM__intrinsic sign(sint,sint)->(sint) : "sign_i" +PM__intrinsic rem(sint,sint)->(sint) : "modulo_i" +PM__intrinsic int8(sint)->(int8) : "i8_i" +PM__intrinsic int16(sint)->(int16) : "i16_i" +PM__intrinsic int32(sint)->(int32) : "i32_i" +PM__intrinsic int64(sint)->(int64) : "i64_i" +PM__intrinsic lint(sint)->(lint) : "offset_i" + +// int type +PM__intrinsic PM__assign_var(&int,int): "assign_ln" +PM__intrinsic mod(int,int)->(int) : "mod_ln" +PM__intrinsic ==(int,int)->(bool) : "eq_ln" +PM__intrinsic /=(int,int)->(bool) : "ne_ln" +PM__intrinsic >=(int,int)->(bool) : "ge_ln" +PM__intrinsic >(int,int)->(bool) : "gt_ln" +PM__intrinsic +(int,int)->(int) : "add_ln" +PM__intrinsic -(int,int)->(int) : "sub_ln" +PM__intrinsic *(int,int)->(int) : "mult_ln" +proc *(x:int,y:'1)=x +PM__intrinsic /(int,int)->(int) : "divide_ln" +proc /(x:int,y:'1)=x +PM__intrinsic **(int,int)->(int) : "pow_ln" +PM__intrinsic max(int,int)->(int) : "max_ln" +PM__intrinsic min(int,int)->(int) : "min_ln" +PM__intrinsic -(int)->(int) : "uminus_ln" +PM__intrinsic string(int)->(string) : "string_ln" +PM__intrinsic sint(int)->(sint) : "int_ln" +PM__intrinsic sreal(int)->(sreal) : "real_ln" +PM__intrinsic real(int)->(real) : "double_ln" +proc int(x:int)=x +PM__intrinsic abs(int)->(int) : "abs_ln" +PM__intrinsic ~(int)->(int) : "bnot_ln" +PM__intrinsic &(int,int)->(int) : "band_ln" +PM__intrinsic |(int,int)->(int) : "bor_ln" +PM__intrinsic xor(int,int)->(int) : "bxor_ln" +PM__intrinsic shift(int,int)->(int) : "bshift_ln" +PM__intrinsic pdiff(int,int)->(int) : "pdiff_ln" +PM__intrinsic sign(int,int)->(int) : "sign_ln" +PM__intrinsic rem(int,int)->(int) : "modulo_ln" +PM__intrinsic int8(int)->(int8) : "i8_ln" +PM__intrinsic int16(int)->(int16) : "i16_ln" +PM__intrinsic int32(int)->(int32) : "i32_ln" +PM__intrinsic int64(int)->(int64) : "i64_ln" +PM__intrinsic lint(int)->(lint) : "offset_ln" + +// lint type +PM__intrinsic PM__assign_var(&lint,lint): "assign_offset" +PM__intrinsic mod(lint,lint)->(lint) : "mod_offset" +PM__intrinsic ==(lint,lint)->(bool) : "eq_offset" +PM__intrinsic /=(lint,lint)->(bool) : "ne_offset" +PM__intrinsic >=(lint,lint)->(bool) : "ge_offset" +PM__intrinsic >(lint,lint)->(bool) : "gt_offset" +PM__intrinsic +(lint,lint)->(lint) : "add_offset" +proc +(x:lint,y:'0)=x +proc +(x:'0,y:lint)=y +PM__intrinsic -(lint,lint)->(lint) : "sub_offset" +proc -(x:lint,y:'0)=x +PM__intrinsic *(lint,lint)->(lint) : "mult_offset" +proc *(x:lint,y:'1)=x +proc *(x:'1,y:lint)=y +PM__intrinsic /(lint,lint)->(lint) : "divide_offset" +proc /(x:lint,y:'1)=x +PM__intrinsic **(lint,lint)->(lint) : "pow_offset" +proc **(x:lint,y:'0)=1 +proc **(x:lint,y:'1)=x +proc **(x:lint,y:'2)=x*x +PM__intrinsic max(lint,lint)->(lint) : "max_offset" +PM__intrinsic min(lint,lint)->(lint) : "min_offset" +PM__intrinsic -(lint)->(lint) : "uminus_offset" +PM__intrinsic string(lint)->(string) : "string_offset" +PM__intrinsic sint(lint)->(sint) : "int_offset" +PM__intrinsic sreal(lint)->(sreal) : "real_offset" +PM__intrinsic real(lint)->(real) : "double_offset" +proc lint(x:lint)=x +PM__intrinsic abs(lint)->(lint) : "abs_offset" +PM__intrinsic ~(lint)->(lint) : "bnot_offset" +PM__intrinsic &(lint,lint)->(lint) : "band_offset" +PM__intrinsic |(lint,lint)->(lint) : "bor_offset" +PM__intrinsic xor(lint,lint)->(lint) : "bxor_offset" +PM__intrinsic shift(lint,lint)->(lint) : "bshift_offset" +PM__intrinsic pdiff(lint,lint)->(lint) : "pdiff_offset" +PM__intrinsic sign(lint,lint)->(lint) : "sign_offset" +PM__intrinsic rem(lint,lint)->(lint) : "modulo_offset" +PM__intrinsic int8(lint)->(int8) : "i8_offset" +PM__intrinsic int16(lint)->(int16) : "i16_offset" +PM__intrinsic int32(lint)->(int32) : "i32_offset" +PM__intrinsic int64(lint)->(int64) : "i64_offset" +PM__intrinsic int(lint)->(int) : "long_offset" + +// int8 type +PM__intrinsic PM__assign_var(&int8,int8): "assign_i8" +PM__intrinsic mod(int8,int8)->(int8) : "mod_i8" +PM__intrinsic ==(int8,int8)->(bool) : "eq_i8" +PM__intrinsic /=(int8,int8)->(bool) : "ne_i8" +PM__intrinsic >=(int8,int8)->(bool) : "ge_i8" +PM__intrinsic >(int8,int8)->(bool) : "gt_i8" +PM__intrinsic +(int8,int8)->(int8) : "add_i8" +proc +(x:int8,y:'0)=x +proc +(x:'0,y:int8)=y +PM__intrinsic -(int8,int8)->(int8) : "sub_i8" +proc -(x:int8,y:'0)=x +PM__intrinsic *(int8,int8)->(int8) : "mult_i8" +proc *(x:int8,y:'1)=x +proc *(x:'1,y:int8)=y +PM__intrinsic /(int8,int8)->(int8) : "divide_i8" +proc /(x:int8,y:'1)=x +PM__intrinsic **(int8,int8)->(int8) : "pow_i8" +proc **(x:int8,y:'0)=1 +proc **(x:int8,y:'1)=x +proc **(x:int8,y:'2)=x*x +PM__intrinsic max(int8,int8)->(int8) : "max_i8" +PM__intrinsic min(int8,int8)->(int8) : "min_i8" +PM__intrinsic -(int8)->(int8) : "uminus_i8" +PM__intrinsic sint(int8)->(sint) : "int_i8" +PM__intrinsic sreal(int8)->(sreal) : "real_i8" +PM__intrinsic real(int8)->(real) : "double_i8" +proc int8(x:int8)=x +PM__intrinsic abs(int8)->(int8) : "abs_i8" +PM__intrinsic ~(int8)->(int8) : "bnot_i8" +PM__intrinsic &(int8,int8)->(int8) : "band_i8" +PM__intrinsic |(int8,int8)->(int8) : "bor_i8" +PM__intrinsic xor(int8,int8)->(int8) : "bxor_i8" +PM__intrinsic shift(int8,int8)->(int8) : "bshift_i8" +PM__intrinsic pdiff(int8,int8)->(int8) : "pdiff_i8" +PM__intrinsic sign(int8,int8)->(int8) : "sign_i8" +PM__intrinsic rem(int8,int8)->(int8) : "modulo_i8" +PM__intrinsic int16(int8)->(int16) : "i16_i8" +PM__intrinsic int32(int8)->(int32) : "i32_i8" +PM__intrinsic int64(int8)->(int64) : "i64_i8" +PM__intrinsic int(int8)->(int) : "long_i8" +PM__intrinsic lint(int8)->(lint) : "offset_i8" + +// int16 type +PM__intrinsic PM__assign_var(&int16,int16): "assign_i16" +PM__intrinsic mod(int16,int16)->(int16) : "mod_i16" +PM__intrinsic ==(int16,int16)->(bool) : "eq_i16" +PM__intrinsic /=(int16,int16)->(bool) : "ne_i16" +PM__intrinsic >=(int16,int16)->(bool) : "ge_i16" +PM__intrinsic >(int16,int16)->(bool) : "gt_i16" +PM__intrinsic +(int16,int16)->(int16) : "add_i16" +proc +(x:int16,y:'0)=x +proc +(x:'0,y:int16)=y +PM__intrinsic -(int16,int16)->(int16) : "sub_i16" +proc -(x:int16,y:'0)=x +PM__intrinsic *(int16,int16)->(int16) : "mult_i16" +proc *(x:int16,y:'1)=x +proc *(x:'1,y:int16)=y +PM__intrinsic /(int16,int16)->(int16) : "divide_i16" +proc /(x:int16,y:'1)=x +PM__intrinsic **(int16,int16)->(int16) : "pow_i16" +proc **(x:int16,y:'0)=1 +proc **(x:int16,y:'1)=x +proc **(x:int16,y:'2)=x*x +PM__intrinsic max(int16,int16)->(int16) : "max_i16" +PM__intrinsic min(int16,int16)->(int16) : "min_i16" +PM__intrinsic -(int16)->(int16) : "uminus_i16" +PM__intrinsic sint(int16)->(sint) : "int_i16" +PM__intrinsic sreal(int16)->(sreal) : "real_i16" +PM__intrinsic real(int16)->(real) : "double_i16" +proc int16(x:int16)=x +PM__intrinsic abs(int16)->(int16) : "abs_i16" +PM__intrinsic ~(int16)->(int16) : "bnot_i16" +PM__intrinsic &(int16,int16)->(int16) : "band_i16" +PM__intrinsic |(int16,int16)->(int16) : "bor_i16" +PM__intrinsic xor(int16,int16)->(int16) : "bxor_i16" +PM__intrinsic shift(int16,int16)->(int16) : "bshift_i16" +PM__intrinsic pdiff(int16,int16)->(int16) : "pdiff_i16" +PM__intrinsic sign(int16,int16)->(int16) : "sign_i16" +PM__intrinsic rem(int16,int16)->(int16) : "modulo_i16" +PM__intrinsic int8(int16)->(int16) : "i8_i16" +PM__intrinsic int32(int16)->(int32) : "i32_i16" +PM__intrinsic int64(int16)->(int64) : "i64_i16" +PM__intrinsic int(int16)->(int) : "long_i16" +PM__intrinsic lint(int16)->(lint) : "offset_i16" + +// int32 type +PM__intrinsic PM__assign_var(&int32,int32): "assign_i32" +PM__intrinsic mod(int32,int32)->(int32) : "mod_i32" +PM__intrinsic ==(int32,int32)->(bool) : "eq_i32" +PM__intrinsic /=(int32,int32)->(bool) : "ne_i32" +PM__intrinsic >=(int32,int32)->(bool) : "ge_i32" +PM__intrinsic >(int32,int32)->(bool) : "gt_i32" +PM__intrinsic +(int32,int32)->(int32) : "add_i32" +proc +(x:int32,y:'0)=x +proc +(x:'0,y:int32)=y +PM__intrinsic -(int32,int32)->(int32) : "sub_i32" +proc -(x:int32,y:'0)=x +PM__intrinsic *(int32,int32)->(int32) : "mult_i32" +proc *(x:int32,y:'1)=x +proc *(x:'1,y:int32)=y +PM__intrinsic /(int32,int32)->(int32) : "divide_i32" +proc /(x:int32,y:'1)=x +PM__intrinsic **(int32,int32)->(int32) : "pow_i32" +proc **(x:int32,y:'0)=1 +proc **(x:int32,y:'1)=x +proc **(x:int32,y:'2)=x*x +PM__intrinsic max(int32,int32)->(int32) : "max_i32" +PM__intrinsic min(int32,int32)->(int32) : "min_i32" +PM__intrinsic -(int32)->(int32) : "uminus_i32" +PM__intrinsic sint(int32)->(sint) : "int_i32" +PM__intrinsic sreal(int32)->(sreal) : "real_i32" +PM__intrinsic real(int32)->(real) : "double_i32" +proc int32(x:int32)=x +PM__intrinsic abs(int32)->(int32) : "abs_i32" +PM__intrinsic ~(int32)->(int32) : "bnot_i32" +PM__intrinsic &(int32,int32)->(int32) : "band_i32" +PM__intrinsic |(int32,int32)->(int32) : "bor_i32" +PM__intrinsic xor(int32,int32)->(int32) : "bxor_i32" +PM__intrinsic shift(int32,int32)->(int32) : "bshift_i32" +PM__intrinsic pdiff(int32,int32)->(int32) : "pdiff_i32" +PM__intrinsic sign(int32,int32)->(int32) : "sign_i32" +PM__intrinsic rem(int32,int32)->(int32) : "modulo_i32" +PM__intrinsic int8(int32)->(int32) : "i8_i32" +PM__intrinsic int16(int32)->(int32) : "i16_i32" +PM__intrinsic int64(int32)->(int64) : "i64_i32" +PM__intrinsic int(int32)->(int) : "long_i32" +PM__intrinsic lint(int32)->(lint) : "offset_i32" + +// int64 type +PM__intrinsic PM__assign_var(&int64,int64): "assign_i64" +PM__intrinsic mod(int64,int64)->(int64) : "mod_i64" +PM__intrinsic ==(int64,int64)->(bool) : "eq_i64" +PM__intrinsic /=(int64,int64)->(bool) : "ne_i64" +PM__intrinsic >=(int64,int64)->(bool) : "ge_i64" +PM__intrinsic >(int64,int64)->(bool) : "gt_i64" +PM__intrinsic +(int64,int64)->(int64) : "add_i64" +proc +(x:int64,y:'0)=x +proc +(x:'0,y:int64)=y +PM__intrinsic -(int64,int64)->(int64) : "sub_i64" +proc -(x:int64,y:'0)=x +PM__intrinsic *(int64,int64)->(int64) : "mult_i64" +proc *(x:int64,y:'1)=x +proc *(x:'1,y:int64)=y +PM__intrinsic /(int64,int64)->(int64) : "divide_i64" +proc /(x:int64,y:'1)=x +PM__intrinsic **(int64,int64)->(int64) : "pow_i64" +proc **(x:int64,y:'0)=1 +proc **(x:int64,y:'1)=x +proc **(x:int64,y:'2)=x*x +PM__intrinsic max(int64,int64)->(int64) : "max_i64" +PM__intrinsic min(int64,int64)->(int64) : "min_i64" +PM__intrinsic -(int64)->(int64) : "uminus_i64" +PM__intrinsic string(int64)->(string) : "string_i64" +PM__intrinsic sint(int64)->(sint) : "int_i64" +PM__intrinsic sreal(int64)->(sreal) : "real_i64" +PM__intrinsic real(int64)->(real) : "double_i64" +proc int64(x:int64)=x +PM__intrinsic abs(int64)->(int64) : "abs_i64" +PM__intrinsic ~(int64)->(int64) : "bnot_i64" +PM__intrinsic &(int64,int64)->(int64) : "band_i64" +PM__intrinsic |(int64,int64)->(int64) : "bor_i64" +PM__intrinsic xor(int64,int64)->(int64) : "bxor_i64" +PM__intrinsic shift(int64,int64)->(int64) : "bshift_i64" +PM__intrinsic pdiff(int64,int64)->(int64) : "pdiff_i64" +PM__intrinsic sign(int64,int64)->(int64) : "sign_i64" +PM__intrinsic rem(int64,int64)->(int64) : "modulo_i64" +PM__intrinsic int8(int64)->(int64) : "i8_i64" +PM__intrinsic int16(int64)->(int64) : "i16_i64" +PM__intrinsic int32(int64)->(int64) : "i32_i64" +PM__intrinsic int(int64)->(int) : "long_i64" +PM__intrinsic lint(int64)->(lint) : "offset_i64" + +// sreal type +PM__intrinsic PM__assign_var(&sreal,sreal): "assign_r" +PM__intrinsic mod(sreal,sreal)->(sreal) : "mod_r" +PM__intrinsic ==(sreal,sreal)->(bool) : "eq_r" +PM__intrinsic /=(sreal,sreal)->(bool) : "ne_r" +PM__intrinsic >=(sreal,sreal)->(bool) : "ge_r" +PM__intrinsic >(sreal,sreal)->(bool) : "gt_r" +PM__intrinsic +(sreal,sreal)->(sreal) : "add_r" +PM__intrinsic -(sreal,sreal)->(sreal) : "sub_r" +PM__intrinsic *(sreal,sreal)->(sreal) : "mult_r" +PM__intrinsic /(sreal,sreal)->(sreal) : "divide_r" +PM__intrinsic **(sreal,sreal)->(sreal) : "pow_r" +PM__intrinsic max(sreal,sreal)->(sreal) : "max_r" +PM__intrinsic min(sreal,sreal)->(sreal) : "min_r" +PM__intrinsic -(sreal)->(sreal) : "uminus_r" +PM__intrinsic string(sreal)->(string) : "string_r" +PM__intrinsic strunc(sreal)->(sint) : "int_r" +PM__intrinsic trunc(sreal)->(int) : "long_r" +PM__intrinsic ltrunc(sreal)->(lint) : "offset_r" +PM__intrinsic real(sreal)->(real) : "double_r" +proc sreal(x:sreal)=x +PM__intrinsic abs(sreal)->(sreal) : "abs_r" +PM__intrinsic acos(sreal)->(sreal) : "acos_r" +PM__intrinsic asin(sreal)->(sreal) : "asin_r" +PM__intrinsic atan(sreal)->(sreal) : "atan_r" +PM__intrinsic atan2(sreal,sreal)->(sreal) : "atan2_r" +PM__intrinsic cos(sreal)->(sreal) : "cos_r" +PM__intrinsic cosh(sreal)->(sreal) : "cosh_r" +PM__intrinsic exp(sreal)->(sreal) : "exp_r" +PM__intrinsic log(sreal)->(sreal) : "log_r" +PM__intrinsic log10(sreal)->(sreal) : "log10_r" +PM__intrinsic sin(sreal)->(sreal) : "sin_r" +PM__intrinsic sinh(sreal)->(sreal) : "sinh_r" +PM__intrinsic sqrt(sreal)->(sreal) : "sqrt_r" +PM__intrinsic tan(sreal)->(sreal) : "tan_r" +PM__intrinsic tanh(sreal)->(sreal) : "tanh_r" +PM__intrinsic floor(sreal)->(sreal) : "floor_r" +PM__intrinsic ceil(sreal)->(sreal) : "ceil_r" +PM__intrinsic rem(sreal,sreal)->(sreal) : "modulo_r" +PM__intrinsic sign(sreal,sreal)->(sreal) : "sign_r" +PM__intrinsic pdiff(sreal,sreal)->(sreal) : "pdiff_r" +PM__intrinsic lint(sreal)->(lint) : "offset_r" +PM__intrinsic scpx(sreal)->(scpx) : "complex_r" +PM__intrinsic _scpx2(sreal,sreal)->(scpx) : "complex2_r" +proc scpx(x:any_real,y:any_real)=_scpx2(sreal(x),sreal(y)) + +// real type +PM__intrinsic PM__assign_var(&real,real): "assign_d" +PM__intrinsic mod(real,real)->(real) : "mod_d" +PM__intrinsic ==(real,real)->(bool) : "eq_d" +PM__intrinsic /=(real,real)->(bool) : "ne_d" +PM__intrinsic >=(real,real)->(bool) : "ge_d" +PM__intrinsic >(real,real)->(bool) : "gt_d" +PM__intrinsic +(real,real)->(real) : "add_d" +PM__intrinsic -(real,real)->(real) : "sub_d" +PM__intrinsic *(real,real)->(real) : "mult_d" +PM__intrinsic /(real,real)->(real) : "divide_d" +PM__intrinsic **(real,real)->(real) : "pow_d" +PM__intrinsic max(real,real)->(real) : "max_d" +PM__intrinsic min(real,real)->(real) : "min_d" +PM__intrinsic -(real)->(real) : "uminus_d" +PM__intrinsic string(real)->(string) : "string_d" +PM__intrinsic strunc(real)->(sint) : "int_d" +PM__intrinsic trunc(real)->(int) : "long_d" +PM__intrinsic ltrunc(real)->(lint) : "offset_d" +PM__intrinsic sreal(real)->(sreal) : "real_d" +proc real(x:real)=x +PM__intrinsic abs(real)->(real) : "abs_d" +PM__intrinsic acos(real)->(real) : "acos_d" +PM__intrinsic asin(real)->(real) : "asin_d" +PM__intrinsic atan(real)->(real) : "atan_d" +PM__intrinsic atan2(real,real)->(real) : "atan2_d" +PM__intrinsic cos(real)->(real) : "cos_d" +PM__intrinsic cosh(real)->(real) : "cosh_d" +PM__intrinsic exp(real)->(real) : "exp_d" +PM__intrinsic log(real)->(real) : "log_d" +PM__intrinsic log10(real)->(real) : "log10_d" +PM__intrinsic sin(real)->(real) : "sin_d" +PM__intrinsic sinh(real)->(real) : "sinh_d" +PM__intrinsic sqrt(real)->(real) : "sqrt_d" +PM__intrinsic tan(real)->(real) : "tan_d" +PM__intrinsic tanh(real)->(real) : "tanh_d" +PM__intrinsic floor(real)->(real) : "floor_d" +PM__intrinsic ceil(real)->(real) : "ceil_d" +PM__intrinsic rem(real,real)->(real) : "modulo_d" +PM__intrinsic sign(real,real)->(real) : "sign_d" +PM__intrinsic pdiff(real,real)->(real) : "pdiff_d" +PM__intrinsic lint(real)->(lint) : "offset_d" +PM__intrinsic cpx(real)->(cpx) : "complex_d" +PM__intrinsic _cpx2(real,real)->(cpx) : "complex2_d" +proc cpx(x:real_num,y:real_num)=_cpx2(real(x),real(y)) + +// scpx type +PM__intrinsic PM__assign_var(&scpx,scpx): "assign_c" +PM__intrinsic +(scpx,scpx)->(scpx) : "add_c" +PM__intrinsic -(scpx,scpx)->(scpx) : "sub_c" +PM__intrinsic *(scpx,scpx)->(scpx) : "mult_c" +PM__intrinsic /(scpx,scpx)->(scpx) : "divide_c" +PM__intrinsic **(scpx,sreal)->(scpx) : "rpow_c" +PM__intrinsic **(scpx,scpx)->(scpx) : "pow_c" +PM__intrinsic -(scpx)->(scpx) : "uminus_c" +PM__intrinsic ==(scpx,scpx)->(bool) : "eq_c" +PM__intrinsic /=(scpx,scpx)->(bool) : "ne_c" +PM__intrinsic re(scpx)->(sreal) : "real_c" +PM__intrinsic abs(scpx)->(scpx) : "abs_c" +PM__intrinsic acos(scpx)->(scpx) : "acos_c" +PM__intrinsic asin(scpx)->(scpx) : "asin_c" +PM__intrinsic atan(scpx)->(scpx) : "atan_c" +PM__intrinsic atan2(scpx,scpx)->(scpx) : "atan2_c" +PM__intrinsic cos(scpx)->(scpx) : "cos_c" +PM__intrinsic cosh(scpx)->(scpx) : "cosh_c" +PM__intrinsic exp(scpx)->(scpx) : "exp_c" +PM__intrinsic log(scpx)->(scpx) : "log_c" +PM__intrinsic sin(scpx)->(scpx) : "sin_c" +PM__intrinsic sinh(scpx)->(scpx) : "sinh_c" +PM__intrinsic sqrt(scpx)->(scpx) : "sqrt_c" +PM__intrinsic tan(scpx)->(scpx) : "tan_c" +PM__intrinsic tanh(scpx)->(scpx) : "tanh_c" +PM__intrinsic im(scpx)->(sreal) : "imag_c" +PM__intrinsic conj(scpx)->(scpx) : "conj_c" + +// cpx type +PM__intrinsic PM__assign_var(&cpx,cpx): "assign_dc" +PM__intrinsic +(cpx,cpx)->(cpx) : "add_dc" +PM__intrinsic -(cpx,cpx)->(cpx) : "sub_dc" +PM__intrinsic *(cpx,cpx)->(cpx) : "mult_dc" +PM__intrinsic /(cpx,cpx)->(cpx) : "divide_dc" +PM__intrinsic **(cpx,real)->(cpx) : "dpow_dc" +proc **(x:cpx,y:sreal)=x**real(y) +PM__intrinsic **(cpx,cpx)->(cpx) : "pow_dc" +PM__intrinsic -(cpx)->(cpx) : "uminus_dc" +PM__intrinsic ==(cpx,cpx)->(bool) : "eq_dc" +PM__intrinsic /=(cpx,cpx)->(bool) : "ne_dc" +PM__intrinsic re(cpx)->(real) : "real_dc" +PM__intrinsic abs(cpx)->(cpx) : "abs_dc" +PM__intrinsic acos(cpx)->(cpx) : "acos_dc" +PM__intrinsic asin(cpx)->(cpx) : "asin_dc" +PM__intrinsic atan(cpx)->(cpx) : "atan_dc" +PM__intrinsic atan2(cpx,cpx)->(cpx) : "atan2_dc" +PM__intrinsic cos(cpx)->(cpx) : "cos_dc" +PM__intrinsic cosh(cpx)->(cpx) : "cosh_dc" +PM__intrinsic exp(cpx)->(cpx) : "exp_dc" +PM__intrinsic log(cpx)->(cpx) : "log_dc" +PM__intrinsic sin(cpx)->(cpx) : "sin_dc" +PM__intrinsic sinh(cpx)->(cpx) : "sinh_dc" +PM__intrinsic sqrt(cpx)->(cpx) : "sqrt_dc" +PM__intrinsic tan(cpx)->(cpx) : "tan_dc" +PM__intrinsic tanh(cpx)->(cpx) : "tanh_dc" +PM__intrinsic im(cpx)->(real) : "imag_dc" +PM__intrinsic conj(cpx)->(cpx) : "conj_dc" + +/* + +// Cannot convert real to int (must use nint or trunc) +proc sint(x:any_real)=sint(0) :test "Cannot convert real to integer" => 'false +proc int(x:any_real)=0 :test "Cannot convert real to integer" => 'false +proc lint(x:any_real)=lint(0) :test "Cannot convert real to integer" => 'false + +// Some numeric conversions not hard-coded +proc cpx(x:real_num)=cpx(real(x)) +proc scpx(x:real_num)=cpx(sreal(x)) +proc string(x:any_int)=string(int64(x)) +proc string(x:any_cpx)= string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x) +proc int(x:fix int)=x + +// Abstract numeric types +type any_int is sint,int,lint,int8,int16,int32,int64 +type any_real is sreal,real +type any_cpx is scpx,cpx +type int_num is any_int +type real_num is int_num, any_real +type cpx_num is real_num,any_cpx +type num is cpx_num + +// Numeric type conversion +proc convert(x,y)=x +proc convert(x:int_num,y:sint)=sint(x) +proc convert(x:int_num,y:int)=int(x) +proc convert(x:int_num,y:lint)=lint(x) +proc convert(x:int_num,y:int8)=int8(x) +proc convert(x:int_num,y:int16)=int16(x) +proc convert(x:int_num,y:int32)=int32(x) +proc convert(x:int_num,y:int64)=int64(x) +proc convert(x:int_num,y:sreal)=sreal(x) +proc convert(x:int_num,y:real)=real(x) +proc convert(x:real_num,y:cpx)=cpx(x) +proc convert(x:real_num,y:scpx)=scpx(x) +proc as(x:int_num,y:)=sint(x) +proc as(x:int_num,y:)=int(x) +proc as(x:int_num,y:)=lint(x) +proc as(x:int_num,y:)=int8(x) +proc as(x:int_num,y:)=int16(x) +proc as(x:int_num,y:)=int32(x) +proc as(x:int_num,y:)=int64(x) +proc as(x:real_num,y:)=sreal(x) +proc as(x:real_num,y:)=real(x) +proc as(x:real_num,y:)=scpx(x) +proc as(x:real_num,y:)=cpx(x) + +// Auto-conversion on assignment +proc PM__assign(&x:num,y:num) { + _assign_element(&x,convert(y,x)) +} +proc PM__assign_var(&x:num,y:num) { + PM__assign(&x,convert(y,x)) +} + +// Mixed arithmatic +type _to_sint is int +type _to_lint is sint,int +type _to_int8 is sint,int,lint +type _to_int16 is sint,int,lint,int8 +type _to_int32 is sint,int,lint,int8,int16 +type _to_int64 is sint,int,lint,int8,int16,int32 +type _to_real is any_int +type _to_sreal is any_int,real +type _to_cpx is real_num +type _to_scpx is real_num,cpx +proc balance(x:sint,y:sint)=x,y +proc balance(x:int,y:int)=x,y +proc balance(x:lint,y:lint)=x,y +proc balance(x:int8,y:int8)=x,y +proc balance(x:int16,y:int16)=x,y +proc balance(x:int32,y:int32)=x,y +proc balance(x:int64,y:int64)=x,y +proc balance(x:sreal,y:sreal)=x,y +proc balance(x:real,y:real)=x,y +proc balance(x:scpx,y:scpx)=x,y +proc balance(x:cpx,y:cpx)=x,y +proc balance(x:sint,y:_to_sint)=x,sint(y) +proc balance(x:lint,y:_to_lint)=x,lint(y) +proc balance(x:int8,y:_to_int8)=x,int8(y) +proc balance(x:int16,y:_to_int16)=x,int16(y) +proc balance(x:int32,y:_to_int32)=x,int32(y) +proc balance(x:int64,y:_to_int64)=x,int64(y) +proc balance(x:sreal,y:_to_sreal)=x,sreal(y) +proc balance(x:real,y:_to_real)=x,real(y) +proc balance(x:scpx,y:_to_scpx)=x,scpx(y) +proc balance(x:cpx,y:_to_cpx)=x,cpx(y) +proc balance(x:_to_sint,y:sint)=sint(x),y +proc balance(x:_to_lint,y:lint)=lint(x),y +proc balance(x:_to_int8,y:int8)=int8(x),y +proc balance(x:_to_int16,y:int16)=int16(x),y +proc balance(x:_to_int32,y:int32)=int32(x),y +proc balance(x:_to_int64,y:int64)=int64(x),y +proc balance(x:_to_sreal,y:sreal)=sreal(x),y +proc balance(x:_to_real,y:real)=real(x),y +proc balance(x:_to_scpx,y:scpx)=scpx(x),y +proc balance(x:_to_cpx,y:cpx)=cpx(x),y +proc div(x:any_int,y:any_int)=if(sz=>r,-1-r)where r=if(sz=>x,abs(x)-1)/if(sz=>y,abs(y))where sz=sign(x,y)==x +proc _divz(x:any_int,y:any_int)=z { + var z,_=balance(x,y) + if(sign(x,y)==x):z=x/y else: z=-1-(abs(x)-1)/abs(y) +} +proc mod(x:real_num,y:real_num)=xx mod yy where xx,yy=balance(x,y) +proc ==(x:num,y:num)=xx==yy where xx,yy=balance(x,y) +proc /=(x:num,y:num)=xx/=yy where xx,yy=balance(x,y) +proc >=(x:real_num,y:real_num)=xx>=yy where xx,yy=balance(x,y) +proc >(x:real_num,y:real_num)=xx>yy where xx,yy=balance(x,y) +proc +(x:num,y:num)=xx+yy where xx,yy=balance(x,y) +proc -(x:num,y:num)=xx-yy where xx,yy=balance(x,y) +proc *(x:num,y:num)=xx*yy where xx,yy=balance(x,y) +proc /(x:num,y:num)=xx/yy where xx,yy=balance(x,y) +proc **(x:num,y:num)=xx**yy where xx,yy=balance(x,y) +proc &(x:num,y:num)=xx&yy where xx,yy=balance(x,y) +proc |(x:num,y:num)=xx|yy where xx,yy=balance(x,y) +proc xor(x:num,y:num)=xx xor yy where xx,yy=balance(x,y) +proc shift(x:num,y:num)=xx shift yy where xx,yy=balance(x,y) +proc max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y) +proc min(x:num,y:num)=min(xx,yy) where xx,yy=balance(x,y) +// bool type +PM__intrinsic PM__assign_var(&bool,bool): "assign_l" +PM__intrinsic string(bool)->(string) : "string_l" +PM__intrinsic and(bool,bool)->(bool) : "and" +PM__intrinsic or(bool,bool)->(bool) : "or" +PM__intrinsic not(bool)->(bool) : "not" +PM__intrinsic ==(bool,bool)->(bool) : "eq_l" +PM__intrinsic /=(bool,bool)->(bool) : "ne_l" + +// Masked types +type masked(x) is rec {_val:x,_there:bool} +proc |(x:masked,y)=if(x._there=>x._val,y) + check "Right operand of ""|"" does not match masked type on the left"=>same_type(x._val,y) + +proc masked(val,there:bool)=new masked { + _val=val,_there=there +} + +proc defined(x:masked)=x._there +proc val(x:masked)=x._val check "masked value is undefined"=>x._there + +proc get(&x,y:masked) { + if y._there{ + x=y._val + } +} + +proc get(&x,y:masked(x)) { + if y._there{ + x=y._val + } + return y._there +} + +// Polymorphic types +PM__intrinsic get(x:*any,y:any)->(=y) : "as" +PM__intrinsic<> get(&x:any,y:*any): "get_poly" +PM__intrinsic<> get(&x:any,y:*any)->(bool) : "get_poly2" +PM__intrinsic<> |(x:*any,y:any)->(=y) : "get_poly_or" + +// val function having null effect +proc val(x)=x + +// ******************************************** +// TUPLES +// ******************************************** + +// Tuple types +type tuple1d(t1) is rec {PM__d1:t1} +type tuple2d(t1,t2) is rec {PM__d1:t1,PM__d2:t2} +type tuple3d(t1,t2,t3) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3} +type tuple4d(t1,t2,t3,t4) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4} +type tuple5d(t1,t2,t3,t4,t5) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5} +type tuple6d(t1,t2,t3,t4,t5,t6) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6} +type tuple7d(t1,t2,t3,t4,t5,t6,t7) is rec {PM__d1:t1,PM__d2:t2,PM__d3:t3,PM__d4:t4,PM__d5:t5,PM__d6:t6,PM__d7:t7} +type tuple1d_of(t) is tuple1d(t) +type tuple2d_of(t) is tuple2d(t,t) +type tuple3d_of(t) is tuple3d(t,t,t) +type tuple4d_of(t) is tuple4d(t,t,t,t) +type tuple5d_of(t) is tuple5d(t,t,t,t,t) +type tuple6d_of(t) is tuple6d(t,t,t,t,t,t) +type tuple7d_of(t) is tuple7d(t,t,t,t,t,t,t) +type tuple(t) is tuple1d(t),tuple2d(t,t),tuple3d(t,t,t),tuple4d(t,t,t,t),tuple5d(t,t,t,t,t), + tuple6d(t,t,t,t,t,t),tuple7d(t,t,t,t,t,t,t) + +proc tuple(x)=new tuple1d { + PM__d1=x +} +proc tuple(x,y)=new tuple2d { + PM__d1=x,PM__d2=y +} +proc tuple(x,y,z)=new tuple3d { + PM__d1=x,PM__d2=y,PM__d3=z +} +proc tuple(x,y,z,t)=new tuple4d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t +} +proc tuple(x,y,z,t,u)=new tuple5d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u +} +proc tuple(x,y,z,t,u,v)=new tuple6d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v +} +proc tuple(x,y,z,t,u,v,w)=new tuple7d { + PM__d1=x,PM__d2=y,PM__d3=z,PM__d4=t,PM__d5=u,PM__d6=v,PM__d7=w +} + +proc get_dim(t:tuple1d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple2d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple3d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple4d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple5d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple6d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple7d,n:'1 or ['1])=t.1 +proc get_dim(t:tuple2d,n:'2 or ['2])=t.2 +proc get_dim(t:tuple3d,n:'2 or ['2])=t.2 +proc get_dim(t:tuple4d,n:'2 or ['2])=t.2 +proc get_dim(t:tuple5d,n:'2 or ['2])=t.2 +proc get_dim(t:tuple6d,n:'2 or ['2])=t.2 +proc get_dim(t:tuple7d,n:'2 or ['2])=t.2 +proc get_dim(t:tuple3d,n:'3 or ['3])=t.3 +proc get_dim(t:tuple4d,n:'3 or ['3])=t.3 +proc get_dim(t:tuple5d,n:'3 or ['3])=t.3 +proc get_dim(t:tuple6d,n:'3 or ['3])=t.3 +proc get_dim(t:tuple7d,n:'3 or ['3])=t.3 +proc get_dim(t:tuple4d,n:'4 or ['4])=t.4 +proc get_dim(t:tuple5d,n:'4 or ['4])=t.4 +proc get_dim(t:tuple6d,n:'4 or ['4])=t.4 +proc get_dim(t:tuple7d,n:'4 or ['4])=t.4 +proc get_dim(t:tuple5d,n:'5 or ['5])=t.5 +proc get_dim(t:tuple6d,n:'5 or ['5])=t.5 +proc get_dim(t:tuple7d,n:'5 or ['5])=t.5 +proc get_dim(t:tuple6d,n:'6 or ['6])=t.6 +proc get_dim(t:tuple7d,n:'6 or ['6])=t.6 +proc get_dim(t:tuple7d,n:'7 or ['7])=t.7 + +proc indices(x:tuple1d)=['1] +proc indices(x:tuple2d)=['1,'2] +proc indices(x:tuple3d)=['1,'2,'3] +proc indices(x:tuple4d)=['1,'2,'3,'4] +proc indices(x:tuple5d)=['1,'2,'3,'4,'5] +proc indices(x:tuple6d)=['1,'2,'3,'4,'5,'6] +proc indices(x:tuple7d)=['1,'2,'3,'4,'5,'6,'7] + +proc full_rank(x:tuple1d)=1 +proc full_rank(x:tuple2d)=2 +proc full_rank(x:tuple3d)=3 +proc full_rank(x:tuple4d)=4 +proc full_rank(x:tuple5d)=5 +proc full_rank(x:tuple6d)=6 +proc full_rank(x:tuple7d)=7 +proc rank(x:tuple)=full_rank(x) + +proc reduce(p:proc,x:tuple1d)=x.1 +proc reduce(p:proc,x:tuple2d)=p.(x.2,x.1) +proc reduce(p:proc,x:tuple3d)=p.(p.(x.3,x.2),x.1) +proc reduce(p:proc,x:tuple4d)=p.(p.(p.(x.4,x.3),x.2),x.1) +proc reduce(p:proc,x:tuple5d)=p.(p.(p.(p.(x.5,x.4),x.3),x.2),x.1) +proc reduce(p:proc,x:tuple6d)=p.(p.(p.(p.(p.(x.6,x.5),x.4),x.3),x.2),x.1) +proc reduce(p:proc,x:tuple7d)=p.(p.(p.(p.(p.(p.(x.7,x.6),x.5),x.4),x.3),x.2),x.1) + +proc map(p:proc,x:tuple1d)=[p.(x.1)] +proc map(p:proc,x:tuple2d)=[p.(x.1),p.(x.2)] +proc map(p:proc,x:tuple3d)=[p.(x.1),p.(x.2),p.(x.3)] +proc map(p:proc,x:tuple4d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4)] +proc map(p:proc,x:tuple5d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5)] +proc map(p:proc,x:tuple6d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6)] +proc map(p:proc,x:tuple7d)=[p.(x.1),p.(x.2),p.(x.3),p.(x.4),p.(x.5),p.(x.6),p.(x.7)] +proc map(p:proc,x:tuple,y:tuple)=error_type() :test "Number of dimensions does not match" => 'false +proc map(p:proc,x:tuple1d,y:tuple1d)=[p.(x.1,y.1)] +proc map(p:proc,x:tuple2d,y:tuple2d)=[p.(x.1,y.1),p.(x.2,y.2)] +proc map(p:proc,x:tuple3d,y:tuple3d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3)] +proc map(p:proc,x:tuple4d,y:tuple4d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4)] +proc map(p:proc,x:tuple5d,y:tuple5d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5)] +proc map(p:proc,x:tuple6d,y:tuple6d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6)] +proc map(p:proc,x:tuple7d,y:tuple7d)=[p.(x.1,y.1),p.(x.2,y.2),p.(x.3,y.3),p.(x.4,y.4),p.(x.5,y.5),p.(x.6,y.6),p.(x.7,y.7)] +proc map(p:proc,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => 'false +proc map(p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=[p.(x.1,y.1,z.1)] +proc map(p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2)] +proc map(p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3)] +proc map(p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4)] +proc map(p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5)] +proc map(p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6)] +proc map(p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=[p.(x.1,y.1,z.1),p.(x.2,y.2,z.2),p.(x.3,y.3,z.3),p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6),p.(x.7,y.7,z.7)] + +proc map(p:proc,w:tuple,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => 'false +proc map(p:proc,w:tuple1d,x:tuple1d,y:tuple1d,z:tuple1d)=[p.(w.1,x.1,y.1,z.1)] +proc map(p:proc,w:tuple2d,x:tuple2d,y:tuple2d,z:tuple2d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2)] +proc map(p:proc,w:tuple3d,x:tuple3d,y:tuple3d,z:tuple3d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3)] +proc map(p:proc,w:tuple4d,x:tuple4d,y:tuple4d,z:tuple4d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4)] +proc map(p:proc,w:tuple5d,x:tuple5d,y:tuple5d,z:tuple5d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5)] +proc map(p:proc,w:tuple6d,x:tuple6d,y:tuple6d,z:tuple6d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6)] +proc map(p:proc,w:tuple7d,x:tuple7d,y:tuple7d,z:tuple7d)=[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6),p.(w.7,x.7,y.7,z.7)] + +proc map(p:proc,x:tuple1d,y:tuple1d)=[u1],[v1]where u1,v1=p.(x.1,y.1) +proc map(p:proc,x:tuple2d,y:tuple2d)=[u1,u2],[v1,v2]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2) +proc map(p:proc,x:tuple3d,y:tuple3d)=[u1,u2,u3],[v1,v2,v3]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3) +proc map(p:proc,x:tuple4d,y:tuple4d)=[u1,u2,u3,u4],[v1,v2,v3,v4]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4) +proc map(p:proc,x:tuple5d,y:tuple5d)=[u1,u2,u3,u4,u5],[v1,v2,v3,v4,v5]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5) +proc map(p:proc,x:tuple6d,y:tuple6d)=[u1,u2,u3,u4,u5,u6],[v1,v2,v3,v4,v5,v6]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),u6,v6=p.(x.6,y.6) +proc map(p:proc,x:tuple7d,y:tuple7d)=[u1,u2,u3,u4,u5,u6,u7],[v1,v2,v3,v4,v5,v6,v7]where u1,v1=p.(x.1,y.1),u2,v2=p.(x.2,y.2),u3,v3=p.(x.3,y.3),u4,v4=p.(x.4,y.4),u5,v5=p.(x.5,y.5),u6,v6=p.(x.6,y.6),u7,v7=p.(x.7,y.7) + +proc map_const(p:proc,x:tuple1d,y)=[p.(x.1,y)] +proc map_const(p:proc,x:tuple2d,y)=[p.(x.1,y),p.(x.2,y)] +proc map_const(p:proc,x:tuple3d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y)] +proc map_const(p:proc,x:tuple4d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y)] +proc map_const(p:proc,x:tuple5d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y)] +proc map_const(p:proc,x:tuple6d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y),p.(x.6,y)] +proc map_const(p:proc,x:tuple7d,y)=[p.(x.1,y),p.(x.2,y),p.(x.3,y),p.(x.4,y),p.(x.5,y),p.(x.6,y),p.(x.7,y)] + +proc map_reduce(q:proc,p:proc,x:tuple1d)=q.(x.1) +proc map_reduce(q:proc,p:proc,x:tuple2d)=p.(q.(x.2),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d)=p.(p.(q.(x.3),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d)=p.(p.(p.(q.(x.4),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d)=p.(p.(p.(p.(q.(x.5),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d)=p.(p.(p.(p.(p.(q.(x.6),q.(x.5)),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7),q.(x.6)),q.(x.5)),q.(x.4)),q.(x.3)),q.(x.2)),q.(x.1)) + +proc map_reduce(q:proc,p:proc,x:tuple,y:tuple)=error_type() :test "Number of dimensions does not match" => 'false +proc map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d)=q.(x.1,y.1) +proc map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d)=p.(q.(x.2,y.2),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d)=p.(p.(q.(x.3,y.3),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d)=p.(p.(p.(q.(x.4,y.4),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d)=p.(p.(p.(p.(q.(x.5,y.5),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d)=p.(p.(p.(p.(p.(q.(x.6,y.6),q.(x.5,y.5)),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7,y.7),q.(x.6,y.6)),q.(x.5,y.5)),q.(x.4,y.4)),q.(x.3,y.3)),q.(x.2,y.2)),q.(x.1,y.1)) + +proc map_reduce(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => 'false +proc map_reduce(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=q.(x.1,y.1,z.1) +proc map_reduce(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=p.(q.(x.2,y.2,z.2),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=p.(p.(q.(x.3,y.3,z.3),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=p.(p.(p.(q.(x.4,y.4,z.4),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=p.(p.(p.(p.(q.(x.5,y.5,z.5),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=p.(p.(p.(p.(p.(q.(x.6,y.6,z.6),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) +proc map_reduce(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=p.(p.(p.(p.(p.(p.(q.(x.7,y.7,z.7),q.(x.6,y.6,z.6)),q.(x.5,y.5,z.5)),q.(x.4,y.4,z.4)),q.(x.3,y.3,z.3)),q.(x.2,y.2,z.2)),q.(x.1,y.1,z.1)) + +proc apply(p:proc,x:tuple1d)=p.(x.1) +proc apply(p:proc,x:tuple2d)=p.(x.1,x.2) +proc apply(p:proc,x:tuple3d)=p.(x.1,x.2,x.3) +proc apply(p:proc,x:tuple4d)=p.(x.1,x.2,x.3,x.4) +proc apply(p:proc,x:tuple5d)=p.(x.1,x.2,x.3,x.4,x.5) +proc apply(p:proc,x:tuple6d)=p.(x.1,x.2,x.3,x.4,x.5,x.6) +proc apply(p:proc,x:tuple7d)=p.(x.1,x.2,x.3,x.4,x.5,x.6,x.7) + +proc map_apply(q:proc,p:proc,x:tuple1d)=p.(q.(x.1)) +proc map_apply(q:proc,p:proc,x:tuple2d)=p.(q.(x.1),q.(x.2)) +proc map_apply(q:proc,p:proc,x:tuple3d)=p.(q.(x.1),q.(x.2),q.(x.3)) +proc map_apply(q:proc,p:proc,x:tuple4d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4)) +proc map_apply(q:proc,p:proc,x:tuple5d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5)) +proc map_apply(q:proc,p:proc,x:tuple6d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5),q.(x.6)) +proc map_apply(q:proc,p:proc,x:tuple7d)=p.(q.(x.1),q.(x.2),q.(x.3),q.(x.4),q.(x.5),q.(x.6),q.(x.7)) + +proc map_apply(q:proc,p:proc,x:tuple,y:tuple)=error_type():test "Number of dimensions does not match" => 'false +proc map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d)=p.(q.(x.1,y.1)) +proc map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d)=p.(q.(x.1,y.1),q.(x.2,y.2)) +proc map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3)) +proc map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4)) +proc map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5)) +proc map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5),q.(x.6,y.6)) +proc map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d)=p.(q.(x.1,y.1),q.(x.2,y.2),q.(x.3,y.3),q.(x.4,y.4),q.(x.5,y.5),q.(x.6,y.6),q.(x.7,y.7)) + +proc map_apply(q:proc,p:proc,x:tuple,y:tuple,z:tuple)=error_type() :test "Number of dimensions does not match" => 'false +proc map_apply(q:proc,p:proc,x:tuple1d,y:tuple1d,z:tuple1d)=p.(q.(x.1,y.1,z.1)) +proc map_apply(q:proc,p:proc,x:tuple2d,y:tuple2d,z:tuple2d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2)) +proc map_apply(q:proc,p:proc,x:tuple3d,y:tuple3d,z:tuple3d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3)) +proc map_apply(q:proc,p:proc,x:tuple4d,y:tuple4d,z:tuple4d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4)) +proc map_apply(q:proc,p:proc,x:tuple5d,y:tuple5d,z:tuple5d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5)) +proc map_apply(q:proc,p:proc,x:tuple6d,y:tuple6d,z:tuple6d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5),q.(x.6,y.6,z.6)) +proc map_apply(q:proc,p:proc,x:tuple7d,y:tuple7d,z:tuple7d)=p.(q.(x.1,y.1,z.1),q.(x.2,y.2,z.2),q.(x.3,y.3,z.3),q.(x.4,y.4,z.4),q.(x.5,y.5,z.5),q.(x.6,y.6,z.6),q.(x.7,y.7,z.7)) + +proc scan(p:proc,x:tuple1d)=x.1 +proc scan(p:proc,x:tuple2d)=[x.1,p.(x.1,x.2)] +proc scan(p:proc,x:tuple3d)=[x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple4d)=[x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple5d)=[x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple6d)=[x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc scan(p:proc,x:tuple7d)=[x.1,x2,x3,x4,x5,x6,p.(x6,x.7)] where x6=p.(x5,x.6) where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) + +proc pre_scan(p:proc,x:tuple1d,x0)=x0 +proc pre_scan(p:proc,x:tuple2d,x0)=[x0,x.1] +proc pre_scan(p:proc,x:tuple3d,x0)=[x0,x.1,p.(x.1,x.2)] +proc pre_scan(p:proc,x:tuple4d,x0)=[x0,x.1,x2,p.(x2,x.3)] where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple5d,x0)=[x0,x.1,x2,x3,p.(x3,x.4)] where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple6d,x0)=[x0,x.1,x2,x3,x4,p.(x4,x.5)] where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +proc pre_scan(p:proc,x:tuple7d,x0)=[x0,x.1,x2,x3,x4,x5,p.(x5,x.6)] where x5=p.(x4,x.5) where x4=p.(x3,x.4) where x3=p.(x2,x.3) where x2=p.(x.1,x.2) +type empty_head is unique + +proc head(x:null)=empty_head +proc head(x:tuple)=x.1 + +proc tail(x:null)=null +proc tail(x:tuple1d)=null +proc tail(x:tuple2d)=[x.2] +proc tail(x:tuple3d)=[x.2,x.3] +proc tail(x:tuple4d)=[x.2,x.3,x.4] +proc tail(x:tuple5d)=[x.2,x.3,x.4,x.5] +proc tail(x:tuple6d)=[x.2,x.3,x.4,x.5,x.6] +proc tail(x:tuple7d)=[x.2,x.3,x.4,x.5,x.6,x.7] + +proc prepend(y,x:null)=[y] +proc prepend(y,x:tuple1d)=[y,x.1] +proc prepend(y,x:tuple2d)=[y,x.1,x.2] +proc prepend(y,x:tuple3d)=[y,x.1,x.2,x.3] +proc prepend(y,x:tuple4d)=[y,x.1,x.2,x.3,x.4] +proc prepend(y,x:tuple5d)=[y,x.1,x.2,x.3,x.4,x.5] +proc prepend(y,x:tuple6d)=[y,x.1,x.2,x.4,x.4,x.5,x.6] +proc prepend(y,x:tuple7d)=error_type() :test "Cannot add dimension to 7d tuple" => 'false + +proc append(x:null,y)=[y] +proc append(x:tuple1d,y)=[x.1,y] +proc append(x:tuple2d,y)=[x.1,x.2,y] +proc append(x:tuple3d,y)=[x.1,x.2,x.3,y] +proc append(x:tuple4d,y)=[x.1,x.2,x.3,x.4,y] +proc append(x:tuple5d,y)=[x.1,x.2,x.3,x.4,x.5,y] +proc append(x:tuple6d,y)=[x.1,x.2,x.4,x.4,x.5,x.6,y] +proc append(y,x:tuple7d)=error_type() :test "Cannot add dimension to 7d tuple" => 'false + +proc elems(x:tuple1d)=x.1 +proc elems(x:tuple2d)=x.1,x.2 +proc elems(x:tuple3d)=x.1,x.2,x,3 +proc elems(x:tuple4d)=x.1,x.2,x.3,x.4 +proc elems(x:tuple5d)=x.1,x.2,x.3,x.4,x.5 +proc elems(x:tuple6d)=x.1,x.2,x.3,x.4,x.5,x.6 +proc elems(x:tuple7d)=x.1,x.2,x.3,x.4,x.5,x.6,x.7 + +proc replace(x:tuple1d,y:'1,z)=[z] +proc replace(x:tuple2d,y:'1,z)=[z,x.2] +proc replace(x:tuple3d,y:'1,z)=[z,x.2,x.3] +proc replace(x:tuple4d,y:'1,z)=[z,x.2,x.3,x.4] +proc replace(x:tuple5d,y:'1,z)=[z,x.2,x.3,x.4,x.5] +proc replace(x:tuple6d,y:'1,z)=[z,x.2,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:'1,z)=[z,x.2,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple2d,y:'2,z)=[x.1,z] +proc replace(x:tuple3d,y:'2,z)=[x.1,z,x.3] +proc replace(x:tuple4d,y:'2,z)=[x.1,z,x.3,x.4] +proc replace(x:tuple5d,y:'2,z)=[x.1,z,x.3,x.4,x.5] +proc replace(x:tuple6d,y:'2,z)=[x.1,z,x.3,x.4,x.5,x.6] +proc replace(x:tuple7d,y:'2,z)=[x.1,z,x.3,x.4,x.5,x.6,x.7] +proc replace(x:tuple3d,y:'3,z)=[x.1,x.2,z] +proc replace(x:tuple4d,y:'3,z)=[x.1,x.2,z,x.4] +proc replace(x:tuple5d,y:'3,z)=[x.1,x.2,z,x.4,x.5] +proc replace(x:tuple6d,y:'3,z)=[x.1,x.2,z,x.4,x.5,x.6] +proc replace(x:tuple7d,y:'3,z)=[x.1,x.2,z,x.4,x.5,x.6,x.7] +proc replace(x:tuple4d,y:'4,z)=[x.1,x.2,x.3,z] +proc replace(x:tuple5d,y:'4,z)=[x.1,x.2,x.3,z,x.5] +proc replace(x:tuple6d,y:'4,z)=[x.1,x.2,x.3,z,x.5,x.6] +proc replace(x:tuple7d,y:'4,z)=[x.1,x.2,x.3,z,x.5,x.6,x.7] +proc replace(x:tuple5d,y:'5,z)=[x.1,x.2,x.3,x.4,z] +proc replace(x:tuple6d,y:'5,z)=[x.1,x.2,x.3,x.4,z,x.6] +proc replace(x:tuple7d,y:'5,z)=[x.1,x.2,x.3,x.4,z,x.6,x.7] +proc replace(x:tuple6d,y:'6,z)=[x.1,x.2,x.3,x.4,x.5,z] +proc replace(x:tuple7d,y:'6,z)=[x.1,x.2,x.3,x.4,x.5,z,x.7] +proc replace(x:tuple7d,y:'7,z)=[x.1,x.2,x.3,x.4,x.5,x.6,z] + +proc spread(x,y:tuple1d or '1)=[x] +proc spread(x,y:tuple2d or '2)=[x,x] +proc spread(x,y:tuple3d or '3)=[x,x,x] +proc spread(x,y:tuple4d or '4)=[x,x,x,x] +proc spread(x,y:tuple5d or '5)=[x,x,x,x,x] +proc spread(x,y:tuple6d or '6)=[x,x,x,x,x,x] +proc spread(x,y:tuple7d or '7)=[x,x,x,x,x,x,x] + +proc +(x:tuple(num),y:tuple(num))=map($+,x,y) +proc -(x:tuple(num),y:tuple(num))=map($-,x,y) +proc *(x:tuple(num),y:tuple(num))=map($*,x,y) +proc /(x:tuple(num),y:tuple(num))=map($/,x,y) +proc **(x:tuple(num),y:tuple(num))=map($**,x,y) +proc mod(x:tuple(num),y:tuple(num))=map($mod,x,y) +proc +(x:tuple(num),y:num)=map_const($+,x,y) +proc -(x:tuple(num),y:num)=map_const($-,x,y) +proc *(x:tuple(num),y:num)=map_const($*,x,y) +proc /(x:tuple(num),y:num)=map_const($/,x,y) +proc **(x:tuple(num),y:num)=map_const($**,x,y) +proc mod(x:tuple(num),y:num)=map_const($mod,x,y) +proc max(x:tuple(real_num),y:tuple(real_num))=map($max,x,y) +proc min(x:tuple(real_num),y:tuple(real_num))=map($min,x,y) +proc max(x:tuple(real_num))=reduce($max,x) +proc min(x:tuple(real_num))=reduce($min,x) +proc sum(x:tuple(num))=reduce($+,x) +proc prod(x:tuple(num))=reduce($*,x) +proc sint(x:tuple(num))=map($sint,x) +proc int(x:tuple(num))=map($int,x) +proc sreal(x:tuple(num))=map($sreal,x) +proc real(x:tuple(num))=map($real,x) + +proc string(x:tuple1d)="[ "++x.1++" ]" +proc string(x:tuple2d)="[ "++x.1++", "++x.2++" ]" +proc string(x:tuple3d)="[ "++x.1++", "++x.2++", "++x.3++" ]" +proc string(x:tuple4d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++" ]" +proc string(x:tuple5d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++" ]" +proc string(x:tuple6d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++" ]" +proc string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++", "++x.6++", "++x.7++" ]" + +// ***************************************************** +// LISTS +// ***************************************************** + +type _list_node(H,T) is struct{_head:H,_tail:T} +type list(T) is _list_node(T,T or _list_node(T,list(T))) +type _list_end is unique + +proc _cons(a,b)=new _list_node{_head=a,_tail=b} + +proc list(a)<>=_cons(a,_list_end) +proc list(a,arg...)<>=_cons(a,list(arg...)) + +proc reduce(p,a:_list_node)=p.(a._head,reduce(p,a._tail)) +proc reduce(p,a:_list_node(,_list_end))=a._head + +proc map(p,&a:_list_node){p.(a._head);map(p,a._tail)} +proc map(p,&a:_list_node(,_list_end)):p.(a._head) + +proc map(p,&a:_list_node(,_list_node),b:_list_node(,_list_node)){p.(&a._head,b._head);map(p,&a._tail,b._tail)} +proc map(p,&a:_list_node(,_list_end),b:_list_node(,_list_end)):p.(&a._head,b._head) +proc map(p,&a:_list_node,b:_list_node): test "List lengths do not match"=>'false + +proc map_const(p,&a:_list_node(,_list_node),b){p.(&a._head,b);map_const(p,&a._tail,b)} +proc map_const(p,&a:_list_node(,_list_end),b):p.(&a._head,b) + +proc PM__assign(&a:list,b:list):map($PM__assign,&a,b) +proc PM__assign(&a:list,b):map_const($PM__assign,&a,b) + +proc map(p,a:_list_node)=_cons(p.(a._head),map(p,a._tail)) +proc map(p,a:_list_node(,_list_end))=_cons(p.(a._head),_list_end) + +proc map(p,a:_list_node(,_list_node),b:_list_node(,_list_node))=_cons(p.(a._head,b._head),map(p,a._tail,b._tail)) +proc map(p,a:_list_node(,_list_end),b:_list_node(,_list_end))=_cons(p.(a._head,b._head),_list_end) +proc map(p,a:_list_node,b:_list_node)=_cons(p.(a._head,b._head),_list_end) check "List lengths do not match"=>'false + +proc [](a:list,b:fix int)=_list_elem(a,b,1) +proc _list_elem(a:_list_node(,_list_node),b:fix int,c:fix int) { + const d + if '(b==c) { + d=a._head + } else { + d=_list_elem(a,b,c+1) + } + return d +} +proc _list_elem(a:_list_node(,_list_end),b:fix int,c:fix int) { + test "List element out of range"=>a==b + return a._head +} + +// ***************************************************** +// RANGES AND SEQUENCES +// ***************************************************** + +// Not in operator +proc notin(x,y)=not(x in y) + +// not inc operator +proc notinc(x,y)=not(x inc y) + +// Treat null as empty sequence in some cases +proc in(x,y:null)='false +proc in(x:null,y:null)='true + +// Range base type (might later expand to interface) +type range_base is real_num + +// Single point sequence +type single_point(t:range_base) is rec {_t:t} +proc single_point(x)=new single_point { + _t=x +} +proc low(x:single_point)=x._t +proc high(x:single_point)=x._t +proc step(x:single_point)=x._t +proc width(x:single_point)='1 +proc norm(x:single_point)=x +proc #(x:single_point)=shape(['0..'0]) +proc _shp(x:single_point)='0..'0 +proc dims(x:single_point)=['1] +proc size(x:single_point)='1 +proc +(x:single_point,y:range_base)=new single_point { + _t=x._t+y +} +proc -(x:single_point,y:range_base)=new single_point { + _t=x._t-y +} +proc _arb(x:single_point)=x._t +proc in(x:range_base,y:single_point)=x==y._t +proc inc(x:single_point,y:seq)=low(y)==x._t and high(y)==x._t +proc convert(x:single_point,y:range_base)=single_point(convert(x._t,y)) +proc sint(x:single_point)=single_point(sint(x._t)) +proc int(x:single_point)=single_point(int(x._t)) +proc sreal(x:single_point)=single_point(sreal(x._t)) +proc real(x:single_point)=single_point(real(x._t)) +proc #(x:single_point,y:index)='0 +proc #(x:single_point,y:grid_slice_dim)='0..'0 +proc #(x:single_point,y:single_point)='0..'0 +proc #(x:grid_slice_dim,y:single_point)=single_point(xx) where xx=x#y._t +proc overlap(x:single_point(any_int),y:single_point(any_int))=0..if(x._t==y._t=>0,-1) +proc overlap(x:grid_slice_dim,y:single_point(any_int))=if(y._t in x=>x#y._t..x#y._t,0..-1) +proc overlap(x:single_point(any_int),y:grid_slice_dim)=0..if(x._t in y=>0,-1) +proc overlap(x:single_point(any_int),y:single_point(any_int))=overlap(x,y),overlap(y,x) +proc overlap(x:grid_slice_dim,y:single_point(any_int))=overlap(x,y),overlap(y,x) +proc overlap(x:single_point(any_int),y:grid_slice_dim)=overlap(x,y),overlap(y,x) +proc intersect(x:single_point(any_int),y:grid_slice_dim)=x._t..if(x._t in y=>x._t,x._t-1) +proc intersect(y:grid_slice_dim,x:single_point(any_int))=x._t..if(x._t in y=>x._t,x._t-1) +proc intersect(x:single_point(any_int),y:single_point(any_int))=x._t..if(x._t==y._t=>x._t,x._t-1) +proc element(x:single_point,y:index)=x._t +proc element(x:single_point,y:subs)=x._t..x._t +proc element(x,y:single_point)=element(x,y._t) +proc string(x:single_point)=string("single "++x._t) + +// Range types +type range(t:range_base) is rec {_lo:t,_hi:t,_n:t} +proc ..(x:range_base,y:range_base)=new range { +_lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) +proc low(x:range)=x._lo +proc high(x:range)=x._hi +proc step(x:range)=convert(1,x._lo) +proc width(x:range)='1 +proc norm(x:range)=x +proc #(x:range(int))=shape([0..x._n-1]) +proc dims(x:range(int))=[x._n] +proc size(x:range(int))=x._n +proc +(x:range,y:range_base)=new range { + _lo=x._lo+y,_hi=x._hi+y,_n=x._n +} +proc -(x:range,y:range_base)=new range { + _lo=x._lo-y,_hi=x._hi-y,_n=x._n +} +proc _arb(x:range)=low(x) +proc in(x:range_base,y:range())=x>=y._lo and x<=y._hi +proc convert(x:range,y:range_base)=new range { + _lo=convert(x._lo,y),_hi=convert(x._hi,y),_n=x._n +} +proc sint(x:range)=new range { + _lo=sint(x._lo),_hi=sint(x._hi),_n=x._n +} +proc int(x:range)=new range { + _lo=int(x._lo),_hi=int(x._hi),_n=x._n +} +proc sreal(x:range)=new range { + _lo=sreal(x._lo),_hi=sreal(x._hi) +} +proc real(x:range)=new range { + _lo=real(x._lo),_hi=real(x._hi),_n=x._n +} +proc inc(x:range,y:seq())= low(y)>=x._lo and high(y)<=x._hi +proc element(x:range(any_int),y:int)=x._lo+convert(y,x._lo) +proc element(x:range(any_int),y:range(int))=element(x,y._lo)..element(x,y._hi) +proc element(x:range(any_int),y:seq(int))=element(x,y._lo)..element(x,y._hi) by y._st +proc element(x:range(any_int),y:null)=x +proc element(x:range(any_int),y:grid_dim)=y+x._lo +proc #(y:range(any_int),x:int)=int(x-y._lo) +proc #(y:range(any_int),x:range(int))=int(x._lo-y._lo)..int(x._hi-y._lo) +proc #(y:range(any_int),x:seq(int))=_intseq(int(x._lo-y._lo),int(x._hi-y._lo), x._st) +proc #(y:range(any_int),x:range_below(int))=0..int(x._t-y._lo) +proc #(y:range(any_int),x:range_above(int))=int(x._t-y._lo)..size(y)-1 +proc #(y:range(any_int),x:strided_range_below(int))=_intseq(0,int(x._t-y._lo),x._st) +proc #(y:range(any_int),x:strided_range_above(int))=_intseq(int(x._t-y._lo),size(y)-1,int(x._st)) +proc #(y:range(any_int),x:stride(int))=_intseq(0,size(y),int(x._st)) +proc #(y:range(any_int),x:null)=0..size(y) +proc intersect(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)..min(y._hi,x._hi) +proc overlap(x:range(any_int),y:range(any_int))=max(y._lo,x._lo)-x._lo..min(y._hi,x._hi)-x._lo +proc expand(x:range,y:range)=x._lo+y._lo..x._hi+y._hi +proc contract(x:range,y:range)=x._lo-y._lo..x._hi-y._hi +proc empty(x:range)=new range { + _lo=x._hi,_hi=x._lo,_n=0 +} +proc string(x:range)=string(x._lo)++".."++(x._hi) +// Cyclic range types (limited functionality and not part of grid) +type cyclic_range is rec {_lo:int,_hi:int,_w:int,_n:int} +proc cyclic_range(x:int,y:int,w:int)=new cyclic_range { +_lo=xx,_hi=yy,_w=w,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y) +proc low(x:cyclic_range)=x._lo +proc high(x:cyclic_range)=x._hi +proc size(x:cyclic_range)=x._n +proc element(x:cyclic_range,y:int)=(x._lo + y) mod x._w +proc string(x:cyclic_range)="cycle("++x._lo++".."++x._hi++","++x._w++")" +// Strided range types +type strided_range(t:range_base) is rec {_lo:t,_hi:t,_st:t,_n:int} +type _any_seq(t:range_base):iterable is strided_range(t), ... +type _any_seq(t:any_int) is ..., range(t) +type seq(t:range_base) is _any_seq(t) +proc _seq(lo,hi,st)=new strided_range { +_lo=lo,_hi=lo+(n-1)*st,_st=st,_n=n}check "Zero step size in strided range"=>st/=0 where n=max(0,1+_rdiv(int((hi-lo)),int(st))) +proc by(x:range(int),y:range_base)=_seq(lo,hi,st) where hi=convert(x._hi,lo) where lo,st=balance(x._lo,y) +proc by(x:seq,y:range_base)=_seq(lo,hi,st) where lo=convert(x._lo,st),hi=convert(x._hi,st) where st=x._st*y +proc _intseq(x:int,y:int,st:int)= new strided_range { +_lo=x,_hi=x+n*s,_st=s,_n=n} where s=if(x>y=>-abs(st),abs(st)) where n=abs((y-x)/st) +proc low(x:strided_range)=x._lo +proc high(x:strided_range)=x._hi +proc step(x:strided_range)=x._st +proc size(x:strided_range)=x._n +proc width(x:strided_range)='1 +proc norm(x:strided_range)=min(lo,hi)..max(lo,hi) by abs(x._st)where hi=lo+(x._n-1)*x._st where lo=x._lo +proc align(x:seq)='0 +proc #(x:strided_range)=shape([0..x._n-1]) +proc dims(x:strided_range)=[x._n] +proc +(x:strided_range,y:range_base)=new strided_range { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_n=x._n +} +proc -(x:strided_range,y:range_base)=new strided_range { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_n=x._n +} +proc _arb(x:seq)=x._lo +proc convert(x:strided_range,y:range_base)=new strided_range { + _lo=convert(x._lo,y),_hi=convert(x._hi,y),_st=convert(x._st,y),_n=x._n +} +proc sint(x:strided_range)=new strided_range { + _lo=sint(x._lo),_hi=sint(x._hi),_st=sint(x._st),_n=x._n +} +proc int(x:strided_range)=new strided_range { + _lo=int(x._lo),_hi=int(x._hi),_st=int(x._st),_n=x._n +} +proc sreal(x:strided_range)=new strided_range { + _lo=sreal(x._lo),_hi=sreal(x._hi),_st=sreal(x._st),_n=x._n +} +proc real(x:strided_range)=new strided_range { + _lo=real(x._lo),_hi=real(x._hi),_st=real(x._st),_n=x._n +} +proc in(x:int,y:strided_range(int))=y._lo<=x and x<=y._hi and (x-y._lo) mod y._st==0 +proc inc(x:strided_range(int),y:strided_range(int))=y._lo in x and y._hi in x and (y._n==1 or y._lo+y._st in x) +proc inc(x:strided_range(int),y:range(int) or single_point(int))=x inc low(y)..high(y) by 1 +proc #(y:seq,x:range_base)=int((x-y._lo)/y._st) +proc #(y:seq,x:range)=y#x._lo..y#x._hi +proc #(y:seq,x:seq)=_intseq(lo,hi,int(x._st)) where lo=y#x._lo,hi=y#x._hi +proc #(y:seq,x:range_below)=0..y#x._t +proc #(y:seq,x:range_above)=y#x._t..size(y)-1 +proc #(y:seq,x:strided_range_below)=_intseq(0,y#x._t,int((x._st+y._st/2)/y._st)) +proc #(y:seq,x:strided_range_above)=_intseq(y#x._t,size(y)-1,int((x._st+y._st/2)/y._st)) +proc #(y:seq,x:stride)=_intseq(0,size(y),int((x._st+y._st/2)/y._st)) +proc #(y:seq,x:null)=0..size(y)-1 +proc string(x:strided_range)=x._lo++".."++x._hi++" by "++x._st +proc element(x:strided_range,y:int)=x._lo+convert(y,x._lo)*x._st +proc element(x:strided_range,y:range(int))=_seq(element(x,y._lo),element(x,y._hi),x._st) +proc element(x:strided_range,y:strided_range(int))=_seq(element(x,y._lo),element(x,y._hi),convert(st*y._st,st)) where st=x._st +proc element(x:strided_range,y:null)=x +proc overlap(x:strided_range(any_int),y:range(any_int))= max(0,(y._lo-x._lo+x._st-1)/x._st)..min(x._n,(y._hi-x._lo)/x._st) +proc overlap(x:range(any_int),y:strided_range(any_int))=max((-d+y._st-1)/y._st*y._st+d,d)..min(x._n,y._hi-x._lo) by y._st where d=y._lo-x._lo +proc intersect(x:strided_range(any_int),y:range(any_int))=x._lo+max(convert(0,n1),n1)*x._st..x._lo+min(convert(x._n,n2),n2)*x._st by x._st where n1=(y._lo-x._lo+x._st-1)/x._st,n2=(y._hi-x._lo)/x._st +proc intersect(x:range(any_int),y:strided_range(any_int))=intersect(y,x) +PM__intrinsic _intersect_seq(int,int,int,int,int,int,int,int)->(int,int,int,int) : "intersect_seq" +proc intersect(x:strided_range(any_int),y:strided_range(any_int))=new strided_range { +_lo=lo,_hi=hi,_st=st,_n=n}where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),int(y._lo),int(y._hi),int(y._st),int(y._n)) +proc overlap(x:strided_range(any_int),y:strided_range(any_int))=new strided_range { +_lo=(lo-x._lo)/x._st,_hi=(hi-x._lo)/x._st,_st=if(sst/=0=>sst,1),_n=n} where sst=st/x._st where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n), int(y._lo),int(y._hi),int(y._st),int(y._n)) +proc empty(x:strided_range(any_int))=new strided_range { + _lo=x._hi,_hi=x._lo,_st=x._st,_n=0 +} +// Block sequence +type block_seq is rec { _lo:int,_hi:int,_st:int,_b:int,_n:int,_align:int} +proc block_seq(lo:int,hi:int,st:int,b:int,align:int){ + test "Block sequence width must be non-negative: "++b=>b>=0 + test "Block sequence width must be less than step: "++b++">="++st=>b<=st + test "Block sequence alignment must be less that width: "++align++">="++b=>align1..0,x._lo..x._lo-x._align+x._b-1) +proc last_block(x:block_seq)=low..min(low+x._b,x._hi) where low=x._lo-x._align+nb*x._st where nb=(x._hi-x._lo+x._align+x._st-x._b+1)/x._st +proc middle_blocks(x:block_seq)=new block_seq { +_lo=low,_hi=low+nb*x._st-1,_st=x._st,_b=x._b,_n=nb*x._b,_align=0}where nb=(x._hi-low+x._st-x._b+1)/x._st where low=if(x._align==0=>x._lo,x._lo-x._align+x._st) +proc string(x:block_seq)=x._lo++".."++x._hi++" by "++x._st++" width "++x._b++" align "++x._align +proc low(x:block_seq)=x._lo +proc high(x:block_seq)=x._hi +proc step(x:block_seq)=x._st +proc width(x:block_seq)=x._b +proc norm(x:block_seq)=x +proc align(x:block_seq)=x._align +proc #(x:block_seq)=shape([0..x._n-1]) +proc dims(x:block_seq)=x._n +proc size(x:block_seq)=x._n +proc +(x:block_seq,y:int)=new block_seq { + _lo=x._lo+y,_hi=x._hi+y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc -(x:block_seq,y:int)=new block_seq { + _lo=x._lo-y,_hi=x._hi-y,_st=x._st,_b=x._b,_n=x._n,_align=x._align +} +proc _arb(x:block_seq)=x._lo +proc in(x:int,y:block_seq)=x>=y._lo and x<=y._hi and (x-y._lo+y._align) mod y._st=x._b:lo=nblo+x._st + if hi-nbhi>=x._b:hi=nbhi+x._b-1 + align=base-(base/x._st)*x._st where base=lo-oldbase + return block_seq(lo,hi,x._st,x._b,align) +} + +proc intersect(x:range(any_int),y:block_seq)=intersect(y,x) +proc overlap(x:range(any_int),y:block_seq) { + z=intersect(y,x) + return block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) +} +proc overlap(x:block_seq,y:range(any_int)) { + z=intersect(x,y) + return start..start+size(z)-1 where start=z#z._lo +} +proc overlap(x:block_seq,y:range(any_int)) { + z=intersect(x,y) + return start..start+size(z)-1, block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align) where start=z#z._lo +} +proc overlap(x:range(any_int),y:block_seq)=xx,yy where yy,xx=overlap(y,x) +proc empty(x:block_seq)=block_seq(1,0,1,1,0) +// Mapped sequence +type map_seq(t:array(int)) is rec {array:t} +proc map_seq(x:grid_dim){ + var a=array(0,#x) + forall i in a,j in x:i=j + return new map_seq{ + array=a + } +} +proc map_seq(x:array(int,mshape1d))=new map_seq { +array=x} check "Array for ""map_seq"" must be strictly increasing or stricly decreasing"=>_mono(x) +proc _mono(x) { + xs=#x + var ok=true + if x[low(xs.1)]x[i-1]:sync ok=false + } + return ok +} +proc map_seq(x:map_seq)=x +proc #(x:map_seq)=#(x.array) +proc dims(x:map_seq)=size(x.array) +proc size(x:map_seq)=size(x.array) +proc +(x:map_seq,y:range_base)=new map_seq{ + array=x.array+y +} +proc -(x:map_seq,y:range_base)=new map_seq{ + array=x.array-y +} +proc _arb(x:map_seq)=_arb(x.array) +proc element(x:map_seq,y:int)=element(x.array,y) +PM__intrinsic _intersect_aseq(&any,any,any,any,any,&any): "intersect_aseq" +PM__intrinsic _overlap_aseq(&any,any,any,any,any,&any): "intersect_aseq"(1) +PM__intrinsic _overlap_aseq2(&any,any,any,any,any,&any,&any): "intersect_aseq"(2) +PM__intrinsic _expand_aseq(&any,any,any,&any,any,any): "expand_aseq" +PM__intrinsic _intersect_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq" +PM__intrinsic _overlap_bseq(&any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(1) +PM__intrinsic _overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any): "intersect_bseq"(2) +PM__intrinsic _includes_aseq(any,any,any,any)->(bool) : "includes_aseq" +PM__intrinsic _index_aseq(any,any,any)->(int) : "index_aseq" +PM__intrinsic _in_aseq(any,any,any)->(bool) : "in_aseq" +proc intersect(x:block_seq,y:block_seq)=intersect(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=overlap(map_seq(x),map_seq(y)) +proc overlap(x:block_seq,y:block_seq)=v,w where v,w=overlap(map_seq(x),map_seq(y)) +proc intersect(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _intersect_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=new map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq(&n,x.array,size(x.array),y.array,size(y.array),&a) + v=new map_seq { + array=a[0..n-1] + } + return v +} +proc overlap(x:map_seq,y:map_seq) { + var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var b=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]) + var n=0 + _overlap_aseq2(&n,x.array,size(x.array),y.array,size(y.array),&a,&b) + ns=[0..n-1] + v=new map_seq { + array=a[ns] + } + w=new map_seq { + array=b[ns] + } + return v,w +} +proc overlap(x:seq,y:seq)=overlap(x,y),overlap(y,x) +proc expand(t:map_seq,i:range(any_int)) { + var a=array(0,[0..max(1,size(t)*max(1,size(i))-1)]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i)) + v=new map_seq { + array=a[0..m-1] + } + return v +} +proc inc(x:map_seq,y:map_seq)=_includes_aseq(x.array,size(x.array),y.array,size(y.array)) +proc inc(x:map_seq,y:seq or block_seq)=x inc map_seq(y) +proc inc(x:block_seq,y:block_seq)=map_seq(x) inc map_seq(y) +proc inc(x:seq or block_seq,y:map_seq)=map_seq(x) inc y +proc in(y:any_int,x:map_seq)=_in_aseq(x.array,size(x.array),int(y)) +proc #(x:map_seq,y:any_int)=_index_aseq(x.array,size(x.array),int(y)) +proc empty(x:map_seq) { + a=array(0,[1..0]) + return new map_seq { + array=a + } +} +// Grids (tuples of sequences) +type _grid_dim(t:range_base) is seq(t),... +type _grid_dim(t:int) is ...,block_seq,map_seq +type grid_dim(t:range_base) is _grid_dim(t) +type grid1d(t1:grid_dim) is [t1] +type grid2d(t1:grid_dim,t2:grid_dim) is [t1,t2] +type grid3d(t1:grid_dim,t2:grid_dim,t3:grid_dim) is [t1,t2,t3] +type grid4d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim) is [t1,t2,t3,t4] +type grid5d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim) is [t1,t2,t3,t4,t5] +type grid6d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim,t6:grid_dim) is [t1,t2,t3,t4,t5,t6] +type grid7d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,t5:grid_dim,t6:grid_dim,t7:grid_dim) is [t1,t2,t3,t4,t5,t6,t7] +type grid(t:range_base) is tuple(grid_dim(t)) +proc #(x:grid)=shape(map($_shp,x)) +proc dims(x:grid)=map($_size,x) +proc +(x:grid,y:tuple(range_base))=map($+,x,y) +proc -(x:grid,y:tuple(range_base))=map($+,x,y) +proc empty(x:grid)=map($empty,x) +proc element(x:grid_dim,y:grid_dim){ + var a=array(0,#y) + forall i in a,j in y:i=x[j] + return new map_seq{ + array=a + } +} +proc element(x:grid,y:grid)=map($element,x,y) +// Slices of grids (may have dims that are just an integer and also _ or _() or null) +type grid_slice_dim(t:range_base) is grid_dim(t),single_point(t),null +type grid_slice(t) is grid(t),tuple(grid_slice_dim(t)) +// Some limited functionality for extended grids (which include cyclic ranges) +type iterable_dim is grid_slice_dim,cyclic_range,... +type iterable_grid is tuple(iterable_dim),grid_slice +proc _shp(x:iterable_dim)=0..size(x)-1 +proc size(x:iterable_dim)->(int)... +proc element(x:iterable_dim,y)=error_type()check "Cannot index this type with a non-integer index"=>'false +proc element(x:iterable_dim,y:int)->(any)... +proc element(x:iterable_dim,y:tuple1d)=element(x,y.1) +proc _shp(x:stretch_dim)=null +proc _shp(x:null)=x +proc _size(x:stretch_dim or null)='1 +proc _size(x)=size(x) +PM__intrinsic _act(x:single_point)->(PM__tinyint) : "miss_arg" +proc _act(x)=x +proc _sliceit(arg...)=tuple(arg...) +proc active_dims(x:iterable_grid)=map_apply($_act,$_sliceit,x) +proc active_dims(x:single_point)=null +PM__intrinsic _act(x:single_point,y:any)->(PM__tinyint) : "miss_arg" +proc _act(x,y)=y +proc active_dims(x:iterable_grid,y:tuple)=map_apply($_act,$_sliceit,x,y) +proc active_dims(x:single_point,y)=null +proc _ar(x:single_point)=0 +proc _ar(x)=1 +proc rank(x:iterable_grid)=map_reduce($_ar,$+,x) +proc element(x:iterable_grid,y:index){ + t=_tup(y) + return _ges(head(x),tail(x),head(t),tail(t),'false) +} +proc element(x:grid_slice,arg...:grid_slice){ + t=_tup(arg...) + return _ges(head(x),tail(x),head(t),tail(t),'true) +} + +proc element(x:null,y)=null +proc _spnt(i,y:'true)=i +proc _spnt(i,y:'false)=i._t +proc _spif(i:int,y:'true)=single_point(i) +proc _spif(i,y:'true)=i +proc _spif(i,y:'false)=i +proc _ges(i:single_point,x,j,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t)) +proc _ges(i:empty_head,x,j,y,t)=error_type() :test "Rank mismatch in subscript" => 'false +proc _ges(i,x,j,y,t)=prepend(_spif(element(i,j),t),_ges(head(x),tail(x),head(y),tail(y),t)) +proc _ges_null(i,x,j,y,t:'true)=prepend(element(i,j),_ges(head(x),tail(x),head(y),tail(y),t)) +proc _ges_null(i,x,j,y,t:'false)=_ges(head(x),tail(x),head(y),tail(y),t) +proc _ges(i:null,x,j,y,t)=_ges_null(i,x,j,y,t) +proc _ges(i:single_point,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i:empty_head,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i:null,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t)) +proc _ges(i:single_point,x,j:empty_head,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t)) +proc _ges(i:empty_head,x,j:empty_head,y,t)=null +proc _ges(i,x,j:empty_head,y,t)=error_type() :test "Rank mismatch" => 'false +proc _ges(i:null,x,j:empty_head,y,t:'true)=error_type() :test "Rank mismatch" => 'false +proc _ges(i:null,x,j:empty_head,y,t:'false)=null +proc size(x:iterable_grid)=map_reduce($_size,$*,x) +proc #(x:grid_slice)=shape(map($_shp,active_dims(x))) +proc dims(x:iterable_grid)=map($_size,active_dims(x)) +proc _arb(x:grid_slice)=map($_arb,x) +proc in(x:tuple(range_base),y:grid_slice)=map_reduce($in,$and,x,y) +proc inc(x:grid_slice,y:grid_slice)=map_reduce($inc,$and,x,y) +proc #(x:grid,y:tuple(subs_dim))=map($#,x,y) +PM__intrinsic _acthash(x:single_point,y:any)->(PM__tinyint) : "miss_arg" +proc _acthash(x,y)=x#y +proc #(x:grid_slice,y:tuple(subs_dim) or grid_slice)=map_apply($_acthash,$_sliceit,x,y) +proc convert(x:grid_slice,y:real_num)=map_const($convert,x,y) +proc sint(x:grid_slice)=map($sint,x) +proc int(x:grid_slice)=map($int,x) +proc sreal(x:grid_slice)=map($sreal,x) +proc real(x:grid_slice)=map($real,x) +proc low(x:grid_slice)=map($low,x) +proc high(x:grid_slice)=map($high,x) +proc overlap(x:grid_slice,y:grid_slice)=map($overlap,x,y) +proc overlap(x:grid_slice,y:grid_slice)=u,v where u,v=map($overlap,x,y) +proc intersect(x:grid_slice,y:grid_slice)=map($intersect,x,y) +proc intersect(x:grid_slice_dim,y:grid_slice_dim)=intersect(map_seq(x),map_seq(y)) +proc overlap(x:grid_slice_dim,y:grid_slice_dim)=overlap(map_seq(x),map_seq(y)) +proc overlap(x:grid_slice_dim,y:grid_slice_dim)=u,v where u,v=overlap(map_seq(x),map_seq(y)) +proc expand(x:grid_slice,y:grid)=map($expand,x,y) +proc contact(x:grid_slice,y:grid)=map($contract,x,y) +PM__intrinsic gcd(x:int,y:int)->(int) : "gcd" +// ***************************************************** +// SHAPES +// ***************************************************** +type extent is tuple(range(int) ),extent1d,extent2d,extent3d,extent4d,extent5d,extent6d,extent7d +type extent1d is tuple1d_of(range(int)) +type extent2d is tuple2d_of(range(int)) +type extent3d is tuple3d_of(range(int)) +type extent4d is tuple4d_of(range(int)) +type extent5d is tuple5d_of(range(int)) +type extent6d is tuple6d_of(range(int)) +type extent7d is tuple7d_of(range(int)) +type mshape(extent_t:extent) is rec {use _extent:extent_t,_n:int,_o:int} +type mshape1d is mshape(extent1d) +type mshape2d is mshape(extent2d) +type mshape3d is mshape(extent3d) +type mshape4d is mshape(extent4d) +type mshape5d is mshape(extent5d) +type mshape6d is mshape(extent6d) +type mshape7d is mshape(extent7d) +// Create array, vector and matrix shapes +proc _low(x)=low(x) +proc _low(x:null)='0 +proc _off(x)=-index(dims(x),map($_low,x)) +proc PM__array(arg...)=shape(map($_extnt,[arg...])) +proc _extnt(n:any_int)=0..int(n)-1 +proc _extnt(n:null)=null +proc _extnt(n:range(any_int))=int(n) +proc shape(extent:extent)=new mshape { + _extent=extent,_n=size(extent),_o=_off(extent) +} +// Conforming mshapes +proc check_conform(x,y) { + check_conform(#x,#y) +} +proc check_conform(x:mshape,y:mshape) { + test "Mshapes "++x++" and "++y++" do not conform"=>conform(x,y) +} + +proc _conform(x,y)=size(x)==size(y) +proc _conform(x:null,y)=size(y)=='1 +proc _conform(x,y:null)='true +proc _conform(x:null,y:null)='true +proc conform(x:mshape,y:mshape)=map_reduce($_conform,$and,x,y) or size(x)==0 or size(y)==0check "Values of different ranks cannot conform"=>rank(x)==rank(y) +// Local size of a mshape +proc _local_size(x:mshape)=size(x._extent) +// Convert an extent to have a zero base +proc zero_base(x:range)=0..size(x)-1 +proc zero_base(x:extent)=map($zero_base,x) +// Extent of a mshape +proc extent(x:shape)=x._extent +// Dimensions of a mshape +proc dims(x:mshape)=map($size,x._extent) +// Size from dimensions +proc size(x:tuple(int))=reduce($*,x) +// Empty mshape +proc _empty(x)=1..0 +proc empty(x:extent)=map($_empty,x) +// Slice of mshape +proc [](x:mshape,s:index)=x._extent[s] +proc [](x:mshape,s:subs)=shape(#active_dims(fill_in(x,s,'true))):check_contains(x,s) +// ***************************************************** +// INDEXING AND SLICING +// ***************************************************** +// Generic types supporting indexing and mapping +type iterable is iterable_grid,grid_slice,grid,grid_slice_dim,cyclic_range,array,... +proc [](x:iterable,arg...){ + d=#x + y=_tup(arg...) + check_contains(d,y) + return element(x,fill_in(d,y,'false)) +} +// Index type +type index is any_int,tuple(any_int) +// Slice and subscript types +type range_below(x) is rec {_t:x} +type range_above(x) is rec {_t:x} +type strided_range_below(x) is rec {_t:x,_st:x} +type strided_range_above(x) is rec {_t:x,_st:x} +type stride(x) is rec {_st:x} +type slice_dim is range(any_int),strided_range(any_int),range_above(any_int), range_below(any_int),strided_range_above(any_int),strided_range_below(any_int), stride(any_int),null,stretch_dim +type slice is slice_dim,tuple(slice_dim) +type subs_dim is slice_dim,any_int +type subs is index,slice,subs_dim,tuple(subs_dim) +// Partial ranges/sequences mainly used in subscripts +proc ..._(x)=new range_below { + _t=x +} +proc _...(x)=new range_above { + _t=x +} +proc by(x:range_base)=new stride { + _st=x +} +proc by(x:range_above(),y)=new strided_range_above { + _t=x._t,_st=convert(y,x._t) +} +proc by(x:range_below(),y)=new strided_range_below { + _t=x._t,_st=convert(y,x._t) +} +proc string(x:range_above)=x._t++"..." +proc string(x:range_below)="..."++x._t +proc string(x:strided_range_above)=x._t++"... by"++x._st +proc string(x:strided_range_below)="..."++x._t++"by "++x._st +proc string(x:stride)="by "++x._st +proc low(x:range_above)=x._t +proc low(x:strided_range_above)=x._t +proc high(x:range_below)=x._t +proc high(x:strided_range_below)=x._t +proc step(x:range_above or range_below)='1 +proc step(x:strided_range_above or strided_range_below)=x._st +proc width(x:strided_range_above or strided_range_below or range_above or range_below)='1 +// Stretch dimension in subscript +type stretch_dim is unique{PM__strdim} +proc string(x:stretch_dim)="_" +proc size(x:stretch_dim)='1 +proc expand(x:stretch_dim,y:grid)=x +proc contract(x:stretch_dim,y:grid)=x +proc in(x:stretch_dim,y)='true +proc inc(x:stretch_dim,y)='true +proc convert(x:stretch_dim,y:range_base)=x +proc #(x:stretch_dim,y:index)='0 +proc #(x:stretch_dim,y:grid_slice_dim)='0..'0 +proc intersect(x:stretch_dim,y:grid_slice_dim)=y +proc intersect(x:grid_slice_dim,y:stretch_dim)=x +proc intersect(x:stretch_dim,y:stretch_dim)=x +proc overlap(x:grid_slice_dim,y:stretch_dim)=#x +proc overlap(x:stretch_dim,y:grid_slice_dim)='0..'0 +proc overlap(x:stretch_dim,y:stretch_dim)='0..'0 +// Check subscript is in range +proc check_contains(a:extent,arg...) { + test "Index "++t++" out of bounds "++a=>contains(a,t) where t=_tup(arg...) +} +proc check_contains(a:mshape,arg...) { + check_contains(a._extent,arg...) +} +proc check_contains(a,arg...) { + check_contains(#a,arg...) +} +proc check_contains(a:dshape,arg...) { + check_contains(a._mshape._extent,arg...) +} +proc _contains(x:null,y)='true +proc _contains(x:range(int),y:any_int)=yy>=x._lo and yy<=x._hi where yy=int(y) +proc _contains(x:range(int),y:range(any_int) or seq(any_int))=_contains(x,y._lo) and _contains(x,y._hi) or y._lo>y._hi +proc _contains(x:range(int),y:range_below(any_int) or strided_range_below(any_int) or range_above(any_int) or strided_range_above(any_int))=_contains(x,y._t) +proc _contains(x:range(int),y:stride(any_int))='true +proc _contains(x:range(int),y:null)='true +proc contains(x:mshape1d,y:subs_dim)=_contains(x.1,y) +proc contains(x:extent,y:tuple(subs_dim))=map_reduce($_contains,$and,x,y) +PM__intrinsic _rgd(x:stretch_dim)->(PM__tinyint) : "miss_arg" +proc _rgd(x)=x +proc _rigid_dims(x:grid_slice or tuple(subs_dim))=map_apply($_rgd,$_sliceit,x) +proc contains(x:extent,y:tuple(subs_dim) and contains(stretch_dim))=contains(x,_rigid_dims(y)) +proc contains(x:extent,y,arg...)=contains(x,[y,arg...]) +// Complete a subscript using a base mshape +proc fill_in(x:null,y,t)=y :test "Cannot use incomplete subscript on null dimension" => 'false +proc fill_in(x:seq(int) or null,y:any_int,t:'true)=single_point(int(y)) +proc fill_in(x:seq(int) or null,y:any_int,t:'false)=int(y) +proc fill_in(x:seq(int) or null,y:any_int,t:null)=int(y)..int(y) +proc fill_in(x:seq(int) or null,y:range(any_int),t)=int(y) +proc fill_in(x:seq(int) or null,y:strided_range(any_int),t)=int(y) +proc fill_in(x:seq(int),y:range_below(any_int),t)=x._lo..int(y._t) +proc fill_in(x:seq(int),y:range_above(any_int),t)=int(y._t)..x._hi +proc fill_in(x:seq(int),y:strided_range_below(any_int),t)=lo..int(y._t) by y._st where lo=y._t-(y._t-x._lo)/y._st*y._st +proc fill_in(x:seq(int),y:strided_range_above(any_int),t)=int(y._t)..x._hi by y._st +proc fill_in(x:seq(int),y:stride(any_int),t)=x by int(y._st) +proc fill_in(x:seq(int) or null,y:null,t)=x +proc fill_in(x:grid,y:tuple(any_int),t)=int(y) +proc fill_in(x:grid,y:tuple(subs_dim),t)=map($fill_in,x,y,spread(t,x)) +proc fill_in(x:grid,y:tuple(subs_dim) and contains(stretch_dim),t)=_fill_in(x,head(y),tail(y),t) +proc _fill_in(x,y,z,t)=prepend(fill_in(x.1,y,t),_fill_in(tail(x),head(z),tail(z),t)) +proc _fill_in(x,y:stretch_dim,z,t:'true)=prepend(null,_fill_in(x,head(z),tail(z),t)) +proc _fill_in(x,y:stretch_dim,z,t:'false)=prepend(y,_fill_in(x,head(z),tail(z),t)) +proc _fill_in(x:null,y:empty_head,z,t)=null +proc _fill_in(x:empty_head,y:stretch_dim,z,t)=prepend(null,_fill_in(x,head(z),tail(z),t)) +proc _fill_in(x:empty_head,y,z,t)=error_type() :test "Rank mismatch in slice" => 'false +// ******************************************************* +// SUBSCRIPT INTERSECTION AND ALIASING +// ******************************************************* +// Test for intersection between two subscripts +proc intersects(x:null,y:subs_dim)='true +proc intersects(x:subs_dim,y:null)='true +proc intersects(x:null,y:null)='true +proc intersects(x:range(any_int),y:range(any_int))=not(x._hiy._hi) +proc intersects(x:seq(any_int),y:seq(any_int))=size(intersect(x,y))>0 +proc intersects(x:range(any_int),y:range_above(any_int) or strided_range_above(any_int))=x._hi>=y._t +proc intersects(x:range_above(any_int) or strided_range_above(any_int),y:range(any_int))=y._hi>=x._t +proc intersects(x:range(any_int),y:range_below(any_int) or strided_range_below(any_int))=x._lo<=y._t +proc intersects(x:range_below(any_int) or strided_range_below(any_int),y:range(any_int))=y._lo<=x._t +proc intersects(x:strided_range(any_int),y:range_above(any_int) or strided_range_above(any_int))=intersects(y._t..x._hi by step(y),x) +proc intersects(y:range_above(any_int) or strided_range_above(any_int),x:strided_range(any_int))=intersects(y._t..x._hi by step(y),x) +proc intersects(x:strided_range(any_int),y:range_below(any_int) or strided_range_below(any_int))=intersects(x,y._t..x._lo by -step(y)) +proc intersects(y:range_below(any_int) or strided_range_below(any_int),x:strided_range(any_int))=intersects(x,y._t..x._lo by -step(y)) +proc intersects(x:range_below(any_int) or strided_range_below(any_int),y:range_above(any_int) or strided_range_above(any_int))=x._t>=y._t +proc intersects(x:range_above(any_int) or strided_range_above(any_int),y:range_below(any_int) or strided_range_below(any_int))=y._t>=x._t +proc intersects(x:range_above(any_int) or strided_range_above(any_int),y:range_above(any_int) or strided_range_above(any_int))='true +proc intersects(x:range_below(any_int) or strided_range_below(any_int),y:range_below(any_int) or strided_range_below(any_int))='true +proc intersects(x:strided_range_below(any_int),y:strided_range_above(any_int))=size(intersect(y._t..x._t by y._st,x._t..y._t by -x._st))>0 +proc intersects(y:strided_range_above(any_int),x:strided_range_below(any_int))=size(intersect(y._t..x._t by y._st,x._t..y._t by -x._st))>0 +proc intersects(x:strided_range_above(any_int),y:strided_range_above(any_int))=abs(x._t-y._t) mod gcd(int(x._st),int(y._st))==0 +proc intersects(x:strided_range_below(any_int),y:strided_range_below(any_int))=abs(x._t-y._t) mod gcd(abs(int(x._st)),abs(int(y._st)))==0 +proc intersects(x:stride(any_int),y:subs_dim)='true +proc intersects(x:subs_dim,y:stride(any_int))='true +proc intersects(x:stride(any_int),y:stride(any_int))='true +proc intersects(x:seq,y:int)=y in x +proc intersects(x:int,y:seq)=x in y +proc intersects(x:int,y:int)=x==y +proc intersects(x:int,y:range_above(any_int))=x>=y._t +proc intersects(x:int,y:range_below(any_int))=x<=y._t +proc intersects(x:int,y:strided_range_above(any_int))=x>=y._t and (x-y._t) mod y._st==0 +proc intersects(x:int,y:strided_range_below(any_int))=x<=y._t and (y._t-x) mod y._st==0 +proc intersects(y:range_above(any_int),x:int)=x>=y._t +proc intersects(y:range_below(any_int),x:int)=x<=y._t +proc intersects(y:strided_range_above(any_int),x:int)=x>=y._t and (x-y._t) mod y._st==0 +proc intersects(y:strided_range_below(any_int),x:int)=x<=y._t and (y._t-x) mod y._st==0 +proc _intersects(x,y,z:'true)=map_reduce($intersects,$and,x,y) +proc _intersects(x,y,z:'false)='false +proc intersects(x:tuple(subs_dim except stretch_dim),y:tuple(subs_dim except stretch_dim))=_intersects(x,y,rank(x)==rank(y)) +proc intersects(x:tuple(subs_dim),y:tuple(subs_dim))=_intersects(rx,ry,rank(rx)==rank(ry))where rx=_rigid_dims(x),ry=_rigid_dims(y) +proc intersects(x:tuple(subs_dim),y:null)='true +proc intersects(x:null,y:tuple(subs_dim))='true +proc _intersects(x:subs,y:subs)=intersects(x,y) +proc _intersects(x,y)='false +// Alias checking +proc PM__check_alias(arg...)=false +proc PM__check_alias(i,j,x,y) { + test "Aliasing error between arguments #"++i++" and #"++j=>not _intersects(x,y) +} +proc PM__check_alias(i,j,x,y,arg...) { + if _intersects(x,y):PM__check_alias(i,j,arg...) +} +// Combining subscripts +proc PM__cmbidx(x,y)=_cmb(x,y) +proc PM__cmbidx(x,y,arg...)=PM__cmbidx(_cmb(x,y),arg...) +type _cmb_error is unique +proc _cmb(x,y)=_cmb_error +proc _cmb(x:subs except index,y:subs)=_cmb1(x,y) +proc _cmb1(x,y)=_cmb_error +proc _cmb1(x:subs_dim,y:subs_dim)=x[y] +proc _cmb1(x:tuple,y:tuple)=_cmb2(x,y,rank(x)==rank(y)) +proc _cmb2(x,y,z:'true)=x[y] +proc _cmb2(x,y,z:'false)=_cmb_error +// ******************************************************* +// ITERATION - SEQUENTIAL AND CONCURRENT +// ******************************************************* +// Iteration over mshape +// - first element +proc PM__first(d:int)=0,null,d>0 +proc PM__first(d:tuple1d)=i,s,e where i,s,e=PM__first(d.1) +proc PM__first(d:tuple2d)=[j1,j2],[s1,s2],e1 and e2 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2) +proc PM__first(d:tuple3d)=[j1,j2,j3],[s1,s2,s3],e1 and e2 and e3 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3) +proc PM__first(d:tuple4d)=[j1,j2,j3,j4],[s1,s2,s3,s4],e1 and e2 and e3 and e4 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4) +proc PM__first(d:tuple5d)=[j1,j2,j3,j4,j5], [s1,s2,s3,s4,s5],e1 and e2 and e3 and e4 and e5 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5) +proc PM__first(d:tuple6d)=[j1,j2,j3,j4,j5,j6],[s1,s2,s3,s4,s5,s6],e1 and e2 and e3 and e4 and e5 and e6 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5),j6,s6,e6=PM__first(d.6) +proc PM__first(d:tuple7d)=[j1,j2,j3,j4,j5,j6,j7],[s1,s2,s3,s4,s5,s6,s7],e1 and e2 and e3 and e4 and e5 and e6 and e7 where j1,s1,e1=PM__first(d.1),j2,s2,e2=PM__first(d.2),j3,s3,e3=PM__first(d.3),j4,s4,e4=PM__first(d.4), j5,s5,e5=PM__first(d.5),j6,s6,e6=PM__first(d.6),j7,s7,e7=PM__first(d.7) +// - subsequent elements +proc PM__next(d:int,g,i)=ii,null,ii> _doloop(int)->(int) : "do_loop" +PM__intrinsic<> _doloop(int,int)->(int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int)->(int,int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int,int)->(int,int,int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int,int,int)->(int,int,int,int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int,int,int,int)->(int,int,int,int,int,int) : "do_loop" +PM__intrinsic<> _doloop(int,int,int,int,int,int,int)->(int,int,int,int,int,int,int) : "do_loop" +proc _elts(x:int)=i where i=_doloop(x) +proc _elts(x:tuple1d)=[i] where i=_elts(x.1) +proc _elts(x:tuple2d)=[i,j] where i,j=_doloop(x.1,x.2) +proc _elts(x:tuple3d)=[i,j,k] where i,j,k=_doloop(x.2,x.2,x.3) +proc _elts(x:tuple4d)=[i,j,k,l] where i,j,k,l=_doloop(x.1,x.2,x.3,x.4) +proc _elts(x:tuple5d)=[i,j,k,l,m] where i,j,k,l,m=_doloop(x.1,x.2,x.3,x.4,x.5) +proc _elts(x:tuple6d)=[i,j,k,l,m,n] where i,j,k,l,m,n=_doloop(x.1,x.2,x.3,x.4,x.5,x.6) +proc _elts(x:tuple7d)=[i,j,k,l,m,n,o] where i,j,k,l,m,n,o=_doloop(x.1,x.2,x.3,x.4,x.5,x.6,x.7) +PM__intrinsic<> _blockedloop(any)->(int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int,int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int,int,int,int) : "blocked_loop" +PM__intrinsic<> _blockedloop(any)->(int,int,int,int,int,int,int) : "blocked_loop" +proc _belts(x,y:shape1d)=[i] where i=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape2d)=[i,j] where i,j=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape3d)=[i,j,k] where i,j,k=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape4d)=[i,j,k,l] where i,j,k,l=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape5d)=[i,j,k,l,m] where i,j,k,l,m=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape6d)=[i,j,k,l,m,n] where i,j,k,l,m,n=_blockedloop(PM__do_over(x,y)) +proc _belts(x,y:shape7d)=[i,j,k,l,m,n,o] where i,j,k,l,m,n,o=_blockedloop(PM__do_over(x,y)) +PM__else +proc PM__generate(x:dshape,n,s)=_elts(dims(x._tilesz),1,n) +proc PM__generate(x:mshape,n,s)=_elts(dims(x),1,n) +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->(int) : "iota" +PM__intrinsic<> _iota(siz:int,start:int,finish:int,incr:int,first:int,trunc:int,totsiz:int)->(int) : "iota" +proc _n(x:int)=x +proc _elts(x:int,siz,tot)=_iota(siz,0,x-1,1,tot) +proc _elts(x:tuple1d,siz,tot)=tuple(_elts(x.1,siz,tot)) +proc _elts(x:tuple2d,siz,tot)=tuple(_elts(x.1,siz,tot),_elts(x.2,siz*_n(x.1),tot) ) +proc _elts(x:tuple3d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts( x.3, s1*_n(x.2), tot)) where s1=siz*_n(x.1) +proc _elts(x:tuple4d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s2*_n(x.3),tot)) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple5d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s3*_n(x.4), tot)) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple6d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s4*_n(x.5), tot)) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +proc _elts(x:tuple7d,siz,tot)=tuple(_elts( x.1,siz,tot),_elts(x.2,s1,tot),_elts(x.3,s2,tot),_elts(x.4,s3,tot),_elts(x.5,s4,tot),_elts(x.6,s5,tot),_elts(x.7,s5*_n(x.6), tot)) where s5=s4*_n(x.5) where s4=s3*_n(x.4) where s3=s2*_n(x.3) where s2=s1*_n(x.2) where s1=siz*_n(x.1) +PM__endif +PM__intrinsic _indices(any)->(int) : "indices" +// ************************************** +// ARRAYS +// ************************************** +// Array types +type array(e,d:shape) is varray(e,d),farray(e,d) +type varray(e,d:shape) is e^var d,array_template(e,d,'true) +type farray(e,d:shape) is e^const d,e^invar d,e^fix d,array_template(e,d,'false) +type farray(e,d:mshape) is ...,array_slice(e^const any),array_slice(e^var any),array_slice(e^invar any),array_slice(e^fix any) +// Array operations +proc _arb(x:any^mshape)=_get_aelem(x,0) +PM__if_compiling +proc size(x:any^mshape)=size(#x) +PM__else +PM__intrinsic size(x:any^mshape)->(int) : "get_size" +PM__endif +PM__intrinsic<> _array(x:any,y:any,z:any,v:'false)->(PM__dim x,y) : "array" +PM__intrinsic<> _array(x:any,y:any,z:any,v:'true)->(PM__vdim x,y) : "var_array" +PM__intrinsic<> _redim(x:any^any,y:any)->(over x,y) : "redim" +PM__intrinsic<> PM__dim_noinit(x:any,y:any,z:any)->(PM__dim x,y) : "array_noinit" +proc #%(x:invar any^any)=_array_shape(x <>) +proc #%(x)=_get_shape(x) +proc _get_shape(x)=#x +proc #(x:any^any)=_array_shape(x) +PM__intrinsic _array_shape(x:any^any)->(#x) : "get_dom" +proc dims(x:any^mshape)=dims(#x) +PM__intrinsic PM__extractelm(x:any^any)->(%x) : "extractelm" +proc element(a:any^mshape,t:index)=_get_aelem(a,index(#(a),t)) +proc _set_elem(&a:any^mshape,v,t:index){ + PM__setaelem(&a,index(#(a),t),v) +} + +proc _make_subref(a:any^mshape,t:index)=_make_subref(a,index(#(a),t)) +PM__intrinsic _make_subref(a:any^mshape,i:int)->(%a) : "make_rf" +PM__intrinsic _get_aelem(x:any^any,y:int)->(%x) : "array_get_elem" +PM__intrinsic PM__setaelem(&x:any^any,y:int,z:any): "array_set_elem" +// Linear index of tuple mshape (zero base,unit stride) +proc _indx(g:null,s)='0 +proc _indx(g:range(int),s)=int(s) +proc _indx(g:any_int,s)=int(s) +proc _sz(x:null)='1 +proc _sz(x:int)=x +proc _sz(x:range(int))=x._n +proc _offset(x:mshape)=x._o +proc _offset(x)='0 +proc index(g:mshape1d or tuple1d_of(int),s:any_int)=int(_indx(g.1,s))+_offset(g) +proc index(g:mshape1d or tuple1d_of(int),s:tuple1d_of(any_int))=int(_indx(g.1,s.1))+_offset(g) +proc index(g:mshape2d or tuple2d_of(int),s:tuple2d_of(any_int))=int(_indx(g.1,s.1)+_sz(g.1)*_indx(g.2,s.2))+_offset(g) +proc index(g:mshape3d or tuple3d_of(int),s:tuple3d_of(any_int))=int(_indx(g.1,s.1)+_sz(g.1)*(_indx(g.2,s.2)+_sz(g.2)*_indx(g.3,s.3)))+_offset(g) +proc index(g:mshape4d or tuple4d_of(int),s:tuple4d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* _indx(g.4,s.4))))+_offset(g) +proc index(g:mshape5d or tuple5d_of(int),s:tuple5d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* _indx(g.5,s.5)))))+_offset(g) +proc index(g:mshape6d or tuple6d_of(int),s:tuple6d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* _indx(g.6,s.6))))))+_offset(g) +proc index(g:mshape7d or tuple7d_of(int),s:tuple7d_of(any_int))= int(_indx(g.1,s.1)+_sz(g.1)* (_indx(g.2,s.2)+_sz(g.2)* (_indx(g.3,s.3)+_sz(g.3)* (_indx(g.4,s.4)+_sz(g.4)* (_indx(g.5,s.5)+_sz(g.5)* (_indx(g.6,s.6)+_sz(g.6)* (_indx(g.7,s.7))))))))+_offset(g) +proc index2point(i:int,s:range(int))=[i+s._lo] +proc index2point(i:int,s:int)=[i] +proc index2point(i:int,s:tuple1d_of(int))=[i] +proc index2point(i:int,s:tuple2d_of(int))=[i1,i2] where i1=i-i2*_sz(s.1) where i2=i/_sz(s.1) +proc index2point(i:int,s:tuple3d_of(int))=[i1,i2,i3] where i1=i-j2*_sz(s.1) where i2=j2-i3*_sz(s.2) where i3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc index2point(i:int,s:tuple4d_of(int))=[i1,i2,i3,i4] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-i4*_sz(s.3) where i4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc index2point(i:int,s:tuple5d_of(int))=[i1,i2,i3,i4,i5] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-i5*_sz(s.4) where i5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc index2point(i:int,s:tuple6d_of(int))=[i1,i2,i3,i4,i5,i6] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-i6*_sz(s.5) where i6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +proc index2point(i:int,s:tuple7d_of(int))=[i1,i2,i3,i4,i5,i6,i7] where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-j4*_sz(s.3) where i4=j4-j5*_sz(s.4) where i5=j5-j6*_sz(s.5) where i6=j6-i7*_sz(s.6) where i7=j6/_sz(s.6) where j6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3) where j3=j2/_sz(s.2) where j2=i/_sz(s.1) +// Numeric array operations +proc -(x:num^any)={ + -xx:xx in x +} +proc +(x:num^any,y:num)={ + xx+y:xx in x +} +proc -(x:num^any,y:num)={ + xx-y:xx in x +} +proc *(x:num^any,y:num)={ + xx*y:xx in x +} +proc *(x:num,y:num^any)={ + x*yy:yy in y +} +proc /(x:num^any,y:num)={ + xx/y:xx in x +} +// ***************************************** +// ARRAY TEMPLATES +// ***************************************** +// Array templates +type array_template(a,d:mshape or dshape,v:fix bool) is rec {_a:a,_d:d,_s:int,_v:v} +proc array(a:any,s:dshape)=new array_template { + _a=a,_d=s,_s=s._size,_v='false +} +proc array(a:any,s:mshape(tuple(range(int))))=new array_template { + _a=a,_d=s,_s=size(s),_v='false +} +proc array(a:any,s:tuple(range(any_int)))=array(a,shape(s)) +proc varray(a:any,s:mshape or dshape)=new array_template { + _a=a,_d=s,_s=size(s),_v='true +} +proc varray(a:any,s:tuple(range(any_int)))=varray(a,shape(s)) +proc _zero(x)=0 +proc varray(a:any,s:tuple(null))=varray(a,shape(map($_zero,s))) +// Treat a template as if it were an array +proc _arb(a:array_template)=a._a +proc #(a:array_template(,mshape,))=a._d +proc dims(a:array_template(,mshape,))=dims(a._d) +proc size(a:array_template)=a._s +proc redim(a:array_template,d:mshape)= new array_template { +_a=a,_d=d,_s=size(d),_v=a._v} check "New dshape does not have same size in redim"=> size(d)==a._s +proc element(a:array_template,arg...:subs)=a._a +// Array creation from template +proc PM__dup(a:array_template(,shape,))=_array(PM__dup(a._a),a._d,int(a._s),a._v) +proc PM__dup(a:array_template(,shape,'true))=_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v) +proc PM__do_dim(a:any,d:mshape)=_array(a,d,size(d),'false) +// ***************************************** +// MATRIX AND VECTOR +// ***************************************** +type matrix_element is num,bool,... +type _matrix(t) is struct{use array:t} +type matrix(t:matrix_element) is _matrix(array(t,shape2d)) +type vector(t:matrix_element) is _matrix(array(t,shape1d)) +type matrix_template(t:matrix_element) is _matrix(array_template(t,shape2d)) +type vector_template(t:matrix_element) is _matrix(array_template(t,shape1d)) +proc PM__matrix(x)=new _matrix{ + array=x +} +proc vector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(array(x,n)) +proc vvector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(varray(x,n)) +proc dvector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(array(x,n,BLOCK_CYCLIC(32))) +proc dvvector(x:matrix_element,n:shape1d or extent1d)=PM__matrix(varray(x,n,BLOCK_CYCLIC(32))) +proc vector(x:matrix_element,n:shape1d or extent1d,distr:distr_template)=PM__matrix(array(x,n,distr)) +proc vvector(x:matrix_element,n:shape1d or extent1d,distr:distr_template)=PM__matrix(varray(x,n)) +proc matrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(array(x,n)) +proc vmatrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(varray(x,n)) +proc dmatrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(array(x,n,BLOCK_CYCLIC(32))) +proc dvmatrix(x:matrix_element,n:shape2d or extent2d)=PM__matrix(varray(x,n,BLOCK_CYCLIC(32))) +proc matrix(x:matrix_element,n:shape2d or extent2d,distr:distr_template)=PM__matrix(array(x,n,distr)) +proc vmatrix(x:matrix_element,n:shape2d or extent2d,distr:distr_template)=PM__matrix(varray(x,n)) +proc matrix_element_zero(x:num)=convert(0,x) +proc matrix_element_balance(x:num,y:num)=xx,yy where xx,yy=balance(x,y) +proc matrix_element_add(x:num,y:num)=x+y +proc matrix_element_subtract(x:num,y:num)=x-y +proc matrix_element_multiply(x:num,y:num)=x*y +proc matrix_element_zero(x:bool)=false +proc matrix_element_balance(x:bool,y:bool)=x,y +proc matrix_element_add(x:bool,y:bool)=x or y +proc matrix_element_multiply(x:bool,y:bool)=x and y +proc +(x:matrix,y:matrix) { + check_conform(x.array,y.array) + test "Cannot add zero size matrices"=>size(x)>0 + var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array)) + for xx in x.array, yy in y.array, zz in z.array:zz=matrix_element_add(xx,yy) return z +} +proc -(x:matrix,y:matrix) { + check_conform(x.array,y.array) + test "Cannot add zero size matrices"=>size(x)>0 + var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array)) + for xx in x.array, yy in y.array, zz in z.array:zz=matrix_element_subtract(xx,yy) return z +} +proc *(x:matrix,y:matrix) { + sx=#x + sy=#y + sz=[sx.1,sy.2] + test "Matrices do not conform for multiplication"=>size(sx.2)==size(sy.1) + test "Cannot multiply zero size matrices"=>size(x)>0 and size(y)>0 + var z=matrix(b,sz) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array)) + for *i in sz,zz in z.array { + var s=matrix_element_zero(_arb(z.array)) + foreach invar k in #(sx.1) { + s=matrix_element_add(s,matrix_element_multiply(x.array[i.1,sx.2[k]],y.array[sy.1[k],i.2])) + } + zz=s + } + return z +} + +// ***************************************** +// DISTRIBUTED SHAPE (DSHAPE) +// ***************************************** +type _distrb(extent:extent,dist:distr or null) +type _distrb(extent:extent,dist:distr) is ...,dshape(extent,dist) +type _distrb(extent:extent,dist:null) is ...,mshape(extent) +type shape(extent:extent,dist:distr or null) is _distrb(extent,dist) +type shape1d(extent:extent1d,dist:distr or null) is shape(extent,dist) +type shape2d(extent:extent2d,dist:distr or null) is shape(extent,dist) +type shape3d(extent:extent3d,dist:distr or null) is shape(extent,dist) +type shape4d(extent:extent4d,dist:distr or null) is shape(extent,dist) +type shape5d(extent:extent5d,dist:distr or null) is shape(extent,dist) +type shape6d(extent:extent6d,dist:distr or null) is shape(extent,dist) +type shape7d(extent:extent7d,dist:distr or null) is shape(extent,dist) +type PM__distr_tag is unique +type dshape(extent:extent,dist:distr) is rec {use _mshape:mshape(extent),dist:dist,_tile,_tilesz,_size:int,_level:int,_dtag:PM__distr_tag} +proc check_conform(x:dshape,y:mshape) { + check_conform(x._mshape,y) +} + +proc check_conform(x:mshape,y:dshape) { + test "A distributed object connot conform to a non-distributed value" => 'false +} + +proc check_conform(x:dshape,y:dshape) { + check_conform(x._mshape,y._mshape) + test "Objects have different distributions"=> x.dist==y.dist +} + +proc conform(x:dshape,y:mshape)=conform(x._mshape,y) +proc conform(x:mshape,y:dshape)='false +proc conform(x:dshape,y:dshape)=conform(x,y) and x.dist==y.dist +proc _local_size(x:dshape)=size(x._tile) +// Get an element from a null tile - just pass index through +proc element(x:null,y:tuple(index))=y +proc element(x:null,y:int)=y +proc size(d:dshape)=d._size +proc dims(d:dshape)=dims(d._mshape._extent) +proc #(d:dshape)=new dshape{ + _mshape=#d._mshape,dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level,_dtag=d._dtag +} +proc [](d:dshape,s:index)=d._mshape._extent[s] +proc [](d:dshape,s:subs)=_dshape_slice(d,ss) where ss=fill_in(#d._mshape._extent,s,'true){ + check_contains(#(d._mshape._extent),s) +} + +proc _dshape_slice(d:dshape,ss)=new dshape{ +_mshape=shape(#active_dims(ss)),dist=dist,_tile=tile,_tilesz=#tile,_size=size(tile),_level=d._level,_dtag=d._dtag} where tile=element(dist,_shrd_node()) where dist=sliced_distr(d.dist,ss) +// ***************************************** +// DISTRIBUTED ARRAY AND SHAPE TEMPLATES +// ***************************************** +type darray_template(e,d,p,t) is rec {_e:e,_d:d,_p:p,_t:t,_v} +type dshape_template(d,p,t) is rec {_d:d,_p:p,_t:t} +proc darray(e,d:extent)=array(e,d,VBLOCK) +proc array(e,d:extent,distr:distr_template,topo:any=null)=new darray_template { + _e=e,_d=d,_p=distr,_t=topo,_v='true +} +proc array(e,d:extent,distr:null or tuple(null))=array(e,d) +proc dvarray(e,d:extent)=varray(e,d,VBLOCK) +proc varray(e,d:extent,distr:distr_template,topo:any=null)=new darray_template { + _e=e,_d=d,_p=distr,_t=topo,_v='true +} +proc varray(e,d:extent,distr:null or tuple(null))=varray(e,d) +proc shape(d:extent,distr,topo:any=null)=new dshape_template { + _d=d,_p=distr,_t=topo +} +// ***************************************** +// DISTRIBUTED ARRAYS +// ***************************************** +proc PM__dup(d:darray_template) { + dd=dims(d._d) + topo=topology(d._t,d._p,dd, min(size(d._d),shrd_nnode())) + dist=distribute(d._p,dd,topo) + test "Not enough processors to implement distribution"=> size(#dist)<=shrd_nnode() + p=_shrd_node() + var elem=empty(dist) + if p size(#dist)<=shrd_nnode() + p=_shrd_node() + var elem=empty(dist) + if p 'false +proc _arb(dd:any^dshape)=_get_aelem(dd,0) +proc dims(dd:any^dshape)=dims((#dd)._mshape) +proc PM__redim(a,d)=_redim(a,d) +proc PM__local(a:any^dshape)=_redim(a,(#a)._tilesz) +proc PM__local(a:any^mshape)=a +proc PM__local%(x:shared) shared =PM__local(x) +proc element(a:any^dshape,t) { + p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t)) + var r=_arb(a) + if p==_this_node():r=_get_aelem(a,i) + _bcast_shared(&r,p) + return r +} + +proc _set_elem(&a:any^dshape,v,t) { + p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t)) + if p==_this_node():PM__setaelem(&a,i,v) +} + +// ************************************************* +// SLICES +// ************************************************* +// Slices +type array_slice(a,s) is struct^{_a:a,_s:s} +proc _arb(x:array_slice)=_arb(x._a) +proc #(x:array_slice)=#(x._s) +proc #(x:array_slice(any^dshape))=_dshape_slice(d,d._mshape._extent#x._s) where d=#(x._a) +proc conform(x:mshape,y:array_slice)=map_reduce($_conform,$and,x,y._s) +proc conform(x:dshape,y:array_slice)=map_reduce($_conform,$and,x._mshape,y._s) +proc conform(x,y:array_slice)=map_reduce($_conform,$and,#x,y._s) +proc dims(x:array_slice)=dims(x._s) +proc size(x:array_slice)=size(x._s) +proc element(x:array_slice(any^mshape,),y:index)=element(x._a,x._s[y]) +proc element(x:array_slice,y:subs)=new array_slice { + _a=x._a,_s=x._s[y] +} +proc _set_elem(&x:array_slice(any^mshape,),v,y:index) { + PM__setaelem(&^(x._a),index(#(x._a),x._s[y]),v) +} +proc PM__dup(x:array_slice(any^mshape,)){ + var a=array(_arb(x),#x) + a=x + return a +} +proc PM__dup(x:array_slice(any^dshape,)){ + d=#x._a + ss=(#x._a)._mshape#x._s + var a=array(_arb(x._a),_dshape_slice(d,ss)) + _set_slice(&^(PM__local(a)),#(#a)._tile, PM__local(x._a),overlap((#x._a)._tile,ss)) + return a +} +// ************************************************* +// ARRAY & SLICE ASSIGNMENT +// ************************************************* +proc PM__assign(&xx:farray,x:any) { + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc PM__assign(&xx:farray,x:array) { + _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) +} +proc PM__assign(&xx:varray,x:any except varray) { + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc PM__assign(&xx:varray,x:farray) { + _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) +} +proc PM__assign_var(&xx:farray,x:any) { + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc PM__assign_var(&xx:farray,x:array) { + _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) +} +proc PM__assign_var(&xx:varray,x:any except varray) { + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc PM__assign_var(&xx:varray,x:farray) { + _array_assign(&xx,x,same_type(_arb(x),_arb(xx))) +} +proc PM__aliased_assign(&xx,x){ +} +proc PM__aliased_assign(&xx:array_slice,x:array_slice) <> { + _assign_internal_slice(&xx,x._s) +} +proc _array_assign(&xx,x,v:'false){ + check_assign_types(_arb(xx),x) + _set_array(&xx,x) +} +proc _array_assign(&xx,x,v:'true){ + check_conform(extent(#xx),extent(#x)) + if _copy_array(&xx,x):_sync_messages(xx,x) +} +proc _array_assign(&xx:array_slice,x:array_slice,v:'true){ + check_conform(extent(#xx),extent(#x)) + if _copy_array(&xx,x):_sync_messages(xx,x) +} +proc _array_assign(&xx:varray,x,v:'true) { + _assign_element(&xx,x) +} +proc _array_assign(&xx:varray,x:array_template,v:'true) { + _assign_element(&xx,PM__dup(x)) +} +PM__if_compiling +proc _set_slice(&x,a,y,b) { + foreach i in a,j in b:x[i]=y[j] +} +PM__else +proc _set_slice(&x,a,y,b) { + if size(a)>0:forall i in a,j in b{ + sync x[i]=y[j] + } +} +PM__endif +type _non_d is any^mshape,array_slice(any^mshape,) +proc _set_array(&x:any^mshape,y){ + forall i in x { + _assign(&i,y) + } +} + +proc _set_array(&x:any^dshape,y){ + _set_array(&^(PM__local(^(&x))),y) +} +proc _set_array(&x:array_slice(any^mshape,),y){ + forall i in x._s { + _set_elem(&x._a,y,i <>) + } +} +proc _set_array(&x:array_slice(any^dshape,),y){ + tile=(#x._a)._tile + t=overlap(tile,((#x._a)#x._s)) + forall i in t { + _set_elem(&x._a,y,i <>) + } +} + +proc _copy_array(&a:_non_d,b:_non_d){ + forall i in a, j in b { + i=j + } + return 'false +} +proc _copy_array(&xx:any^dshape,x:_non_d) { + tile=(#xx)._tile + forall i in tile { + PM__setaelem(&xx,index(dims(tile),here),x[(#x)[i]] <>) + } + return 'false +} +proc _copy_array(&xx:array_slice(any^dshape,),x:_non_d) { + tile=(#xx._a)._tile + subtile,subarray=overlap(tile,(#xx._a)._mshape#xx._s) + forall i in subtile,j in subarray { + PM__setaelem(&xx._a,index(dims(tile),i),x[element(#x,active_dims(xx._s,j))] <>) + } + return 'false +} + +proc _copy_array(&a:_non_d,x:any^dshape) { + dist=(#x).dist + foreach p in #(dist) { + tile=element(dist,p) + i=index(dims(dist),p) + if i==_shrd_node() { + forall kk in PM__local(x),j in tile { + var k=kk + _bcast_shared(&k,i) + _set_elem(&a,k,(#a)[j] <>) + } + } else { + forall j in tile { + var k=_arb(a) + _bcast_shared(&k,i) + _set_elem(&a,k,(#a)[j] <>) + } + } + } + return 'false +} + +proc _copy_array(&v:_non_d,x:array_slice(any^dshape,)) { + dist=(#(x._a)).dist + xs=(#(x._a))._mshape#x._s + nodes=#dist + foreach pp in overlap(nodes,nodes_for_grid(dist,xs)) { + p=nodes[pp] + utile,elem=overlap(dist[nodes[p]],xs) + i=index(dims(dist),p) + if i==_shrd_node() { + forall j in utile, jj in elem { + var k=element(PM__local(x._a),j) + _bcast_shared(&k,i) + _set_elem(&v,k,element(#v,active_dims(x._s,jj)) <>) + } + } else { + forall j in elem { + var k=_arb(x._a) + _bcast_shared(&k,i) + _set_elem(&v,k,element(#v,active_dims(x._s,j)) <>) + } + } + } + return 'false +} + +proc _copy_array(&x:any^mshape,y:array_template) { + _set_array(&x,y._a) + return 'false +} +proc _copy_array(&x:any^dshape,y:array_template) { + _set_array(&^(PM__local(^(&x))),y._a) + return 'false +} +type _comp is contains(array or *any or ^*(,,,,)) +proc _copy_array(&xx:array_slice(any^dshape,),x:array_slice(any^dshape)) { + _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s, PM__local(x._a),xd,xd._mshape#x._s,xd._tile) where xxd=#(xx._a),xd=#(x._a) + return 'true +} + +proc _copy_array(&xx:any^dshape,x:array_slice(any^dshape)) { + _copy_darray_slice(&^(PM__local(^(&xx))),xxd,zero_base(xxd._mshape._extent), PM__local(x._a),xd,xd._mshape#x._s,xd._tile) where xxd=#xx,xd=#(x._a) + return 'true +} + +proc _copy_array(&xx:array_slice(any^dshape,),x:any^dshape) { + _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s, PM__local(x),xd,zero_base(xd._mshape._extent),xd._tile) where xxd=#(xx._a),xd=#x + return 'true +} + +proc _copy_array(&xx:any^dshape,x:any^dshape) { + _copy_darray_slice(&^(PM__local(^(&xx))),xxd,zero_base(xxd._mshape._extent), PM__local(x),xd,zero_base(xd._mshape._extent),xd._tile) where xxd=#xx,xd=#x + return 'true +} + +proc _assign_internal_slice(&xx:array_slice(any^mshape),s) { + x=new array_slice{ + _a=xx._a,_s=s + } + xx=x +} +proc _assign_internal_slice(&xx:array_slice(any^dshape),s) { + xxd=#(xx._a) + xxs=xxd._mshape#xx._s + xs=xxd._mshape#s + ltile=intersect(xxd._tile,xs) + ls=#ltile + var x=array(_arb(xx),ls) + _set_slice(&x,ls,PM__local(xx._a),overlap(xxd._tile,ltile)) + _copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxs, x,xxd,xxd._mshape#s,ltile) +} + +proc _copy_darray_slice(&xx,newd,xxs,x,oldd,xs,otile) { + _push_node_dist() + oldpart,oldtile=overlap(xs,oldd._tile) + newpart,newtile=overlap(xxs,newd._tile) + if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) { + p=index(dims(oldd.dist),pp) + if p/=_this_node() { + tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p)))) + ov=overlap(newd._tile,tile) + if size(ov)>0:_recv_slice(p,&xx,ov) + } + } + if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) { + p=index(dims(newd.dist),pp) + if p/=_this_node() { + tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p)))) + ov=overlap(otile,tile) + if size(ov)>0:_send_slice(p,x,ov) + } + } + if size(newpart)>0 and size(oldpart)>0 { + oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart)) + _set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o)) + } + PM__pop_node(newd) +} + +proc _copy_darray_slice(&xx:_comp^any,newd,xxs,x,oldd,xs,otile) { + _push_node_dist() + oldpart,oldtile=overlap(xs,oldd._tile) + newpart,newtile=overlap(xxs,newd._tile) + if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) { + p=index(dims(newd.dist),pp) + if p/=_this_node() { + tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p)))) + ov=overlap(otile,tile) + if size(ov)>0:_send_slice(p,x,ov) + } + } + if size(newpart)>0 and size(oldpart)>0 { + oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart)) + _set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o)) + } + if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) { + p=index(dims(oldd.dist),pp) + if p/=_this_node() { + tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p)))) + ov=overlap(newd._tile,tile) + if size(ov)>0:_recv_slice_sync(p,&xx,ov) + } + } + PM__pop_node(newd) +} + +proc _xp(x:single_point,y)=single_point(low(y)) +proc _xp(x,y)=y +// ************************************************* +// REFERENCES (SUBSCRIPTS AND SLICES) +// ************************************************* +// Reference type for & args +type PM__reftype(x) is x,^shared(x,,,,) +// Support for internal ^(...) reference type +PM__intrinsic _v1(x:any)->(PM__d1 x) : "elem"(1) +PM__intrinsic _v2(x:any)->(PM__d2 x) : "elem"(2) +PM__intrinsic _v3(x:any)->(PM__d3 x) : "elem"(3) +PM__intrinsic _v4(x:any)->(PM__d4 x) : "elem"(4) +PM__intrinsic _v5(x:any)->(PM__d5 x) : "elem"(5) +PM__intrinsic _v1%(r:any,s:any,h:any,x:any)->(PM__d1% x) : "elem"(1) +PM__intrinsic _v2%(r:any,s:any,h:any,x:any)->(PM__d2% x) : "elem"(2) +PM__intrinsic _v3%(r:any,s:any,h:any,x:any)->(PM__d3% x) : "elem"(3) +PM__intrinsic _v4%(r:any,s:any,h:any,x:any)->(PM__d4% x) : "elem"(4) +PM__intrinsic _v5%(r:any,s:any,h:any,x:any)->(PM__d5% x) : "elem"(5) +// Right hand side references +proc _make_null(x)=null +proc PM__subref(x,t)=error_type() check "Incorrect type in subscript"=>'false +proc PM__subref(x,t:subs){ + tt=_tup(t) + check_contains(#x,tt) + return _subref(x,tt) +} +proc PM__subref(x,t:null)=PM__subref(x,map($_make_null,#x)) +proc PM__subref(x:^*(,,,,),t:null)=PM__subref(x,map($_make_null,#_v1(x))) +proc _subref(x:any^mshape,t:index)=element(x,t) +proc _subref(x:any^any,t:subs)=new array_slice { + _a=x,_s=fill_in(#x,t,'true) +} +proc _subref(x:array_slice(any^mshape,),t:index)=element(x._a,x._s[t]) +proc _subref(x:array_slice,t:subs)=new array_slice { + _a=x._a,_s=x._s[t] +} +proc _subref(x:any^dshape,t:index)= PM__ref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t)) +proc _subref(x:array_slice(any^dshape,),t:index)=_subref(x._a,x._s[t]) +proc _subref(a:^*(,,,,),t)=PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a)) +proc _subref(a,t)=$[](a,t) +proc [](a:array,arg...)=PM__getref(PM__subref(a,_tup(arg...))) +// Left hand side references +proc PM__sublhsamp(x,t)=error_type() check "Incorrect type in subscript"=>'false +proc PM__sublhsamp(x,t:subs) { + tt=_tup(t) + check_contains(#x,tt) + return _sublhs(x,tt) +} +proc PM__sublhsamp(x:any^dshape,t:subs) { + test "Cannot have subscript of a distributed array in ""&"" argument"=>'false + return _arb(x) +} + +proc PM__sublhs(x,t)=error_type() check "Incorrect type in subscript"=>'false +proc PM__sublhs(x,t:subs) { + tt=_tup(t) + check_contains(#x,tt) + return _sublhs(x,tt) +} +proc PM__sublhs(x:^!(,,,,),t:subs) { + tt=_tup(t) + return _sublhs(x,tt) +} +proc PM__sublhs(x,t:null)=PM__sublhs(x,map($_make_null,#x)) +proc PM__sublhs(x:^!(,,,,),t:null)=PM__sublhs(x,map($_make_null,#_v1(x))) +proc _sublhs(x:any^mshape,t:index)=_make_subref(x,t) +proc _sublhs(x:any^any,t:subs)=new array_slice { + _a=x,_s=fill_in(#x,t,'true) +} +proc _sublhs(x:array_slice(any^mshape,),t:index)=_make_subref(x._a,x._s[t]) +proc _sublhs(x:array_slice,t:subs)=new array_slice { + _a=x._a,_s=x._s[t] +} +proc _sublhs(x:any^dshape,t:index)= PM__ref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#_tup(t)) +proc _sublhs(a:^!(,,,,),t)=PM__ref(_arb(_v1(a)),a,_tup(t),_v4(a),_v5(a)) +proc [](&a:array,v,arg...){ + PM__assign(&^(PM__sublhs(^(&a),_tup(arg...))),v) +} + +// Realise a reference +proc PM__valref(x)=x +proc PM__valref(x:^*(,,,,)) { + var v=_v1(x) + if _v4(x)==_shrd_node() { + v=_getref(x,null) + } + _bcast_shared(&v,_v4(x)) + return v +} + +// Assign to a reference +proc PM__assign(&x:^*(,,,,),y) { + check_assign_types(_v1(^(&x)),y) + if _v4(^(&x))==_shrd_node() { + PM__assign(&^(_getlhs(^(&x),null)),y) + } +} + +proc PM__assign(&x:^*(,,,,),y,p:assignment_operator) { + if _v4(^(&x))==_shrd_node() { + PM__assign(&^(_getlhs(^(&x),null)),p.(PM__valref(x),y)) + } +} + +// ************************************************************* +// DISTRIBUTED REFERENCES +// ************************************************************* +// Distributed reference is an internal compiler type +// ^ ( value or value_example, parent, subscript, node or [indexed_dim,dshape] , mode) +// mode is: +// null -- local reference +// _s_ref -- shrd index on darray, only shrd/indexed otherwise +// _sp_ref -- shrd index on darray, some priv after (or before) +// _d_ref -- indexed index on darray, shrd/indexed otherwise +// _dp_ref -- indexed index on darray, some priv after (or before) +// _p_ref -- priv index on darray and possibly elsewhere +type _s_ref is unique +type _sp_ref is unique +type _d_ref is unique +type _dp_ref is unique +type _p_ref is unique +PM__intrinsic _import_dref%(r:any,s:any,h:any,x:any)->(^^x) : "import_dref" +// Some trivial referencing cases +proc PM__sublhsamp%(x,t:subs)=PM__sublhs%(x,t) +proc PM__sublhsamp%(x:any^dshape,t:subs) { + test "Cannot have subscript of a distributed array in ""&"" argument"=>'false + return _arb(x) +} + +proc PM__sublhs%(x,y)=PM__subref%(x,y) +proc PM__sublhs%(x:priv ^*(,,,,),y)=PM__subref%(x,y) +proc PM__sublhs%(x:priv,y)=PM__sublhs(x,y):test """sync"" assignment updating a private variable"=>'false +proc PM__subref%(x:priv,y)=PM__subref(x,y) +proc PM__sublhs%(x:priv,y:invar indexed)=PM__sublhs(x,*y) +proc PM__subref%(x:priv,y:invar indexed)=PM__subref(x,*y) +proc PM__subref%(region:mshape,x:invar any^mshape,y:index)=PM__subref(x,y) +proc PM__subref%(region:mshape,x:invar any^mshape,y:subs)=PM__subref(x,y) +proc PM__subref%(region:mshape,x:invar any^mshape,y:invar indexed)=PM__subref(x,_dmap(y,here)) +proc PM__sublhs%(region:mshape,x:priv,y)=PM__sublhs(x,y):test """sync"" assignment updating a private variable"=>'false +proc PM__sublhs%(region:mshape,x,y)=PM__sublhs(x,y) +proc PM__sublhs%(region:mshape,x:any^dshape,y)=PM__subref%(x,y) +proc PM__subref%(x,y:indexed_dim)=PM__subref%(x,_tup%(y)) +// Reference of non-distributed array with priv or indexed subscript +proc PM__subref%(x:invar any^mshape,t:index){ + tt=_tup(t) + check_contains(#x,tt) + i=index(#x,tt) + return PM__dref(_get_aelem(x,i),x,i,null,null) +} +proc PM__subref%(x:invar any^mshape,t:subs){ + tt=_tup(t) + check_contains(#x,tt) + return PM__drefs(x,x,tt,null,null) +} +proc PM__subref%(x:invar any^mshape,t:invar indexed)=PM__subref%(x,_dmap(t,here)) +proc PM__subref%(x:invar array_slice,t,m)=PM__subref%(x._a,x._s[t]) +proc PM__subref%(x,t)=PM__dref($[](x,t),x,t,null,null) +// Subscript or slice of distributed array +proc PM__subref%(x:shared any^dshape,t:invar index) complete <>{ + tt=_tup(t) + check_contains(#(x),tt) + return PM__dref(_arb(x),x,i,p,_s_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#tt) +} +proc PM__subref%(x:shared any^dshape,t:index){ + tt=_tup(t) + check_contains(#(x),tt) + return PM__dref(_arb(x),x,i,p,_p_ref) where p,i=node_and_index((#x).dist,(#x)._mshape#tt) +} +proc PM__subref%(x:shared any^dshape,t:subs){ + tt=_tup(t) + check_contains(#(x),tt) + var xx=varray(_arb(x),empty(#x)) + return PM__drefs(xx,x,tt,p,_p_ref) where p=nodes_for_grid((#x).dist,tt) +} +proc PM__subref%(x:shared any^dshape,t:invar indexed) cond =PM__subref%(x,*t) +proc PM__subref%(region:shape(,blocked_distr),x:shared any^dshape(,blocked_distr),t:invar indexed) uncond { + check_contains(#x,_dmap(t,here)) + return PM__drefi(_arb(x),x,tt,[tt,#x],_d_ref) where tt=_tup(t) +} +proc PM__subref%(x:shared any^dshape,t:invar indexed) uncond =PM__subref%(x,*t) +// Subscript or slice of non-distristuted array which is itself result of variant slice +proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:index){ + tt=_tup(t) + check_contains(#_v1%(x),tt) + i=index(#(_v1%(x)),tt)return PM__dref(_get_aelem(_v1%(x),i),x,i,null,null) +} +proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar index){ + tt=_tup%(t) + check_contains(#_v1%(x),tt) + i=index(#(_v1%(x)),tt) + return PM__drefi(_get_aelem(_v1%(x),i),x,t,null,null) +} +proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:subs) { + tt=_tup(t) + check_contains(#(_v1%(x)),tt) + return PM__drefs(PM__import_val(_v1%(x)),x,tt,null,null) +} +proc PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar indexed)=PM__subref%(x,_dmap(t,here)) +// Subscript or slice of darray which is itself the result of a priv subscript +proc PM__subref%(x:priv ^*(any^dshape,,,null,null),t:index){ + tt=_tup(t) + check_contains(#_v1%(x),tt) + return PM__dref(_arb(_v1%(x)),_v2%(x),i,p,_p_ref) where p,i=node_and_index((#_v1%(x)).dist,(#_v1%(x))._mshape#tt) +} +proc PM__subref%(x:priv ^*(any^dshape,,,null,null),t:subs){ + tt=_tup(t) + check_contains(#_v1%(x),tt) + return PM__drefs(PM__import_val(_v1%(x)),x,tt,p,_p_ref) where p=nodes_for_grid((#_v1%(x)).dist,tt) +} +proc PM__subref%(x:priv ^*(any^dshape,,,null,null),t:invar indexed)=PM__subref%(x,_dmap(t,here)) +// Subscript of a priv slice +proc PM__subref%(x:priv ^#(,,,null,null),t:subs)=PM__subref%(_v2%(x),_v3%(x)[_tup(t)]) +proc PM__subref%(x:priv ^#(,,,null,null),t:invar indexed)=PM__subref%(_v2%(x),_v3%(x)[tt]) where tt=_dmap(t,here) +// Subscript of distributed reference +proc _arb%(x:partial)=_arb(x) +proc _arb%(x:complete) complete <>=_arb(x) +proc _arb%(x:chan) complete <>=_arb(x) +proc _arb%(x:invar) complete <>=_arb(x) +proc PM__subref%(x:priv ^*(any^any,,,,),t:invar subs)=PM__drefi(_arb%(_v1%(x)),x,_tup%(t)) +proc PM__subref%(x:priv ^*(any^any,,,,),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t)) +proc PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_sp_ref) +proc PM__subref%(x:priv ^*(any^any,,,,),t:invar indexed)=PM__subref%(x,_dmap(_tup(t),here)) +proc PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:invar indexed)=PM__drefi(_arb%(_v1%(x)),x,_tup(t)) +proc PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar indexed)=PM__drefi(_arb%(_v1%(x)),x,_tup(t)) +proc PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar subs)=PM__drefi(_arb%(_v1%(x)),x,_tup%(t)) +proc PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:priv subs)=PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_dp_ref) +// Node .[] subscript of distributed array +type _lcl is unique{_LCL} +proc PM__nodelhs%(x,y)=PM__noderef%(x,y) +proc PM__noderef%(region:dshape,x:shared any^dshape,y:invar null)=^(PM__import_val(PM__local(x)),coherent) +proc PM__noderef%(region:dshape,x:shared any^dshape,y:invar any_int){ + xd=#((#x).dist) + check_contains(xd,y) + return PM__drefi(PM__local(x),x,_LCL,p,_s_ref)where p=index(xd,int(y)) +} +proc PM__noderef%(region:dshape,x:shared any^dshape,y:priv any_int){ + xd=#((#x).dist) + check_contains(xd,y) + return PM__drefi(PM__local(x),x,_LCL,p,_p_ref)where p=index(xd,y) +} +proc PM__noderef%(region:dshape,x:shared any^dshape,y:shared indexed)=PM__noderef%(x,*y) +proc PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:invar any_int){ + xd=#((#x).dist) + check_contains(xd,y) + return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_sp_ref)where p=index(xd,int(y)) +} +proc PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:priv any_int){ + xd=#((#x).dist) + check_contains(xd,y) + return PM__drefi(PM__local(_v1%(x)),x,_LCL,p,_p_ref)where p=index(xd,int(y)) +} +proc PM__noderef%(x:priv ^*(any^dshape,,,null,null),y:shared indexed)=PM__noderef%(x,*y) +proc PM__noderef%(x,y)=error_type() { + if not region is { + test """.[]"" subscript in non-distributed region"=>'false} elseif x is { + test """.[]"" subscript cannot be applied to a mirrored array"=>'false} elseif not x is { + test """.[]"" subscript applied to a non-array"=>'false} elseif not y is { + test """.[]"" subscript must have an integer value"=>'false} else { + test "Incorrect "".[]"" subscript"=>'false + } +} + +// May need to cap off reference with here +type _here(t) is rec {here:t} +proc _cap%(x,h)<>=x +proc _cap%(x:contains(indexed),h)<>=PM__dref(_v1%(x),x,new _here { + here=h +} +) +proc _capn%(x,h)<>=PM__dref(_v1%(x),x,new _here { + here=h +} +) +// Treat ! variables differently only for limited circumstances in drefs +proc _drat(at,tile,t)='false +proc _drat(at:'true,tile:tuple(range or block_seq),t:indexed and _dr)='true +type _di(n) is indexed_dim('1,'1,,n) or int +type _dr is [_di('1)],[_di('1),_di('2)],[_di('1),_di('2),_di('3)],[_di('1),_di('2),_di('3),_di('4)],[_di('1),_di('2),_di('3),_di('4),_di('5)],[_di('1),_di('2),_di('3),_di('4),_di('5),_di('6)],[_di('1),_di('2),_di('3),_di('4),_di('5),_di('6),_di('7)] +// Resolve a distributed reference +proc PM__getref%(x,at)=x +proc PM__getref%(x:priv ^*(,,,null,null),at)=_v1%(x) +proc PM__getref%(x:priv ^*(,,,int,_p_ref),at) { + PM__recv pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null) + return v +} +proc PM__getref%(x:priv ^*(,,,int,_sp_ref),at) { + PM__serve pp,xx,v,_cap%(x,here),_v4%(x),at,_getref(xx,null) + return v +} +proc _scatter(x,region) { + if _this_node()==_v4(x):foreach node in #region.dist { + d=#region._mshape + a={ + _getref(_import_dref%(x),j): j in d + } + p=index(dims(region.dist),node) + _send_slice(p,a,region.dist[node]) + } +} + +proc PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) complete <> { + chan var xx=_v1%(x) + _getref_s%(&xx!,^^(x),at) + _bcast_shared(&xx) + return xx +} +proc _getref_s%(&xx:invar,x:invar,at:invar) PM__node { + PM__head_node{ + _irecv(_v4(x),&xx) + } + _scatter(x,region) + _sync_messages(xx,x) +} +proc PM__getref%(x:complete ^*(_comp,,,int,_s_ref),at:invar) complete <>{ + chan var xx=_v1%(x) + _getref_sc%(&xx!,^^(x),at) + _bcast_shared(&xx) + return xx +} +proc _getref_sc%(&xx:invar,x:invar,at:invar) PM__node { + _scatter(x,region) + PM__head_node{ + _recv(_v4(x),&xx) + } + _sync_messages(xx,x) +} +proc PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) complete <> { + chan var a=_v1%(x) + _getref_d%(&^(PM__local%(^(&a!))),^^(x),at <>) + _bcast_shared(&a) + return a +} + +proc _getref_d%(&a:invar,x:invar,at:invar) PM__node { + _get_dindex_from_dref(&a,x,t.2,_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) where t=_v4(x) +} +proc PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) complete <> { + chan var a=_arb(_v2%(x)) + _getref_dc%(&a!,^^(x),at <>) + _bcast_shared(&a) + return a +} +proc _getref_dc%(&a:invar,x:invar,at:invar) PM__node { + PM__head_node{ + _get_dindex(&^(PM__local(^(&a))),PM__local(_v2(x)),t.2,_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) where t=_v4(x) + } +} + +proc PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) complete <> { + chan var a=_v1%(x) + _getref_dp%(&^(^^(^(&a))),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>) + _bcast_shared(&a) + return a +} +proc _getref_dp%(&a:invar,x:invar,at:invar,atq:invar,t:invar) PM__node { + PM__head_node{ + _get_dindex_from_ref(&a,x,t.2, _local_region(region._tile,subregion(schedule)),region, t.1,atq,_drat(at,region._tile,t.1)) + } +} +proc PM__getref%(x:priv ^#(,,,,),at) { + var v=varray(_arb(_v1%(x)),#_v3%(x)) + var vv=varray(_arb(_v1%(x)),empty(#_v1%(x))) + foreach p in _v4%(x) { + dist=(#(_getref(_v2%(x),null))).dist + u=overlap(_v3%(x),dist[p]) + ppp=index(dims(dist),p) + PM__recv pp,xx,vvv,_cap%(x,here),ppp,at,_getref(xx,null) + v[u]=vvv + } + return v +} + +// Resolve reference locally (once communicated) +proc _getref_elem(x:any^mshape,i)=_get_aelem(x,i) +proc _getref_elem(x:any^dshape,i)=_get_aelem(PM__local(x),i) +proc _getref(x:^*(,,int,,),y)=_getref_elem(_getref(_v2(x),y),_v3(x)) +proc _getref(x:^*(,,_here,,),y:null)<>=_getref(_v2(x),_v3(x).here) +proc _getref(x:^*(,,subs,,),y)<>=_getref(_v2(x),y)[_v3(x)] +proc _getref(x:^*(,,null,,),y)<>=_getref(_v2(x),y) +proc _getref(x:^*(,,_lcl,,),y)<>=PM__local(_getref(_v2(x),y)) +proc _getref(x:^.(,,,,),y)<>=_getref(_v2(x),y).^(x) +proc _getref(x:^shared(,null,null,null,null),y)<>=_v1(x) +proc _getref(x:^#(,,,,),y)<>=_getslice(_getref(_v2(x),y),_v3(x)) +proc _getslice(x:any^dshape,tt) { + t=overlap((#x)._tile,tt) + var v=varray(_arb(x),#t) + v=PM__local(x)[t] + return v +} +proc _getslice(x:any^mshape,t) { + var v=varray(_arb(x),#t) + v=x[t] + return v +} +proc _getref(x:any^any,y)=x +proc _getref(x:^shared(,,indexed,,),y)<>=_getref(_v2(x),y)[_dmap(_v3(x),y)] +proc _getref(x:^shared(,any^dshape,indexed,,),y)<>=element(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) where ms=#_v2(x) +proc _getref(x:^shared(,,indexed,,),y:null)<>=_v1(x) :test "Internal error - uncapped dref" => 'false +PM__if_compiling +PM__intrinsic _sync%(any,any,any,&x:any): "sync" +PM__else +proc _sync%(&x:any){ +} +PM__endif +// Assignment of distributed and/or shared or uniform references +proc PM__assign%(&x:priv,y,at) { + _sync%(&x) + PM__assign(&x,y <>) +} +proc PM__assign%(&x:invar,y,at) { + _sync%(&x) + _assign_to_invar%(&x,y) +} +proc _assign_to_invar%(&x:uniform,y:invar) complete { + PM__assign(&x,y <>) +} + +proc _assign_to_invar%(&x:shared,y:invar) shared{ + PM__assign(&x,y) +} + +proc _assign_to_invar%(&x:invar,y:priv) { + test "Can only assign an ""invar"" value to an ""invar"" variable" => 'false +} + +proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y,at) { + PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { + PM__assign(&^(_getlhs(^(&xx),null)),yy) + } + PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,'false { + test "Cannot assign element twice in same assignment"=> _getref(xx,null)==yy + } +} + +proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y:invar,at) { + PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { + PM__assign(&^(_getlhs(^(&xx),null)),y) + } +} + +proc PM__assign%(&x:priv ^*(,,,null,null),y,at) { + foreach invar p in 0..size(#region.dist)-1 { + PM__bcast xx,yy,_cap%(x,here),y,p { + PM__assign(&^(_getlhs(^(&xx),null)),yy) + } + } + foreach invar p in 0..size(#region.dist)-1 { + PM__bcast xx,yy,_cap%(x,here),y,p { + test "Cannot assign an element two different values in a single assignment"=> _getref(xx,null)==yy + } + } +} + +proc PM__assign%(&x:priv ^*(,,,null,null),y:invar,at) { + _sync%(&x) + var xx=_import_dref%(x) + PM__assign(&^(_getlhs(^(&xx),here)),y) +} +proc PM__assign%(&x:priv ^*(,null,null,null,null),y:invar,at) { + _sync%(&x) + PM__assign(&^(_v1%(^(&x))),y) +} +proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y,at) { + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { + PM__assign(&^(_getlhs(^(&xx),null)),yy) + } + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,'false { + test "Cannot assign element to two different values in same assignment"=> _getref(xx,null)==yy + } +} + +proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y:invar,at) { + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { + PM__assign(&^(_getlhs(^(&xx),null)),PM__import_val(y)) + } +} + +proc PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y,at) { + _set_ref_dp%(&^(^^(_cap%(^(&x),here))),^(^^(y)), $_just_assign,^^(^??),at,_v4(x) <>) +} +proc _just_assign(x,y)=y +proc _set_ref_dp%(&x:invar,y:invar, prc:invar,atq:invar,at:invar,t:invar) PM__node { + _set_dindex_of_ref(&x,y,t.2,_local_region(region._tile,subregion(schedule)),region,t.1,prc,atq,at) +} + +// Operater assignment: x =y +proc PM__assign%(&x:priv,y:priv,pr,at) { + PM__assign(&x,y,pr) +} +proc PM__assign%(&x:priv,y:invar,pr,at) { + PM__assign(&x,y,pr) +} +proc PM__assign%(&x:invar,y,pr,at) { + _assign_to_invar%(&x,y,pr,at) +} + +proc _assign_to_invar%(&x:uniform,y:invar,pr:uniform,at:uniform) complete{ + PM__assign(&x,y,pr <>) +} + +proc _assign_to_invar%(&x:shared,y:invar,pr:uniform,at:uniform) shared { + PM__assign(&x,y,pr) +} + +proc _assign_to_invar%(&x:invar,y:priv,pr,at){ + _assign_to_invar%(&x,_reduce_for_assign%(pr,y,x),pr,at) +} +proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y,pr,at) { + PM__send p,xx,yy,_cap%(x,here),_v4%(x),y,at { + PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) + } +} + +proc PM__assign%(&x:priv ^*(,,,int,_p_ref),y:invar,pr,at) { + PM__send p,xx,yy,_cap%(x,here),_v4%(x),null,at { + PM__assign(&^(_getlhs(^(&xx),null)),y,pr) + } +} + +proc PM__assign%(&x:priv ^*(,,,null,null),y:priv,pr,at) { + foreach invar p in 0..size(region.dist)-1 { + PM__bcast xx,yy,_cap%(x,here),y,p { + PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) + } + } +} + +proc PM__assign%(&x:priv ^*(,,,null,null),y:invar,pr,at) { + var xx=_import_dref%(x) + PM__assign(&^(_getlhs(^(&xx),here)),y,pr) +} +proc PM__assign%(&x:priv ^*(,null,null,null,null),y:invar,pr,at) { + PM__assign(&^(_v1%(^(&x))),y,pr) +} +proc PM__assign%(&x:priv ^*(,,,int,_sp_ref or _s_ref),y:priv,pr,at) { + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),y,at { + PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) + } +} + +proc PM__assign%(&x:priv ^*(,,,int,_sp_ref),y:invar,pr,at) { + PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { + PM__assign(&^(_getlhs(^(&xx),null)),y,pr) + } +} + +proc PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y:priv,pr,at) { + _set_dindex_of_ref%(&^(^^(_cap%(^(&x),here))),^^(y),t.2,_local_region(region._tile,subregion(schedule)),region,t.1,pr,^^(^??),at <>)where t=_v4%(x) +} +// Resolve LHS reference (locally after communication) +proc _getlhs(x:^*(,,_here,,),y)=_getlhs(_v2(x),_v3(x).here) +proc _getlhs(x:^*(,,_lcl,,),y)=_getlhs(_v2(x),y) +proc _getlhs(x:^(,,int,,),y)=_make_subref(_getlhs(_v2(x),y),int(_v3(x))) +proc _getlhs(x:^shared(,,null,,),y)=_getlhs(_v2(x),y) +proc _getlhs(x:^shared(,,int,,),y)=_make_subref(_getlhs(_v2(x),y),int(_v3(x))) +proc _getlhs(x:^(,,subs,,),y)=PM__sublhs(_getlhs(_v2(x),y),_v3(x)) +proc _getlhs(x:^shared(,,subs,,),y)=PM__sublhs(_getlhs(_v2(x),y),_v3(x)) +proc _local_ref(x,t)=PM__subref(x,overlap((#x)._tile,t)) +proc _getlhs(x:^#(,,subs,,),y)<>=_local_ref(x,_v3(x)) +proc _getlhs(x:^#shared(,,subs,,),y)<>=_local_ref(x,_v3(x)) +proc _getlhs(x:^.(,,,,),y)<>=_getlhs(_v2(x),y).^&(x) +proc _getlhs(x:^shared(,null,null,null,null),y)<>=_v1(x) +proc _getlhs(x:^(,null,null,null,null),y)<>=_v1(x) +proc _getlhs(x:any^any,y)=x +proc _getlhs(x:any^dshape,y)=PM__local(x) +proc _getlhs(x:^shared(,,indexed,,),y)<>=_make_subref(_getlhs(_v2(x),y),_dmap(_v3(x),y)) +proc _getlhs(x:^shared(,any^dshape,indexed,,),y)<>=_make_subref(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) where ms=#_v2(x) +proc _getlhs(x:^shared(,,indexed,,),y:null)=_v1(x) :test "Internal error -- uncapped indexed ref" => 'false +// ************************************************************** +// INDEXED VARIABLES +// ************************************************************** +type indexed_dim(d:int,m:int,c:int,n:int) is rec {_m:m='1,_c:c='0,_d:d='1,_n:n} +type indexed(t:int) is tuple(indexed_dim or int) except tuple(int) +proc PM__makeidxdim(x:null,y)=new indexed_dim { + _n=y +} +proc PM__makeidxdim(x:null)=new indexed_dim { + _n=null +} +proc PM__makeidxdim(x:range,y)=new indexed_dim { + _c=x._lo,_n=y +} +proc PM__makeidxdim(x:strided_range,y)=new indexed_dim { + _c=x._lo,_m=x._st,_n=y +} +proc PM__makeidxdim(x,y)=PM__makeidxdim(get_dim(x,y),y) +proc PM__makeidxdim(x:tuple)=map($PM__makeidxdim,x,indices(x)) +proc PM__makeidxdim(x:seq)=[PM__makeidxdim(x,'1)] +proc PM__makeidx(x:indexed_dim or indexed)=new _indexed { + _t=_tup(x),_r=null +} +proc PM__makeidx(x:indexed_dim or indexed,y)=new _indexed { + _t=_tup(x),_r=y +} +proc PM__makeidx(x,y)=x :test "Malformed indexed expression" => 'false +proc PM__makeidx(x)=x :test "Malformed indexed expression" => 'false +proc *%(x:indexed)=_dmap(x,here) +proc *%(x)=here check"""*"" operator can only be applied to an ""indexed"" value"=>'false +proc *(x)=x check"""*"" operator cannot be applied outside of a parallel context"=>'false +proc +(x:indexed_dim,yy:any_int)=new indexed_dim { +_m=x._m,_c=x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy) +proc +(yy:any_int,x:indexed_dim)=new indexed_dim { +_m=x._m,_c=x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy) +proc -(x:indexed_dim,yy:any_int)=new indexed_dim { +_m=x._m,_c=x._c-y*x._d,_d=x._d,_n=x._n} where y=int(yy) +proc -(yy:any_int,x:indexed_dim)=new indexed_dim { +_m=-x._m,_c=-x._c+y*x._d,_d=x._d,_n=x._n} where y=int(yy) +proc *(x:indexed_dim,yy:any_int)=new indexed_dim { +_m=x._m*y,_c=y*x._c,_d=x._d,_n=x._n} where y=int(yy) +proc *(yy:any_int,x:indexed_dim)=new indexed_dim { +_m=x._m*y,_c=y*x._c,_d=x._d,_n=x._n} where y=int(yy) +proc /(x:indexed_dim,yy:any_int)=new indexed_dim { +_m=x._m,_c=x._c,_d=x._d*y,_n=x._n} where y=int(yy) +proc +(x:indexed_dim,y:indexed_dim)=new indexed_dim { + _m=x._m*y._d+y._m*x._d,_c=x._c*y._d+y._c*x._d,_d=x._d*y._d,_n=x._n +} +proc -(x:indexed_dim,y:indexed_dim)=new indexed_dim { + _m=x._m*y._d-y._m*x._d,_c=x._c*y._d-y._c*x._d,_d=x._d*y._d,_n=x._n +} +proc string(x:indexed_dim)="($here."++x._n++"*"++x._m++"+"++x._c++")/"++x._d +proc string(x:indexed_dim('1))="$here."++x._n++"*"++x._m++"+"++x._c +proc string(x:indexed_dim('1,'1))="$here."++x._n++"+"++x._c +proc string(x:indexed_dim('1,'1,'0))="$here."++x._n +proc _correct(x:indexed,y:extent)=map($-,x,low(y)) +proc _dmap(x:any_int,n:int)=x +proc _dmap(x:any_int,n:grid_slice_dim)=single_point(x) +proc _dmap(x:any_int,n:tuple(int))=x +proc _dmap(x:any_int,n:tuple(grid_slice_dim))=single_point(x) +proc _dmap(x:indexed_dim,n:int)=(n*x._m+x._c)/x._d +proc _dmap(x:indexed_dim,n:tuple)=_dmap(x,get_dim(n,x._n)) +proc _dmap(x:indexed_dim,n:grid_slice_dim)=min(lo,hi)..max(lo,hi)where lo=_dmap(x,low(n)),hi=_dmap(x,high(n)) +proc _dmap(x:indexed_dim('1,'1),n:strided_range)=n._lo+x._c..n._hi+x._c by n._st +proc _dmap(x:indexed_dim('1,'1),n:block_seq)=block_seq(n._lo+x._c,n._hi+x._c,n._st,n._b,n._align) +proc _dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice)=map_const($_dmap,x,n) +proc _dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice,s:extent)=s#map_const($_dmap,x,n) +type _round_up is unique +type _round_down is unique +proc _dunmap(x:indexed_dim,n:null)=null +proc _dunmap(x:indexed_dim,n:int,r:_round_down)=(n*x._d-x._c)/x._m +proc _dunmap(x:indexed_dim,n:int,r:_round_up)=(n*x._d+x._m-sign(1,x._m)-x._c)/x._m +proc _dunmap(x:indexed_dim,n:tuple)=_dunmap(get_dim(n,x._n),x) +proc _dunmap(x:indexed_dim,n:grid_slice_dim)=min(lo,hi)..max(lo,hi) where lo=_dunmap(x,low(n),_round_down),hi=_dunmap(x,high(n),_round_up) +proc _dun(x:indexed_dim,m,n:extent)=replace(n,x._n,intersect(get_dim(n,x._n),_dunmap(x,m))) +proc _dun(x:int,m,n:extent)=n +proc _dunmap(x:indexed,m:grid_slice or tuple(int),n:extent)=_dun(x.1,m.1,nn) where nn=_dunmap(tail(x),tail(m),n) +proc _dunmap(x:[indexed_dim or int],m:grid_slice or tuple(int),n:extent)=_dun(x.1,m.1,n) +// Given tile and global region (which may be null) compute local region +proc _local_region(t,r:null)=t +proc _local_region(t,r)=intersect(t,r) +proc _root_node(at:'true)=_root_node() +proc _root_node(at:'false)=_this_node() +// Resolve x[indexed] +proc _get_dindex(&a,x,shapex,local_tile,local_region,t:indexed,at) { + tt=_correct(t,shapex._mshape) + if size(_dmap(tt,local_region._mshape))*4>size(local_region._mshape) { + if at or a is <_comp^any> { + _get_dindex_ss(&a,x,shapex,local_tile,local_region,tt,at) + } else { + _get_dindex_s(&a,x,shapex,local_tile,local_region,tt,at) + } + } else { + if at or a is <_comp^any> { + _get_dindex_rs(&a,x,shapex,local_tile,local_region,tt,at) + } else { + _get_dindex_r(&a,x,shapex,local_tile,local_region,tt,at) + } + } +} + +// Resolve x[indexed] for cases where size(x[indexed])>=size(region) +// -- in this case send one value for every point in current (sub)region +proc _get_dindex_s(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) { + PM__head_node{ + shapexx=#shapex._mshape + this_tile=shapex._tile + foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { + if contains(#(shapex.dist),p) { + i=index(dims(shapex.dist),p) + if i/=_this_node(){ + other_tile=element(shapex.dist,p) + dest_range2=_dunmap(t,other_tile,local_region._mshape) + portion_to_recv=overlap(local_tile,dest_range2) + if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv) + } + } + } + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(local_region.dist,dest_range){ + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + portion_to_recv=intersect(other_tile,dest_range) + if size(portion_to_recv)>0: _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile) + } + } + } + _copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t) + _sync_messages(a,x) + } +} + +// Resolve x[indexed] for cases where size(x[indexed])<=size(region) +// -- in this case send those values in x which are needed to calculate x[indexed] +proc _get_dindex_r(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) { + shapexx=#shapex._mshape + src_range=_dmap(t,local_tile) + var b=array(_arb(a),#src_range) + foreach p in nodes_for_grid(shapex.dist,src_range) { + if contains(#(shapex.dist),p) { + i=index(dims(shapex.dist),p) + if i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(src_range,other_tile) + if size(portion_to_send)>0:_recv_slice(i,&b,active_dims(src_range,portion_to_send)) + } + } + } + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(local_region.dist,dest_range){ + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + src_range2=_dmap(t,other_tile) + portion_to_send=overlap(shapex._tile,src_range2) + if size(portion_to_send)>0:_send_slice(i,x,portion_to_send) + } + } + } + u,v=overlap(src_range,shapex._tile) + forall i in u,j in v{ + _set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <>) + } + _sync_messages(x,b) + _copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t) +} + +// Resolve x[indexed] for cases where size(x[indexed])>=size(region) +// -- in this case send one value for every point in current (sub)region +// -- Version for more complex types that need sync receive +proc _get_dindex_ss(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) { + shapexx=#shapex._mshape + this_tile=shapex._tile + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(local_region.dist,dest_range){ + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + portion_to_recv=intersect(other_tile,dest_range) + if size(portion_to_recv)>0: _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile) + } + } + } + _copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t) + foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { + if contains(#(shapex.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(shapex.dist,p) + dest_range2=_dunmap(t,other_tile,local_region._mshape) + portion_to_recv=overlap(local_tile,dest_range2) + if size(portion_to_recv)>0 { + _recv_slice_sync(i,&a,portion_to_recv) + } + } + } + } + _sync_messages(a,x) +} + +// Resolve x[indexed] for cases where size(x[indexed])<=size(region) +// -- in this case send those values in x which are needed to calculate x[indexed] +// -- Version for more complex types that need sync receive +proc _get_dindex_rs(&a:_comp^any,x,shapex,local_tile,local_region,t:indexed,at) { + PM__head_node { + shapexx=#shapex._mshape + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(local_region.dist,dest_range){ + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + src_range=_dmap(t,other_tile) + portion_to_send=overlap(shapex._tile,src_range) + if size(portion_to_send)>0:_send_slice(i,x,portion_to_send) + } + } + } + } + src_range=_dmap(t,local_tile) + var b=array(_arb(a),#src_range) + if _head_node() or at { + u,v=overlap(src_range,shapex._tile) + forall i in u,j in v { + _set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <>) + } + foreach p in nodes_for_grid(shapex.dist,src_range) { + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(src_range,other_tile) + if size(portion_to_send)>0{ + PM__head_node{ + _recv_slice_sync(i,&b,active_dims(src_range,portion_to_send)) + } + if at:_bcast_slice_shared(&b,active_dims(src_range,portion_to_send)) + } + } + } + } + } + _copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t) + _sync_messages(x,b) +} + +proc _copy_dmapped(&a,a_tile,a_extent,b,b_tile,t) { + u=overlap(a_tile,_dunmap(t,b_tile,a_extent)) + forall i in u { + j=b_tile#_dmap(t,a_tile[i]) + if j in #b_tile:_set_elem(&a,PM__getelem(b,j),i <>) + } +} + +proc _copy_dmapped_ref(&a,a_tile,a_extent,b,b_tile,t) { + u=intersect(a_tile,_dunmap(t,b_tile,a_extent)) + forall i in u { + bb=_import_dref%(b) + _set_elem(&a,_getref(bb,i),a_tile#i <>) + } +} + +// Resolve x[ indexed ][ indexed or shared ] ... +proc _get_dindex_from_dref(&a:any^any,x,shapex,local_tile,local_region,tt:indexed,at) { + t=_correct(tt,shapex._mshape) + shapexx=#shapex._mshape + this_tile=shapex._tile + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { + if contains(#(shapex.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node(){ + other_tile=element(shapex.dist,p) + dest_range2=_dunmap(t,other_tile,local_region._mshape) + portion_to_recv=overlap(local_tile,dest_range2) + if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv) + } + } + } + nodes=nodes_for_grid(local_region.dist,dest_range) + var b=array(varray(_arb(a),spread(1..0,local_region._mshape)),#nodes) + foreach pp in #nodes { + p=nodes[pp] + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + portion_to_recv=intersect(other_tile,dest_range) + if size(portion_to_recv)>0 { + b[pp]={ + _getref(_import_dref%(x),h):h in portion_to_recv + } + _isend(i,b[pp]) + } + } + } + } + _copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t) + _sync_messages(a,x) +} + +// Resolve x[ indexed ][ indexed or shared ] ... +proc _get_dindex_from_dref_s(&a:_comp^any,x,shapex,local_tile,local_region,tt:indexed,at) { + t=_correct(tt,shapex._mshape) + shapexx=#shapex._mshape + this_tile=shapex._tile + dest_range=_dunmap(t,shapex._tile,local_region._mshape) + nodes=nodes_for_grid(local_region.dist,dest_range) + var b=array(varray(_arb(a),spread(1..0,local_region._mshape)),#nodes) + foreach pp in #nodes { + p=nodes[pp] + if contains(#(local_region.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node() { + other_tile=element(local_region.dist,p) + portion_to_recv=intersect(other_tile,dest_range) + if size(portion_to_recv)>0 { + b[pp]={ + _getref(_import_dref%(x),h):h in portion_to_recv + } + _isend(i,b[pp]) + } + } + } + } + _copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t) + foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) { + if contains(#(shapex.dist),p) { + i=index(dims(local_region.dist),p) + if i/=_this_node(){ + other_tile=element(shapex.dist,p) + dest_range2=_dunmap(t,other_tile,local_region._mshape) + portion_to_recv=overlap(local_tile,dest_range2) + if size(portion_to_recv)>0{ + PM__head_node{ + _recv_slice_sync(i,&a,portion_to_recv) + } + if at:_bcast_slice_shared(&a,portion_to_recv) + } + } + } + } + _sync_messages(a,x) +} + +// Resolve x[ indexed ][ priv ] +proc _get_dindex_from_ref(&a,x,shapex,this_tile,local_region,t:indexed,complt,at) { + dest_range=_dmap(t,this_tile,#shapex._mshape) + foreach p in nodes_for_grid(shapex.dist,dest_range){ + i=index(dims(local_region.dist),p) + if contains(#(local_region.dist),p) and i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape)) + _send_recv_slice_req(i,x,&a,local_region._mshape,portion_to_send,complt) + } + } + src_range=_dunmap(t,shapex._tile,local_region._mshape) + forall j in overlap(this_tile,src_range) { + jj=index(#this_tile,j) + PM__do_at size(this_tile),jj,aa,a,xx,x { + PM__assign(&aa,_getref(xx,null)) + } + } + foreach p in nodes_for_grid(local_region.dist,src_range) { + if contains(#(local_region.dist),p) and index(dims(local_region.dist),p)/=_this_node() { + PM__recv_req pp,xx,x,_getref(xx,null) + } + } + if a is <_comp>: foreach p in nodes_for_grid(shapex.dist,dest_range){ + i=index(dims(local_region.dist),p) + if contains(#(local_region.dist),p) and i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape)) + _recv_slice_reply(i,&a,local_region._mshape,portion_to_send,complt) + } + } + _sync_messages(a,x) +} + +// Resolve x[ indexed ][ whatever ] = priv +proc _set_dindex_of_ref%(&x:invar,y:invar,shapex:invar,this_tile:invar,local_region:invar,tt:invar indexed, pr:invar proc,complt:invar,at:invar) PM__node <>:_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt,pr,complt,at) +proc _set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt:indexed, pr:proc,complt,at) { + t=_correct(tt,shapex._mshape) + dest_range=_dmap(t,this_tile,#shapex._mshape) + PM__head_node{ + foreach p in nodes_for_grid(shapex.dist,dest_range){ + i=index(dims(shapex.dist),p) + if contains(#(shapex.dist),p) and i/=_this_node() { + other_tile=element(shapex.dist,p) + portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape)) + _send_slice_assn(i,x,y,#this_tile,portion_to_send,complt) + } + } + } + src_range=_dunmap(t,shapex._tile,local_region._mshape) + for j in overlap(this_tile,src_range) { + jj=index(#this_tile,j) + PM__do_at size(this_tile),jj,yy,y,xx,x { + PM__assign(&^(_getlhs(xx,null)),yy,pr) + } + } + foreach p in nodes_for_grid(local_region.dist,src_range) { + i=index(dims(local_region.dist),p) + if contains(#(local_region.dist),p) and i/=_this_node() { + PM__recv_assn pp,xx,yy,x,y,at{ + PM__assign(&^(_getlhs(^(&xx),null)),yy,pr) + } + } + } + _sync_messages(x,y) +} + +// ************************************************************** +// Envelope and stencil definitions +// ************************************************************** +type envelope is rec{cross:extent or null,corner:extent or null,envelope:extent} +proc ortho(x:extent)=new envelope { + cross=x,corner=spread(0..0,x),envelope=x +} +proc ortho(x:extent,y:extent)=new envelope { + cross=if(x inc y=>x,y),corner=y,envelope=envelope(x,y) +} +proc envelope(x:envelope)=x.envelope +proc envelope(x:extent)=x +proc envelope(x:any_int,y:any_int)=min(xx,yy)..max(xx,yy) where xx=int(x),yy=int(y) +proc envelope(x:any_int,y:seq(any_int))=envelope(x..x,y) +proc envelope(x:seq(any_int),y:any_int)=envelope(x,y..y) +proc envelope(x:seq(any_int),y:seq(any_int))=if(size(x)>0=>if(size(y)>0=>min(lx,ly)..max(hx,hy),lx..hx),if(size(y)>0=>0..0,ly..hy)) where lx=min(llx,hhx),ly=min(lly,hhy),hx=max(llx,hhx),hy=max(lly,hhy)where llx=int(low(x)),lly=int(low(y)),hhx=int(high(x)),hhy=int(high(y)) +proc envelope(x:tuple,y:tuple)=map($envelope,x,y) +proc envelope(x:null,y:extent)=y +proc envelope(x:extent,y:null)=x +proc envelope(x:extent or null,y:envelope)=envelope(x,y.envelope) +proc envelope(x:envelope,y:extent or null)=envelope(x.envelope,y) +proc envelope(x:envelope,y:envelope)=envelope(x.envelope,y.envelope) +proc string(x:envelope)=string(x.cross++" ortho "++x.corner) +// ************************************************************** +// Support for nhd statement +// ************************************************************** +type _nhd is rec{_nbhd,_tile,_tilesz,_interior,_limits} +type nbhd(t) is struct^{_array:farray(t),_nbhd,_index,_here} +proc PM__nhd%(x:invar envelope or extent,bound:invar) shared <>=new _nhd { +_nbhd=x,_tile=t,_tilesz=#t,_interior=overlap(t,region._tile),_limits=_expand_limits(region._extent,envelope(x),bound)} where t=_get_halo(region,region._tile,envelope(x)) +proc PM__nhd%(x,bound:invar)=^(new _nhd { + _nbhd=n,_tile=t,_tilesz=#t,_interior=t,_limits=region._extent +} +,shared) where t=region._tile where n=xx where xx=spread(0..0,here){ + _check_nhd%(x) +} +proc _check_nhd%(n:invar envelope or extent) { +} +proc _check_nhd%(n:extent):test "Neighbourhood must be invar"=>'false +proc _check_nhd%(n):test "Neighbourhood must be an extent or envelope"=>'false +proc PM__check_bounds%(b:invar boundary){ + _check_ranks(extent(region),b) +} +proc PM__check_bounds%(b:boundary):test "Bounds must be ""invar"""=>'false +proc PM__check_bounds%(b):test "Bounds must have a boundary type"=>'false +proc _check_ranks(n:tuple,b:tuple):test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n),rank(b)) +proc _check_ranks(n:envelope,b:tuple):test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n.cross),rank(b)) +proc _check_ranks(n,b:tuple):test "Rank of boundary does not match that of neighbourhood"=>same_type('1,rank(b)) +proc _check_ranks(n,b){ +} +type boundary is boundary_dim,tuple(boundary_dim) +type boundary_dim is CYCLE,EXCLUDED,range(int),null +type CYCLE is unique +type EXCLUDED is unique +proc _expand_limits(t:range(int),n:range(int),b:boundary_dim)=t +proc _expand_limits(t:range(int),n:range(int),b:CYCLE)=_exterior(t,n) +proc _expand_limits(t:tuple,n:tuple,b:boundary_dim)=map($_expand_limits,t,n,spread(b,n)) +proc _expand_limits(t:tuple,n:tuple,b:tuple(boundary_dim))=map($_expand_limits,t,n,b) +proc PM__set_nhd%(&n,x:complete){ + n._array[n._nbhd._interior[n._index]]=x +} +proc PM__set_nhd%(&n,x):n._array[n._nbhd._interior[n._index]]=x check "Expression in ""nhd"" must be ""complete"""=>'false +proc PM__nhd_join(x)=x._array +proc PM__nhd_join(x,y)=new _join{ + head=x,tail=y._array +} +proc PM__nhd_var%(x,n:_nhd,i,h)<>=new nbhd{ + _array=_make_nhd%(^(x,shared),n._tilesz),_nbhd=n,_index=i,_here=h +} +proc PM__nhd_active(region,nbhd,bound:null)=region._extent +proc PM__nhd_active(region,nbhd,bound:tuple)=map($_nhd_active,region._extent,nbhd,bound) +proc PM__nhd_active(region,nbhd,bound){ + r=PM__nhd_active(region,nbhd,spread(bound,region._extent)) + return r +} +proc _nhd_active(r,n,b:CYCLE or null)=r +proc _nhd_active(r,n,b:range)=low(r)-min(0,low(b))..high(r)-max(0,high(b)) +proc _nhd_active(r,n,b:EXCLUDED)=_nhd_active(r,n,n) +proc _make_nhd%(x:invar,d:invar) shared <>{ + var v=array(x,d) + return v +} +proc PM__set_edge%(&x,y,z){ +} +proc PM__subref(x:nbhd,t:subs)=_nhd_sub(x,t) +proc PM__subref(x:nbhd,t:null)=_nhd_sub(x,t) +proc _nhd_sub(x:nbhd,t:any except contains(null or stretch_dim))=PM__subref(x._array,tt+x._nbhd._interior[x._index]) { + tt=_tup(t) + test "Subscript"++tt++" not in neighbourhood"++x._nbhd._nbhd=>contains(_foot(tt,x._nbhd._nbhd),tt),"At "++x._here++" nhd "++tt++" goes outside of boundary "++limits=>contains(limits,dtt) where limits=x._nbhd._limits where dtt=tt+x._here +} + +proc _nhd_sub(x:nbhd,t)=_arb(x._array)check "Subscripts with null or ""_"" dimensions not accepted for ""nbhd"""=>'false +proc PM__dup(x:nbhd)=x:test "Cannot make a variable or constant of type ""nbhd"""=>'false +proc envelope(x:_nhd)=envelope(x._nbhd) +proc envelope(x,y:_nhd)=envelope(x,y._nbhd) +proc envelope(x:_nhd,y:_nhd)=envelope(x._nbhd,y._nbhd) +type _join is struct^{head,tail} +proc PM__blocking%(x:null){ +} +proc PM__blocking%(x):test "Block expression must be tuple of integers"=>'false +proc PM__blocking%(x:tuple(any_int)){ + test "Rank of ""block="" does not match region"=>same_type(rank(x),rank(region)) + test "Block sizes must be positive"=>map_reduce($_positive,$and,x) +} +proc _positive(x)=x>0 +proc PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) shared <> { + PM__head_node{ + this_tile=region._tile + this_tile_x=nbhd._tile + pp=index2point(_this_node(),dims(region.dist)) + foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) { + if contains(#region.dist,i) and i/=pp { + p=index(dims(region.dist),i) + other_tile=element(region.dist,i) + tile_x=_get_halo(region._mshape,region._tile, _foot(i-pp,nbhd._nbhd)) + ov=this_tile_x#intersect(tile_x,other_tile) + if size(ov)>0 { + _recv_slice(p,&a,ov) + } + } + } + foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { + if contains(#region.dist,i) and i/=pp { + p=index(dims(region.dist),i) + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd)) + ov=overlap(this_tile_x,intersect(this_tile,other_tile_x)) + if size(ov)>0 { + _send_slice(p,a,ov) + } + } + } + _apply_boundaries(&a,region,envelope(nbhd._nbhd),this_tile_x,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),'false) + } +} + +proc PM__send_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { + PM__head_node{ + this_tile=region._tile + this_tile_x=nbhd._tile + pp=index2point(_this_node(),dims(region.dist)) + foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { + if contains(#region.dist,i) and i/=pp { + p=index(dims(region.dist),i) + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd)) + ov=overlap(this_tile_x,intersect(this_tile,other_tile_x)) + if size(ov)>0 { + _send_slice(p,a,ov) + } + } + } + _apply_boundaries(&a,region,envelope(nbhd._nbhd),this_tile_x,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),'false) + } +} + +proc inside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo..lo-y,hi-y..hi)) where lo=low(x),hi=high(x) +proc inside_edge(x:extent,y:tuple(int))=map($inside_edge,x,y) +proc outside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo+y..lo,hi..hi+y)) where lo=low(x),hi=high(x) +proc outside_edge(x:extent,y:tuple(int))=map($outside_edge,x,y) +proc _foot(d,n:envelope)=if(_crss(d)=>n.cross,n.corner) +proc _foot(d,n:extent)=n +proc PM__recv_nhd%(&a:invar,nbhd:invar,b:invar) shared <> { + PM__head_node{ + _apply_boundaries(&a,region,envelope(nbhd._nbhd),nbhd._tile,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),'true) + } +} + +proc PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { + PM__head_node{ + this_tile=region._tile + this_tile_x=nbhd._tile + pp=index2point(_this_node(),dims(region.dist)) + foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) { + if contains(#region.dist,i) and i/=pp { + p=index(dims(region.dist),i) + other_tile=element(region.dist,i) + tile_x=_get_halo(region._mshape,region._tile, _foot(i-pp,nbhd._nbhd)) + ov=this_tile_x#intersect(tile_x,other_tile) + if size(ov)>0 { + _recv_slice_sync(p,&a,ov) + } + } + } + _apply_boundaries(&a,region,envelope(nbhd._nbhd),region._tile,extent(region), envelope(nbhd._nbhd),b,rank(extent(region)),'true) + } +} + +proc PM__bcast_nhd%(&a:invar,nbhd:invar,b:invar) shared <> { + if shrd_nnode()>1 { + foreach i in 1..chunks(region,envelope(nbhd._nbhd))-1 { + chunk=chunk(region,envelope(nbhd._nbhd),i,b) + _bcast_slice_shared(&a,chunk) + } + } +} + +proc _rev(a:tuple)=map($_rev,a) +proc _rev(a:range)=-high(a)..-low(a) +proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:tuple,index,recv) { + _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,get_dim(bound,index),index,recv) + _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound,index-'1,recv) +} + +proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:tuple,index:'0,recv) { +} +proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound,index,recv) { +} +proc _apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:CYCLE,index,recv) { + ex=get_dim(extent,index) + ev=get_dim(envelope,index) + lo=low(ex) + hi=high(ex) + up=max(high(ev),0) + down=min(low(ev),0) + upper_outside=replace(extent,index,hi+1..hi+up) + upper_inside=replace(extent,index,hi+down+1..hi) + lower_outside=replace(extent,index,lo+down..lo-1) + lower_inside=replace(extent,index,lo..lo+up-1) + _copy_bounds(&a,d,n,this_tile_x,upper_outside,lower_inside,recv) + _copy_bounds(&a,d,n,this_tile_x,lower_outside,upper_inside,recv) +} + +proc _copy_bounds(&a,d,n,this_tile_x,to,from,recv:'false) { + oldpart,oldtile=overlap(from,d._tile) + newpart,newtile=overlap(to,this_tile_x) + foreach pp in nodes_for_grid(d.dist,element(from,newpart)) { + p=index(dims(d.dist),pp) + if pp in #d.dist and p/=_this_node() { + tile=element(to,overlap(from,element(d.dist,p))) + ov=overlap(this_tile_x,tile) + if size(ov)>0{ + _recv_slice(p,&a,ov) + } + } + } + foreach pp in nodes_for_grid(d.dist,_get_anti_halo(d,element(to,oldpart),n)) { + p=index(dims(d.dist),pp) + if pp in #d.dist and p/=_this_node() { + tile=element(from,overlap(to,_get_halo(d,element(d.dist,p),n))) + ov=this_tile_x#intersect(d._tile,tile) + if size(ov)>0{ + _send_slice(p,a,ov) + } + } + } +} + +proc _copy_bounds(&a:_comp^any,d,n,this_tile_x,to,from,recv:'false) { + oldpart,oldtile=overlap(from,d._tile) + newpart,newtile=overlap(to,this_tile_x) + foreach pp in nodes_for_grid(d.dist,_get_anti_halo(d,element(to,oldpart),n)) { + p=index(dims(d.dist),pp) + if pp in #d.dist and p/=_this_node() { + tile=element(from,overlap(to,_get_halo(d,element(d.dist,p),n))) + ov=this_tile_x#intersect(d._tile,tile) + if size(ov)>0{ + _send_slice(p,a,ov) + } + } + } +} + +proc _copy_bounds(&a,d,n,this_tile_x,to,from,recv:'true) { + oldpart,oldtile=overlap(from,this_tile_x) + newpart,newtile=overlap(to,this_tile_x) + o,oo=overlap(newpart,oldpart) + _set_slice(&a,element(newtile,o),a,element(oldtile,oo)) +} +proc _copy_bounds(&a:_comp^any,d,n,this_tile_x,to,from,recv:'true) { + oldpart,oldtile=overlap(from,this_tile_x) + newpart,newtile=overlap(to,this_tile_x) + o,oo=overlap(newpart,oldpart) + _set_slice(&a,element(newtile,o),a, element(oldtile,oo)) + foreach pp in nodes_for_grid(d.dist,element(from,newpart)) { + p=index(dims(d.dist),pp) + if pp in #d.dist and p/=_this_node() { + tile=element(to,overlap(from,element(d.dist,p))) + _recv_slice(p,&a,overlap(this_tile_x,tile)) + } + } +} + +proc _send_slice(p,a:_join,o) { + _send_slice(p,a.head,o) + _send_slice(p,a.tail,o) +} +proc _recv_slice(p,&a:_join,o) { + _recv_slice(p,&a.head,o) + _recv_slice(p,&a.tail,o) +} +proc _recv_slice_sync(p,&a:_join,o){ + _recv_slice_sync(p,&a.head,o) + _recv_slice_sync(p,&a.tail,o) +} +proc _bcast_slice_shared(&a:_join,o) { + _bcast_slice_shared(&a.head,o) + _bcast_slice_shared(&a.tail,o) +} +proc _sync_messages(x:_join):_sync_messages(x.head,x.tail) +proc _not_zero(x)=if(x/=0=>1,0) +proc _crss(x)=1==map_reduce($_not_zero,$+,x) +// Add (anti) halo around tile +// Args: mshape / tile / displacement +// (mshape not used at the moment - there to cope with other topologies) +// Result: expanded tile +proc _get_halo(d:range(int),t:range(int),i:any_int)=low(t)+ii..high(t)+ii where ii=int(i) +proc _get_halo(d:range(int),t:strided_range(int),i:any_int)= low(t)+ii..high(t)+ii by step(t) where ii=int(i) +proc _get_halo(d:range(int),t:block_seq,i:any_int){ + return block_seq(low(t)+ii,high(t)+ii,step(t),width(t),0) where ii=int(i) +} +proc _get_halo(d:range(int),t:map_seq,i:any_int) { + var a=array(0,size(t)) + for j in a,k in t.array:j=k+i + return new map_seq { + array=a + } +} +proc _get_halo(d:range(int),t:range(int),i:range(any_int))=low(t)+int(low(i))..high(t)+int(high(i)) +proc _get_halo(d:range(int),t:strided_range(int),i:range(any_int)){ + var step=step(t) + var width=size(i) + if width>step { + step=1 + width=1 + } + return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0) +} +proc _get_halo(d:range(int),t:block_seq,i:range(any_int)){ + var step=step(t) + var width=size(i)+width(t)-1 + if width>step { + step=1 + width=1 + } + return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0) +} +proc _get_halo(d:range(int),t:map_seq,i:range(any_int)) { + var a=array(0,[0..size(t)*size(i)-1]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i)) + return _redim(a,shape(m)) +} +proc _get_halo(d:extent,j:grid,i:tuple(any_int or range(any_int)))= map($_get_halo,d,j,i) +proc _get_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))=_get_halo(d.1,t.1,i) +proc _get_halo(d,t,i:null)=t +proc _get_anti_halo(d:range(int),t:range(int),i:any_int)=low(t)-ii..high(t)-ii where ii=int(i) +proc _get_anti_halo(d:range(int),t:strided_range(int),i:any_int)= low(t)-ii..high(t)-ii by step(t) where ii=int(i) +proc _get_anti_halo(d:range(int),t:block_seq,i:any_int){ + return block_seq(low(t)-ii,high(t)-ii,step(t),width(t)) where ii=int(i) +} +proc _get_anti_halo(d:range(int),t:map_seq,i:any_int) { + var a=array(0,size(t)) + for j in a,k in t.array:j=k-i + return new map_seq { + array=a + } +} +proc _get_anti_halo(d:range(int),t:range(int),i:range(any_int))=low(t)-int(high(i))..high(t)-int(low(i)) +proc _get_anti_halo(d:range(int),t:strided_range(int),i:range(any_int)){ + var step=step(t) + var width=size(i) + if width>step { + step=1 + width=1 + } + return block_seq(low(t)-int(high(i)),high(t)-int(low(i)),step,width) +} +proc _get_anti_halo(d:range(int),t:block_seq,i:range(any_int)){ + var step=step(t) + var width=size(i)+width(t)-1 + if width>step { + step=1 + width=1 + } + return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width) +} +proc _get_anti_halo(d:range(int),t:map_seq,i:range(any_int)) { + var a=array(0,[0..size(t)*size(i)-1]) + var m=0 + _expand_aseq(&m,t.array,size(t.array),&a,-high(i),-low(i)) + return _redim(a,shape(m)) +} +proc _get_anti_halo(d:extent,j:grid, i:tuple(any_int or range(any_int)))= map($_get_anti_halo,d,j,i) +proc _get_anti_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))=_get_anti_halo(d.1,t.1,i) +proc _get_anti_halo(d,t,i:null)=t +proc _interior(t:range,n:range)=low(t)+max(0,-low(n))..high(t)-max(0,high(n)) +proc _interior(t:strided_range,n:range)=1..0 by 1 +proc _interior(tt:block_seq,n:range)=block_seq(low(t)+max(-low(n),0),high(t),width(t),width(t)-max(-low(n),0)-max(high(n),0),0)where t=middle_blocks(tt) +proc _get_chunk(t:range,n:range,l:'true)=low(t)..low(t)+min(-min(0,low(n))-1,size(t)-1) +proc _get_chunk(t:range,n:range,l:'false)=low(t)+max(size(t)-max(high(n),0),-min(low(n),-1))..high(t) +proc _get_chunk(t:range,n:range,l:_down)=low(t)+w..low(t)+w+w-1 where w=max(0,-low(n)) +proc _get_chunk(t:range,n:range,l:_up)=high(t)-w-w+1..high(t)-w where w=max(0,high(n)) +proc _get_chunk(tt:block_seq,n:range,l:'true)=if(low(n)<0=>block_seq(low(t),high(t),step(t),min(-low(n),width(t)),0),empty(t)) where t=middle_blocks(tt) +proc _get_chunk(tt:block_seq,n:range,l:'false)=if(high(n)>0=>block_seq(low(t)+max(0,width(t)-high(n)),high(t),step(t),min(width(t),high(n)),0),empty(t)) where t=middle_blocks(tt) +proc _get_chunk(t:grid_dim,n:range,l:_left or _right)=empty(t) +proc _get_chunk(t:block_seq,n:range,l:_left)=block_seq(low(b),high(b),1,1,0) where b=first_block(t) +proc _get_chunk(t:block_seq,n:range,l:_right)=block_seq(low(b),high(b),1,1,0) where b=last_block(t) +proc _chunk(t,n,r,e,l)=if(r>e=>_interior(t,n),rt,_get_chunk(t,n,l)) +proc _get_chunk(t:tuple1d,n,e,l)=[_chunk(t.1,n.1,1,e,l)] +proc _get_chunk(t:tuple2d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l)] +proc _get_chunk(t:tuple3d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l)] +proc _get_chunk(t:tuple4d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l)] +proc _get_chunk(t:tuple5d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l)] +proc _get_chunk(t:tuple6d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l),_chunk(t.6,n.6,6,e,l)] +proc _get_chunk(t:tuple7d,n,e,l)=[_chunk(t.1,n.1,1,e,l),_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l),_chunk(t.6,n.6,6,e,l),_chunk(t.7,n.7,7,e,l)] +proc chunks(t:tuple(range(any_int)),n:extent)=rank(t)*2+1 +proc chunks(t:tuple(range(any_int) or block_seq),n:extent)=rank(t)*4+1 +proc chunks(t:grid,n:extent)=2 +proc _cr(i,n):test "Index out of range in ""get_chunk"""=>i>=0 and i<=n +proc chunk(t:tuple(range(any_int)),n:extent,i:int) { + _cr(i,rank(t)*2) + var r=n + if i==0: r=map($_interior,t,n) elseif i&1==0: r=_get_chunk(t,n,(i+1)/2,'true) else: r=_get_chunk(t,n,(i+1)/2,'false) + return r +} + +type _left is unique +type _right is unique +type _up is unique +type _down is unique +proc chunk(t:tuple(range(any_int) or block_seq),n:extent,i:int) { + _cr(i,rank(t)*4) + var r=t + if i==0:r=map($_interior,t,n) else: switch (i-1)&3 { + case 0:r=_get_chunk(t,n,(i+3)/4,'true) + case 1:r=_get_chunk(t,n,(i+3)/4,'false) + case 2:r=_get_chunk(t,n,(i+3)/4,_left) + default:r=_get_chunk(t,n,(i+3)/4,_right) + } + return r +} +proc chunk(t:grid,n:extent,i:int) { + _cr(i,1) + var r=#t + if i==0:r=empty(#t) + return r +} +proc chunk(t:grid,n:extent,i:int,b:null)=chunk(t,n,i) +proc chunk(t:grid,n:extent,i:int,b:extent)=intersect(chunk(t,n,i),b) +proc inside_edge(t:tuple(range(any_int)),n:extent,i:int,low:fix bool)=_get_chunk(t,n,i,low) +proc outside_edge(t:tuple(range(any_int)),n:extent,i:int,low:fix bool)=_get_chunk(map($_exterior,t,n),n,i,low) +proc outside_edge_wrapped(t:tuple(range(any_int)),n:extent,i:int,low:'true)=_get_chunk(map($_exterior,t,n),n,i,_up) +proc outside_edge_wrapped(t:tuple(range(any_int)),n:extent,i:int,low:'false)=_get_chunk(map($_exterior,t,n),n,i,_down) +proc _exterior(t:range(int),n:range(int))=low(t)+min(low(n),0)..high(t)+max(high(n),0) +proc _get_external_chunk(t:tuple(range(any_int)),n:extent,i:int) { + var r=t + tt=map($_exterior,t,n) + if i==0: r=#tt elseif i&1==0: r=_get_chunk(tt,n,(i+1)/2,_up) else: r=_get_chunk(tt,n,(i+1)/2,_down) + return r +} + +// ************************************************************* +// nbr% and nbhd% intrinsics +// ************************************************************* +type disp_index is any_int,tuple(any_int) +type disp_sub is disp_index,tuple(any_int or range(any_int)) +// *** Default *** +proc nbr%(x:chan,t:shared disp_index,v:shared){ + test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) + j=displace(region._mshape,here,t) + var y=v + if contains(region._mshape,j) { + y=x![j] + } + return y +} + +proc nbhd%(x:chan,t:shared disp_sub,v:shared) { + test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) + var a=array(v,#t) + foreach invar i in t { + j=displace(region._mshape,here,i) + if j in region._mshape { + a[here]=x![j] + } + } + return a +} + +// *** Blocked distributions *** +proc nbr%(region:dshape(,blocked_distr),x:chan,t:shared disp_index,v:shared) { + test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) + var j=displace(region._mshape,here,t) + a,ad=tile_with_halo%(x,t,v) + return a[ad#j] +} + +proc nbhd%(region:dshape(,blocked_distr),x:chan,t:shared disp_sub,v:shared){ + test "Default and chan values must have same type in ""nbr"""=>same_type(x,v) + a=displace(region._mshape,here,t) + y,yd=tile_with_halo%(x,t,v) + return y[yd#a] +} + +proc tile_with_halo%(x,t,v) { + return a,d where a,d=_local_tile_with_halo(region,PM__local(x),t,v) +} +// Return local tile with halo cells +proc _local_tile_with_halo(region,x,t,v) { + this_tile_x=_get_halo(region._mshape,region._tile,t) + var a=array(v,#this_tile_x) + foreach i in nodes_for_grid(region.dist,this_tile_x) { + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,t) + var p=index(dims(region.dist),i) + if contains(#region.dist,i) and p/=_this_node() { + _recv_slice(p,&a,overlap(this_tile_x,other_tile)) + } + } + foreach i in nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) { + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,t) + p=index(dims(region.dist),i) + if contains(#region.dist,i) and p/=_this_node() { + _send_slice(p,x,overlap(region._tile,other_tile_x)) + } + } + o,oo=overlap(this_tile_x,region._tile) + a[o]=x[oo] + _sync_messages(a,x) + return a,this_tile_x +} + +proc _local_tile_with_halo(region,x:_comp,t,v) { + this_tile_x=_get_halo(region._mshape,region._tile,t) + var a=array(v,#this_tile_x) + foreach i in nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) { + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,t) + p=index(dims(region.dist),i) + if contains(#region.dist,i) and p/=_this_node() { + _send_slice(p,x,overlap(region._tile,other_tile_x)) + } + } + o,oo=overlap(this_tile_x,region._tile) + a[o]=x[oo] + foreach i in nodes_for_grid(region.dist,this_tile_x) { + other_tile=element(region.dist,i) + other_tile_x=_get_halo(region._mshape,other_tile,t) + p=index(dims(region.dist),i) + if contains(dims(region.dist),i) and p/=_this_node() { + _recv_slice_sync(p,&a,overlap(this_tile_x,other_tile)) + } + } + _sync_messages(a,x) + return a,this_tile_x +} + +// Displace x by y within mshape d +proc displace(d:range(int),x:int,y:any_int)=x+int(y) +proc displace(d:range(int),x:int,y:range(any_int))=x+int(y._lo)..x+int(y._hi) +proc displace(d:extent1d,x:tuple1d(int),y:range(any_int) or any_int)=displace(d.1,x.1,y) +proc displace(d:extent,x:tuple(int),y:tuple(range(any_int) or any_int))=map($displace,d,x,y) +// ************************************************ +// TOPOLOGIES +// ************************************************ +proc topology(tp:null,dis,d:tuple,l:int)=cart_topo(int(d),dis,l) +proc topology(tp,dis,d,l:int)=tp +PM__intrinsic<> _get_dims(int,int)->(int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int)->(int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int)->(int,int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int,int)->(int,int,int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int,int,int)->(int,int,int,int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int,int,int,int)->(int,int,int,int,int,int) : "get_dims" +PM__intrinsic<> _get_dims(int,int,int,int,int,int,int,int)->(int,int,int,int,int,int,int) : "get_dims" +proc _zd(x,y)=if(x==1=>1,nodes_needed(y,x)) +proc cart_topo(dd:tuple,t:null,n:int)=cart_topo(dd,spread(VBLOCK,dd),n) +proc cart_topo(dd:tuple,t,n:int)=cart_topo(dd,spread(t,dd),n) +proc cart_topo(d:tuple1d,t:tuple1d,n:int)=tuple(_get_dims(n,_zd(d.1,t.1))) +proc cart_topo(d:tuple2d,t:tuple2d,n:int)=tuple(b,a) where a,b=_get_dims(n,_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple3d,t:tuple3d,n:int)=tuple(c,b,a) where a,b,c=_get_dims(n,_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple4d,t:tuple4d,n:int)=tuple(dd,c,b,a) where a,b,c,dd=_get_dims(n,_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple5d,t:tuple5d,n:int)=tuple(e,dd,c,b,a) where a,b,c,dd,e=_get_dims(n,_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple6d,t:tuple6d,n:int)=tuple(f,e,dd,c,b,a) where a,b,c,dd,e,f=_get_dims(n,_zd(d.6,t.6),_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +proc cart_topo(d:tuple7d,t:tuple7d,n:int)=tuple(g,f,e,dd,c,b,a) where a,b,c,dd,e,f,g=_get_dims(n,_zd(d.7,t.7),_zd(d.6,t.6),_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1)) +// ************************************************ +// DISTRIBUTIONS +// ************************************************ +type distr_dim is no_distr,direct_distr,block_distr,vblock_distr,cyclic_distr,block_cyclic_distr +type distr:iterable is null,blocked_distr,distr_dim,tuple(distr_dim),sliced_distr +type blocked_distr is block_distr,vblock_distr,tuple(block_distr or vblock_distr) +type distr_template is null,distr_template_dim,tuple(distr_template_dim),... +type distr_template_dim is null,vblock_template,direct_template,block_template,cyclic_template,block_cyclic_template,... +// Null distribution (mirroring) +proc distribute(dis:null,d:int,t:int,p:int)=no_distr(d,t,p) +type no_distr is rec {_hi:int,_p:int,_pr:int} +proc nodes_needed(d:null,g:int)=1 +proc no_distr(g:int,d:int,p:int)=new no_distr { + _hi=int(g),_p=int(d),_pr=p +} +proc #(b:no_distr)=shape([0..b._p-1]) +proc _shp(b:no_distr)=0..b._p-1 +proc dims(b:no_distr)=[b._p] +proc size(b:no_distr)=b._p +proc element(b:no_distr,i:int)=0..b._hi-1 +proc tile_size(b:no_distr,i:int)=b._hi +proc empty(b:no_distr)=1..0 +proc nodes_for_grid(b:no_distr,g:seq(int))=b._pr..b._pr +proc node_for(b:no_distr,j:int)=b._pr +proc index(b:no_distr,j:int,p:int)=j +proc node_nhd(b:no_distr,p:int,d:range(int))=p..p +proc node_co_nhd(b:no_distr,p:int,d:range(int))=p..p +// Direct distribution (1-1 map to processor topology) +type direct_distr is rec {_p:int} +type direct_template is unique{DIRECT} +proc distribute(dis:direct_template,d:int,t:int,p:int)=direct_distr(d) +proc nodes_needed(d:direct_template,g:int)=g +proc direct_distr(d:int)=new direct_distr { + _p=int(d) +} +proc #(b:direct_distr)=shape([0..b._p-1]) +proc _shp(b:direct_distr)=0..b._p-1 +proc dims(b:direct_distr)=[b._p] +proc size(b:direct_distr)=b._p +proc element(b:direct_distr,i:int)='0..'0 +proc tile_size(b:direct_distr,i:int)='1 +proc empty(b:direct_distr)='1..'0 +proc nodes_for_grid(b:direct_distr,g:seq(int))=int(g) +proc node_for(b:direct_distr,j:int)=j +proc index(b:direct_distr,j:int,p:int)='0 +proc node_nhd(b:direct_distr,p:int,d:int or range(int))=d+p +proc node_co_nhd(b:direct_distr,p:int,d:int or range(int))=-low(d)+p..-high(d)+p by -1 +// Variable block distribution +type vblock_distr is rec {_hi:int,_p:int} +type vblock_template is unique{VBLOCK} +proc distribute(dis:vblock_template,d:int,t:int,p:int)=vblock_distr(d,t) +proc nodes_needed(d:vblock_template,g:int)=0 +proc vblock_distr(g:int,d:int)=new vblock_distr { + _hi=int(g),_p=int(d) +} +proc #(b:vblock_distr)=shape([0..b._p-1]) +proc _shp(b:vblock_distr)=0..b._p-1 +proc dims(b:vblock_distr)=[b._p] +proc size(b:vblock_distr)=b._p +proc element(b:vblock_distr,i:int)=start..finish where finish=(ii+1)*b._hi/b._p-1 where start=ii*b._hi/b._p where ii=int(i) +proc tile_size(b:vblock_distr,i:int)=finish-start+1 where finish=(ii+1)*b._hi/b._p-1 where start=ii*b._hi/b._p where ii=int(i) +proc empty(b:vblock_distr)=1..0 +proc nodes_for_grid(b:vblock_distr,g:seq(int))=lo1..hi1 where lo1=_rdiv(b._p*(low(g)+1)-1,b._hi), hi1=_rdiv(b._p*(high(g)+1)-1,b._hi) +proc node_for(b:vblock_distr,j:int)=p where p=_rdiv(b._p*(j+1)-1,b._hi) +proc index(b:vblock_distr,j:int,p:int)=i where i=jj-s1 where s1=p*b._hi/b._p where jj=int(j) +proc _rdiv(x,y)=if(y<0=>if(x<0=>x/y,(y-x+1)/y),x>0=>x/y,(x-y+1)/y) +proc node_nhd(b:vblock_distr,p:int,d:range(int))=p+(low(d)-bk+1)/bk..p+(high(d)+bk-1)/bk where bk=b._hi/b._p +// fixed block distribution +type block_distr is rec {_b:int,_s:int,_p:int} +type _block_template is rec{block:int} +type _block_template_default is unique{BLOCK} +type block_template is _block_template_default,_block_template +proc BLOCK(block:int)=new _block_template { + block=block +} +proc distribute(dis:_block_template,d:int,t:int,p:int)=block_distr(d,t,dis.block) +proc distribute(dis:block_template,d:int,t:int,p:int)=block_distr(d,t) +proc nodes_needed(d:_block_template,g:int)=(g+d.block)/d.block +proc nodes_needed(d:block_template,g:int)=0 +proc block_distr(s:int,p:int)=new block_distr { +_b=b,_s=s,_p=p} where b=(s+p-1)/p +proc block_distr(s:int,t:int,b:int)=new block_distr { +_b=b,_s=s,_p=p} where p=(s+b-1)/b +proc #(b:block_distr)=shape([0..b._p-1]) +proc _shp(b:block_distr)=0..b._p-1 +proc dims(b:block_distr)=[b._p] +proc size(b:block_distr)=b._p +proc element(b:block_distr,i:int)=start..finish where finish=min(b._s-1,(ii+1)*b._b-1) where start=ii*b._b where ii=int(i) +proc tile_size(b:block_distr,i:int)=finish-start+1 where finish=min(b._s-1,(ii+1)*b._b-1) where start=ii*b._b where ii=int(i) +proc empty(b:block_distr)=1..0 +proc nodes_for_grid(b:block_distr,g:seq(int))=lo1..hi1 where lo1=_rdiv(int(low(g)),b._b), hi1=_rdiv(int(high(g)),b._b) +proc node_for(b:block_distr,j:int)=p where p=_rdiv(jj,b._b) where jj=int(j) +proc index(b:block_distr,j:int,p:int)=i where i=jj-s1 where s1=p*b._b where jj=int(j) +proc node_nhd(b:block_distr,p:int,d:range(int))=p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b +// Cyclic distribution +type cyclic_distr is rec {_hi:int,_p:int} +type cyclic_template is unique{CYCLIC} +proc distribute(dis:cyclic_template,d:int,t:int,p:int)=cyclic_distr(d,t) +proc nodes_needed(d:cyclic_template,g:int)=0 +proc cyclic_distr(g:int,d:int)=new cyclic_distr { + _hi=int(g),_p=int(d) +} +proc #(b:cyclic_distr)=shape([0..b._p-1]) +proc _shp(b:cyclic_distr)=0..b._p-1 +proc dims(b:cyclic_distr)=[b._p] +proc size(b:cyclic_distr)=b._p +proc element(b:cyclic_distr,i:int)= int(i)..b._hi-1 by b._p +proc tile_size(b:cyclic_distr,i:int)=(b._hi-1-int(i))/b._p+1 +proc empty(b:cyclic_distr)=1..0 by 1 +proc nodes_for_grid(b:cyclic_distr,g:seq(int))=cyclic_range(lo,high,p) where high=if(hi-lo>=p=>lo+p-1,hi+if(hi>lo=>0,p)) where lo=low(g) mod p,hi=high(g) mod p where p=b._p +proc node_for(b:cyclic_distr,j:any_int)=p where p=int(j) mod b._p +proc index(b:cyclic_distr,j:int,p:int)=int(j)/b._p +proc node_nhd(b:cyclic_distr,p:int,d:range(int))=cyclic_range(p+low(d),p+high(d),b._p) +// Block cyclic distribution +type block_cyclic_distr is rec {_hi:int,_p:int,_b:int,_s:int} +type block_cyclic_template is rec {block:int} +proc BLOCK_CYCLIC(block:int)=new block_cyclic_template{ + block=block +} +proc distribute(dis:block_cyclic_template,d:int,t:int,p:int)=block_cyclic_distr(d,t,dis.block) +proc nodes_needed(d:block_cyclic_template,g:int)=0 +proc block_cyclic_distr(g:int,p:int,b:int)=new block_cyclic_distr { +_hi=int(g),_p=int(pp),_b=bb, _s=s} where s=pp*bb where bb=if(pp==1=>g,b) where pp=min((g+b-1)/b,p) +proc #(b:block_cyclic_distr)=shape([0..b._p-1]) +proc _shp(b:block_cyclic_distr)=0..b._p-1 +proc dims(b:block_cyclic_distr)=[b._p] +proc size(b:block_cyclic_distr)=b._p +proc element(b:block_cyclic_distr,i:int)= block_seq(s,b._hi-1,b._s,b._b,0) where s=ii*b._b where ii=int(i) +proc tile_size(b:block_cyclic_distr,i:int)=nc*b._b+max(0,min(b._b,df-nc*b._s)) where nc=df/b._s where df=b._hi-s where s=ii*b._b where ii=int(i) +proc empty(b:block_cyclic_distr)=block_seq(1,0,1,1,0) +proc nodes_for_grid(b:block_cyclic_distr,g:grid_dim)=if(hi-lo+1cyclic_range(lo,hi,p),cyclic_range(0,p-1,p)) where lo=low(g)/b._b,hi=high(g)/b._b where p=b._p +proc nodes_for_grid(b:block_cyclic_distr,g:strided_range){ + var r=0..0 + if b._s==step(g) { + r=nodes_for_grid(b,low(g)..low(g))} else { + r=nodes_for_grid(b,low(g)..high(g)) + } + return r +} + +proc nodes_for_grid(b:block_cyclic_distr,g:block_seq){ + var r=cyclic_range(0,0,1) + if b._s==step(g) { + r=nodes_for_grid(b,low(g)..low(g)+width(g)-1)} else { + r=nodes_for_grid(b,low(g)..high(g)) + } + return r +} + +proc node_for(b:block_cyclic_distr,j:int)=p where p=_rdiv(jj,b._b) mod b._p where jj=int(j) +proc index(b:block_cyclic_distr,j:int,p:int)=i where i=r+b._b*(s-p) where r=j-s*b._s where s=_rdiv(j,b._s) +proc node_nhd(b:block_cyclic_distr,p:int,d:range(int))=p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b +proc nodes_for_grid(b,g:single_point)=nodes_for_grid(b,g._t..g._t) +// Tuple of distributions +proc distribute(dis:tuple(distr_template_dim),d:tuple(int),t:tuple(int))=map($distribute,dis,d,t,p) where p=index2point(_this_node(),t) +proc distribute(dis:distr_template_dim,d:tuple(int),t:tuple(int))=map($distribute,spread(dis,d),d,t,p) where p=index2point(_this_node(),t) +proc distribute(dis:null,d:tuple(int),t:tuple(int))=distribute(VBLOCK,d,t) +proc nodes_needed(b:tuple(distr_template_dim),g:tuple(int))=map($nodes_needed,b,g) +proc nodes_needed(b:distr_template_dim,g:tuple(int))=map($nodes_needed,spread(b,g),g) +proc node_for(b:tuple(distr_dim),j:tuple(int))=map($node_for,b,j) +proc #(b:tuple(distr_dim))=shape(map($_shp,b)) +proc dims(b:tuple(distr_dim))=map($size,b) +proc element(b:tuple(distr_dim),i:tuple(int))=map($element,b,i) +proc element(b:tuple(distr_dim),i:int)=element(b,index2point(i,dims(b))) +proc tile_size(b:tuple(distr_dim),i:tuple(int))=map($tile_size,b,i) +proc empty(b:tuple(distr_dim))=map($empty,b) +proc nodes_for_grid(b:tuple(distr_dim),g:grid_slice)=map($nodes_for_grid,b,g) +proc node_num_for(b:tuple(distr_dim),j:tuple(int))=index(dims(b),map($node_for,b,j)) +proc index(b:tuple(distr_dim),j:tuple(int),p:tuple(int))=index(tile_size(b,p),map($index,b,j,p)) +proc node_and_index(b:tuple(distr_dim),j:tuple(int))=index(dims(b),p),i where i=index(tile_size(b,p),map($index,b,j,p)) where p=map($node_for,b,j) +proc node_and_index(b:distr_dim,j:int)=p,i where i=index(b,j,p) where p=node_for(b,j) +proc node_nhd(b:tuple,p:tuple,d:tuple)=map($node_nhd,b,p,d) +proc node_co_nhd(b:tuple,p:tuple,d:tuple)=map($node_co_nhd,b,p,d) +// Slice of a tuple of distributions +type sliced_distr(t,s) is rec{_t:t,_s:s} +proc sliced_distr(t:tuple(distr_dim),s:tuple(seq(int) or single_point(int)))=new sliced_distr{ + _t=t,_s=s +} +proc node_for(t:sliced_distr,j:tuple(int))=node_for(t._t,t._s[j]) +proc #(t:sliced_distr)=#t._t +proc dims(t:sliced_distr)=dims(t._t) +proc element(t:sliced_distr,i:tuple(int) or int)=overlap(t._s,element(t._t,i)) +proc tile_size(t:sliced_distr,i:tuple(int) or int)=dims(element(t,i)) +proc empty(t:sliced_distr)=new sliced_distr{ + _t=empty(t._t),_s=t._s +} +proc nodes_for_grid(t:sliced_distr,g:grid)=nodes_for_grid(t._t,t._s[g]) +proc node_num_for(t:sliced_distr,j:tuple(int))=node_num_for(t._t,t._s[j]) +proc index(t:sliced_distr,j:tuple(int),p:tuple(int))=index(tile_size(t,p),element(t,p)#j) +proc node_and_index(t:sliced_distr,j:int)=p,i where i=index(t,j,p) where p=node_for(t,j) +proc node_nhd(t:sliced_distr,p:tuple,d:tuple)=node_nhd(t._t,p,_stpmult(d,t._s)) +proc node_co_nhd(t:sliced_distr,p:tuple,d:tuple)=node_co_nhd(t._t,p,_stpmult(d,t._s)) +proc _stpmult(d:tuple,s:tuple)=map($_stpmult,d,s) +proc _stpmult(d:range,s:range)=d +proc _stpmult(d:range,s:strided_range)=if(st>0=>st*low(d)..st*high(d),st*high(d)..st*low(d)) where st=step(s) +// ***************************************** +// SUPPORT FOR PARALLEL STATEMENTS +// ***************************************** +// Get and set elements in "for" +proc PM__getelem(x:grid_slice_dim or cyclic_range,y)=element(x,y) +proc PM__getelem(x:grid_slice or iterable_grid,y)=element(x,y) +proc PM__getelem(a:any^mshape,t)=_get_aelem(a,index(dims(a),t)) +proc PM__getelem(a:array_slice(any^any,),y)=element(a,y) +proc PM__getelem(x:array_template,y)=x._a +proc PM__getelem(a:any^dshape,t)=element(a,(#a)[t]) +proc PM__setelem(&x,v,y) { + _set_elem(&x,v,(#x)[y]) +} +proc PM__setelem(&a:any^mshape,v,t:index){ + PM__setaelem(&a,index(dims(a),t),v) +} + +proc PM__setelem(&a:any^dshape,v,t:index) { + PM__setaelem(&a,i,v) check p==_this_node() where p,i=node_and_index((#a).dist,_tup(t)) +} + +proc PM__setelem(&a:array_slice(any^any,),v,t:index) { + _set_elem(&a._a,v,a._s[t]) +} + +proc PM__get_elem%(x,i,h)=PM__getelem(x,h) +proc PM__set_elem%(&x:invar,v:complete,i,h){ + PM__setelem(&x,v,h <>) + _assemble%(&x,region) +} +proc PM__get_elem%(x:shared any^dshape,i,h)=element(PM__local(x),i) +proc PM__set_elem%(&x:invar any^dshape,v:complete,i,h) { + _set_elem(&^(PM__local(^(&x))),v,i <>) +} +proc PM__get_elem%(x:shared array_slice(any^dshape),j,h)=_get_aelem(x._a,i) check p==_this_node() where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) +proc PM__set_elem%(&x:invar array_slice(any^dshape),v:complete,j,h){ + PM__setaelem(&x._a,i,v <>) check p==_this_node() where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) +} + +proc _assemble%(&a:invar any^mshape,xregion:invar mshape) { +} +proc _assemble%(&a:invar array_slice(any^shape,),xregion:invar mshape) { +} +proc _assemble%(&a:invar any^mshape,xregion:invar) shared <> { + dist=xregion.dist + foreach p in #(dist) { + tile=dist[p] + i=index(dims(dist),p) + if i==_this_node() { + forall j in tile { + var k=PM__getelem(a,j) + PM__broadcast(&k,i) + } + } else { + forall j in tile { + var k=_arb(a) + PM__broadcast(&k,i) + PM__setelem(&a,k,j <>) + } + } + } +} + +proc _assemble%(&a:invar array_slice(any^shape,),xregion:invar) shared <> { + dist=xregion.dist + foreach p in #(dist) { + tile=intersect((#(a._a))#a._s,dist[p]) + i=index(dims(dist),p) + if i==_this_node() { + forall j in tile { + var k=PM__getelem(a._a,j) + PM__broadcast(&k,i) + } + } else { + forall j in tile { + var k=_arb(a._a) + PM__broadcast(&k,i) + PM__setelem(&a._a,k,j <>) + } + } + } +} + +// Support for % procs +proc PM__get_tilesz(d)=d._tile,d._size +proc PM__get_tilesz(d:mshape)=d,size(d) +// Support for ! operator +PM__if_compiling +proc PM__makearray%(x:chan) complete <>=_makearray(x,region,size(region)) +proc PM__makearray%(x:priv)=_makearray(x,region,size(region)):test "Can only apply ""!"" to a ""chan"" " => 'false +proc PM__makearray%(x:invar)=_makearray(x,region,size(region)):test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => 'false +PM__intrinsic<> _makearray(x:any,y:any,z:any)->(PM__invar_dim x,y) : "make_array" +PM__else +proc PM__makearray%(x:chan) complete <>=_makearray(x,region) +proc PM__makearray%(x:priv)=_makearray(x,region):test "Can only apply ""!"" to a ""chan"" " => 'false +proc PM__makearray%(x:invar)=_makearray(x,region):test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => 'false +PM__intrinsic<> _makearray(x:any,y:any)->(PM__dim x,y) : "make_array" +PM__endif +// active%() intrinsic +proc active%(x)=_masked%(^(x,coherent),^(^??,coherent) <>) +proc _masked%(x) complete <>=masked(x) +proc active%()=^(^??,coherent) +PM__intrinsic PM__active()->(bool) : "active" +// Imports and exports +PM__intrinsic _import_val(x:any)->(=x) : "import_val" +PM__intrinsic PM__importshrd(x:any)->(=x) : "import_val" +PM__intrinsic<> PM__importvarg(x:any)->(=x) : "import_varg" +PM__intrinsic _import_scalar(x:any)->(invar x) : "import_scalar" +proc PM__import_val(x) { + PM__checkimp(x) + return _import_val(x) +} +proc PM__impscalar(x) { + PM__checkimp(x) + return _import_scalar(x) +} +proc PM__import_val(x:^*(,,,,)) { + test "Compiler internal error:importing reference" => 'false + return x +} +proc PM__impscalar(x:^*(,,,,)) { + test "Compiler internal error:importing reference" => 'false + return x +} +proc PM__checkimp(x,arg...) { + PM__checkimp(x) + PM__checkimp(arg...) +} +proc PM__checkimp(x) { +} +proc PM__checkimp(x:contains(PM__distr_tag)) { + test "Cannot import a distributed value into a nested parallel scope" => 'false +} +type schedule(subregion,blocking) is rec{_subregion:subregion,_subtile,_blocking:blocking} +proc subregion(schedule:schedule)=schedule._subregion +proc subregion(schedule:null)=null +proc subtile(schedule:schedule)=schedule._subtile +// Over statements +proc PM__over%(schedule:null,x:invar,block:invar) shared <>=new schedule{ + _subregion=x,_subtile=overlap(region._tile,x),_blocking=_blocking(block,region) +} +proc PM__over%(x:invar,block:invar) shared <>=new schedule{ +_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}where s=intersect(x,schedule._subregion) +proc PM__make_over%(schedule:null,x:invar tuple(subs_dim except stretch_dim),block:invar) shared <>=new schedule{ +_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}check "Value"++s++" in ""over"" out of bounds: "++region._extent=>region._extent inc s where s=fill_in(region._extent,x,null) +proc PM__make_over%(x:invar tuple(subs_dim except stretch_dim),block:invar) shared <>=new schedule{ +_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}where s=intersect(map($norm,fill_in(region._extent,x,'true)),schedule._subregion) +proc PM__make_over%(x:invar,block)=x check "Expression in an ""over"" statement must be a subscript tuple"=>'false +proc PM__make_over%(x,block)=x check "Expression in an ""over"" statement must be ""invar"""=>'false +proc _blocking(b:tuple(any_int),region)=int(b) { + test "Blocking factor must have same rank as current region"=> rank(b)==rank(extent(region)) +} + +proc _blocking(b,region)=null { + test "Blocking factor must be a tuple of integers"=>'false +} +proc _blocking(b:null,region)=null +PM__if_compiling +proc PM__do_over(x:null,region)=x +proc PM__do_over(x:schedule,region)=_st(map_apply($_do_elem,$_st,x._subtile),_ldims(region),x._blocking) +proc _do_elem(x:range(int))=_st(low(x),high(x)) +proc _do_elem(x:strided_range(int))=_st(low(x),high(x),step(x)) +proc _do_elem(x:block_seq)=_st(low(x),high(x),step(x),width(x),align(x)) +proc _do_elem(x:map_seq)=_st(x.array,size(x.array),null,null) +proc _do_elem(x:single_point)=_st(x._t) +proc PM__nested_loop(x:null){ +} +PM__intrinsic PM__nested_loop(any): "nested_loop" +proc _ldims(x:mshape)=map_apply($size,$_st,x._extent) +proc _ldims(x:dshape)=map_apply($size,$_st,x._tile) +PM__else +proc PM__do_over%(x:null)=true +proc PM__do_over%(x:invar schedule(tuple(seq or block_seq)))=here in x._subregion +proc PM__do_over%(x:invar schedule(grid))=PM__do_over%(schedule._subtile) +proc PM__do_over%(x:invar grid) complete <>{ + chan var t=false + _in%(x,&^(PM__local(^(&t!))) <>) + return t +} + +proc PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x +proc _in%(x:invar,&t:invar) shared <>{ + forall i in x { + sync t[i]=true + } +} +PM__endif +// Parallel processing inquiry +PM__intrinsic _sys_node()->(int) : "sys_node" +PM__intrinsic sys_nnode()->(int) : "sys_nnode" +PM__intrinsic _this_node()->(int) : "this_node"(1) +PM__intrinsic this_node%(r:any,s:any,h:any)->(int) : "this_node"(2) +PM__intrinsic this_nnode()->(int) : "this_nnode" +PM__intrinsic _shrd_node()->(int) : "shared_node" +PM__intrinsic shrd_nnode()->(int) : "shared_nnode" +PM__intrinsic _root_node()->(int) : "root_node" +PM__intrinsic is_shrd()->(bool) : "is_shared" +PM__intrinsic is_shrd(any)->(bool) : "is_shared" +PM__intrinsic is_par()->(bool) : "is_par" +proc _head_node()=_shrd_node()==0 +// Parallel system nested contexts +PM__intrinsic<> _push_node_grid(arg...:any): "push_node_grid" +proc _push_node(d:int,t:int){ + _push_node_grid(false,t) +} +proc _push_node(d:tuple1d,t:tuple1d,e:tuple1d) { + _push_node_grid(is_cyclic(e.1),t.1) +} + +proc _push_node(d:tuple2d,t:tuple2d,e:tuple2d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),t.1,t.2) +} + +proc _push_node(d:tuple3d,t:tuple3d,e:tuple3d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),t.1,t.2,t.3) +} + +proc _push_node(d:tuple4d,t:tuple4d,e:tuple4d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),t.1,t.2,t.3,t.4) +} + +proc _push_node(d:tuple5d,t:tuple5d,e:tuple5d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),is_cyclic(e.5),t.1,t.2,t.3,t.4,t.5) +} + +proc _push_node(d:tuple6d,t:tuple6d,e:tuple6d) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),t.1,t.2,t.3,t.4,t.5,t.6) +} + +proc _push_node(d:tuple7d,t:tuple7d,e:tuple7) { + _push_node_grid(is_cyclic(e.1),is_cyclic(e.2),is_cyclic(e.3),is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),is_cyclic(e.7),t.1,t.2,t.3,t.4,t.5,t.6,t.7) +} + +PM__intrinsic<> _push_node_split(int): "push_node_split" +PM__intrinsic _push_node_conc(): "push_node_conc" +proc PM__pop_node(x:mshape) { +} +PM__intrinsic PM__pop_node(x:shape): "pop_node" +PM__intrinsic PM__pop_conc(bool): "pop_node_conc" +PM__intrinsic<> _push_node_dist(): "push_node_distr" +proc _lvl()=1 +// ************************************************ +// PROCESSOR ALLOCATION +// ************************************************ +proc PM__partition(pp,d:dshape) { + _push_node_dist() + return dd._tile,dd,null where dd=new dshape { + _mshape=#d._mshape,dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level + } +} +proc PM__partition(pp,d:dshape,distr:null,topo:null,simplify:null,work:null,sched,block) { + _push_node_dist() + return dd._tile,dd,_block_schedule(block,dd) where dd=new dshape { + _mshape=#d._mshape,dist=d.dist, _tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level + } +} + +proc PM__partition(pp,d:dshape,distr,topo,simplify,work,sched,block) { + test "Cannot have attributes in ""for""statement over distributed value" => 'false + return dd._tile,dd,null where dd=new dshape { + _mshape=##d,dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,_level=d._level + } +} +proc PM__partition(pp,d:mshape)=tile,shape,sched where tile,shape,sched= PM__partition(pp,d,null,null,null,null,null,null) +proc PM__partition(pp,mshape:mshape,distr,topo,simplify,work,sched,block) { + d=dims(mshape) + topol=topology(topo,distr,d,min(max(1,size(d)),shrd_nnode())) + var p=_shrd_node() + dist=distribute(distr,d,topol) + s=size(#(dist)) + np=shrd_nnode() + test "requested topology "++#dist++" larger than available processors: "++s++">"++np=>s<=np + if s=s { + p=workshare(work,mshape,dist,s,p-s,shrd_nnode()-s) + } + _push_node_split(p) } else { + _push_node_dist() + } + elem=element(dist,p) + elemsz=#elem + dd=new dshape { + _mshape=#mshape,dist=dist,_tile=elem,_tilesz=elemsz, _size=size(elemsz),_level=_lvl() + } + return dd._tile,dd,_block_schedule(block,dd) +} + +proc PM__partition(pp:null,d:mshape,distr,topo,simplify,work,sched,block)=#d._extent,#d,_block_schedule(block,#d) +proc PM__partition(pp:null,d:dshape,distr,topo,simplify,work,sched,block)=#d._extent,#d._mshape,_block_schedule(block,#d._mshape) +proc _block_schedule(block:null,region)=null +proc _block_schedule(block,region)=new schedule{ + _subregion=region,_subtile=region._tile,_blocking=_blocking(block,region) +} +proc workshare(work:null,d,dist,nnode:int,snode:int,nsnode:int)=nnode*(2*snode+1)/(2*nsnode) +proc workshare(work:array(int),d,dist,nnode:int,snode:int,nsnode:int) { + test "work array does not conform to mshape"=>conform(#work,#d) + var wk=work + return _wshare(wk,nnode,snode,nsnode) +} + +PM__intrinsic _wshare(int^any,int,int,int)->(int) : "wshare" +// ************************************************************* +// I/O OPERATIONS +// ************************************************************* +// Built-in operators +PM__intrinsic<> _open_file(string,bool,bool,bool,bool,bool,bool,bool)->(sint,sint) : "open_file" +PM__intrinsic<> _close_file(sint)->(sint) : "close_file" +PM__intrinsic<> _seek_file(sint,lint)->(sint) : "seek_file" +PM__intrinsic<> _read_file(sint,&any)->(sint) : "read_file" +PM__intrinsic<> _write_file(sint,any)->(sint) : "write_file" +PM__intrinsic<> _read_file_array(sint,&any,int)->(sint) : "read_file_array" +PM__intrinsic<> _write_file_array(sint,any,int)->(sint) : "write_file_array" +PM__intrinsic<> _read_file_tile%(any,any,any,sint,&any,int,int)->(sint) : "read_file_tile" +PM__intrinsic<> _write_file_tile%(any,any,any,sint,any,int,int)->(sint) : "write_file_tile" +PM__intrinsic<> _io_error_string(sint)->(string) : "io_error_string" +// IO/related types +type io_type is num,bool +type filesystem is rec{_tag:PM__distr_tag} +type file is struct {_f:sint,_tag:PM__distr_tag} +type io_error is rec {_errno:sint,use _iserr:bool} +proc PM__filesys()=new filesystem{ +} +// Basic operations + +// @@ with no keys... now, need to pass through keywords + +proc open(&filesystem:filesystem,name,append=false,create=false,temp=false,excl=false,read=false,write=false,seq=false)=new file { + _f=f +},_make_file_error(err) where f,err=_open_file(name,append,create,temp,excl,read,write,seq) +proc _make_file_error(x:sint)=new io_error { + _errno=x,_iserr=x/=0 +} +proc close(&f:file){ + err=_close_file(f._f) + return _make_file_error(err) +} +proc seek(&f:file,j:lint){ + err=_seek_file(f._f,j) + return _make_file_error(err) +} +proc read(&f:file,&x:io_type){ + err=_read_file(f._f,&x) + return _make_file_error(err) +} +proc write(&f:file,x:io_type){ + err=_write_file(f._f,x) + return _make_file_error(err) +} +// Array I/O +proc read(&f:file,&x:io_type^mshape){ + err=_read_file_array(f._f,&x,size(x)) + return _make_file_error(err) +} +proc write(&f:file,x:io_type^mshape){ + err=_write_file_array(f._f,x,size(x)) + return _make_file_error(err) +} +proc read(&f:file,&x:io_type^dshape) { + var err=_make_file_error(0's) + for i in x:err=read%(&f,&i) + return err +} +proc write(&f:file,x:io_type^dshape) { + var err=_make_file_error(0's) + for i in x:err=write%(&f,i) +} +// Distributed I/O +proc partition%(f:filesystem)=f:test "Partition not yet implemented"=>'false +proc read%(&f:shared file,&x:complete io_type){ + err=_read_file_tile%(f._f,&x,index(dims(region._mshape),here),size(region._mshape)) + return _make_file_error(err) +} +proc write%(&f:shared file,x:complete io_type){ + err=_write_file_tile%(f._f,x,index(dims(region._mshape),here),size(region._mshape)) + return _make_file_error(err) +} +// Error trapping versions of I/O routines +proc string(error:io_error)=_io_error_string(error._errno) +proc open(&f:filesystem,name:string) { + file,error=open(&f,name) + test "Error opening file """++name++""": "++error=>not(error) + return file +} + +proc close(&f:file) { + error=close(&f) + test "Error closing file:"++error=>not(error) +} +proc read(&f:file,&x) { + error=read(&f,&x) + test "Error reading from file:"++error=>not(error) +} +proc write(&f:file,x) { + error=write(&f,x) + test "Error writing to file:"++error=>not(error) +} +proc seek(&f:file,x:lint) { + error=seek(&f,x) + test "Error on seek:"++error=>not(error) +} +proc read%(&f:shared file,&x) { + error=read%(&f,&x) + test "Error reading from file:"++error=>not(error) +} +proc write%(&f:shared file,x) { + error=write%(&f,x) + test "Error writing to file:"=>not(error) +} +// ************************************************************* +// SUPPORT PROCEDURES FOR COMMUNICATING OPERATIONS +// ************************************************************* +// SOA tuples +type _stuple1d is rec^{t1} +type _stuple2d is rec^{t1,t2} +type _stuple3d is rec^{t1,t2,t3} +type _stuple4d is rec^{t1,t2,t3,t4} +type _stuple5d is rec^{t1,t2,t3,t4,t5} +type _stuple6d is rec^{t1,t2,t3,t4,t5,t6} +type _stuple7d is rec^{t1,t2,t3,t4,t5,t6,t7} +proc _st(t1)=new _stuple1d{ + t1=t1 +} +proc _st(t1,t2)=new _stuple2d{ + t1=t1,t2=t2 +} +proc _st(t1,t2,t3)=new _stuple3d{ + t1=t1,t2=t2,t3=t3 +} +proc _st(t1,t2,t3,t4)=new _stuple4d{ + t1=t1,t2=t2,t3=t3,t4=t4 +} +proc _st(t1,t2,t3,t4,t5)=new _stuple5d{ + t1=t1,t2=t2,t3=t3,t4=t4,t5=t5 +} +proc _st(t1,t2,t3,t4,t5,t6)=new _stuple6d{ + t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6 +} +proc _st(t1,t2,t3,t4,t5,t6,t7)=new _stuple7d{ + t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,t7=t7 +} +// Create normalised form of a grid used for _xxx_slice operations +proc _norm(n,x:seq or block_seq)=_st(n,low(x),high(x),step(x),width(x),align(x)) +proc _norm(n,x:map_seq)=_st(x.array,n) +proc _norm(n,x:grid)=_st(map_apply($_norm,$_st,n,x),size(x)) +// Apply idxdim index and convert to normal for for _send_slice_mapped +proc _dnorm(x:indexed_dim('1),m,n:single_point)=_st(m,t,t,1,1,0) where t=_dmap(x,n._t) +proc _dnorm(x:indexed_dim('1),m,n:range)=_st(m,_dmap(x,n._lo),_dmap(x,n._hi),1,1,0) +proc _dnorm(x:indexed_dim('1),m,n:strided_range)=_st(m,_dmap(x,n._lo),_dmap(x,n._hi),x._st*n._m,1,0) +proc _dnorm(x:indexed_dim('1,'1),m,n:block_seq)=_st(m,n._lo+x._c,n._hi+x._c,n._st,n._b,n._align) +proc _dnorm(x:indexed_dim('1),m,n:block_seq)=_dnorm(x,m,map_seq(n)) +proc _dnorm(x:indexed_dim('1),m,n:map_seq){ + var a=array(0,#n._array) + forall i in a,j in n._array:i=_dmap(x,j) + return _st(a) +} +proc _dnorm(x:indexed_dim('1),m,n:grid)=_st(map_apply($_dnorm,$_st,x,m,n),size(n)) +type _griddef is rec^{grid,elems} +proc _gd(grid,elems,size)=new _griddef{ + grid=grid,elems=elems +} +proc _send_slice(p,x:_comp^any,d) { + forall i in d { + _isend_offset%(j,p,x) where j=index(#x,i) + } +} + +proc _send_slice(p,x,d) { + _isend_offset(_norm(dims(x),d),p,x) +} + +proc _send_slice_mapped(p,x,d,t,s) { + forall k in d { + _isend_offset%(j,p,x) where j=index(dims(s),s#i) where i=_dmap(t,k) + } +} + +proc _send_slice_mapped(p,x:_comp^any,d,t:indexed_dim('1),s) { + forall k in d { + _isend_offset%(j,p,x) where j=index(dims(s),s#i) where i=_dmap(t,k) + } +} + +proc _send_slice_mapped(p,x,d,t:indexed_dim('1),s) { + _isend_offset(_dnorm(t,dims(x),d),p,x) +} + +proc _recv_slice(p,&x:_comp^any,d) { + forall i in d { + _irecv_offset%(j,p,&x) where j=index(#x,i) + } +} + +proc _recv_slice(p,&x,d) { + _irecv_offset(_norm(dims(x),d),p,&x) +} + +proc _recv_slice_sync(p,&x:_comp^any,d) { + forall i in d { + _recv_offset%(j,p,&x) where j=index(#x,i) + } +} + +proc _recv_slice_sync(p,&x,d) { + _recv_offset(_norm(dims(x),d),p,&x) +} + +proc _bcast_slice_shared(&x,d){ + _bcast_shared_offset(_norm(dims(x),d),&x) +} +proc _send_recv_slice_req(p,x:_comp,&a,sx,d,c:^^('true)) { + forall i in d { + j=index(sx,i) + _isend_recv_req%(j,p,^(x),&^(^(a))) + } +} + +proc _send_recv_slice_req(p,x,&a,sx,d,c:^^('true)) { + _isend_recv_req(_norm(dims(sx),d),p,^(x),&^(^(a))) +} +proc _send_recv_slice_req(p,x,&a,sx,d,c) { + forall i in d { + j=index(sx,i) + _isend_recv_req%(j,p,^(x),&^(^(a)),c) + } +} + +proc _send_slice_assn(p,x:_comp,y,sx,d,c:^^('true)) { + forall i in d { + _isend_assn%(j,^(p),^(x),^(y)) where j=index(sx,i) + } +} + +proc _send_slice_assn(p,x,y,sx,d,c:^^('true)) { + _isend_assn(_norm(dims(sx),d),p,x,y) +} +proc _send_slice_assn(p,x,y,sx,d,c) { + forall i in d { + _isend_assn%(j,p,^(x),^(y),^(c)) where j=index(sx,i) + } +} + +proc _recv_slice_reply(p,&x:_comp,sx,d,c:^^('true)) { + forall i in d { + _recv_reply%(j,^(p),&^(^(x))) where j=index(sx,i) + } +} + +proc _recv_slice_reply(p,&x,sx,d,c:^^('true)) { + _recv_reply(_norm(dims(sx),d),p,&x) +} +proc _recv_slice_reply(p,&x,sx,d,c) { + forall i in d { + _recv_reply%(j,p,&^(^(x)),c) where j=index(sx,i) + } +} + +PM__intrinsic<> _isend_offset%(r:any,s:any,h:any,j:any,p:any,x:any): "isend_offset" +PM__intrinsic<> _isend_offset(j:any,p:any,x:any): "isend_grid" +PM__intrinsic<> _irecv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any): "irecv_offset" +PM__intrinsic<> _irecv_offset(j:any,p:any,&x:any): "irecv_grid" +PM__intrinsic<> _recv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any): "recv_offset" +PM__intrinsic<> _recv_offset(j:any,p:any,&x:any): "recv_grid" +PM__intrinsic<> _bcast_shared_offset%(r:any,s:any,h:any,j:any,&x:any): "bcast_shared_offset" +PM__intrinsic<> _bcast_shared_offset(j:any,&x:any): "bcast_shared_grid" +PM__intrinsic<> _isend(p:any,x:any): "isend" +PM__intrinsic<> _irecv(p:any,&x:any): "irecv" +PM__intrinsic<> _recv(p:any,&x:any): "recv" +PM__intrinsic<> _isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any): "isend_req" +PM__intrinsic<> _isend_recv_req(j:any,p:any,x:any,&a:any): "isend_req" +PM__intrinsic<> _isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any,c:any): "isend_req" +PM__intrinsic<> _isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any): "isend_assn" +PM__intrinsic<> _isend_assn(j:any,p:any,x:any,y:any): "isend_assn" +PM__intrinsic<> _isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any,c:any): "isend_assn" +PM__intrinsic<> _recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any,c:any): "recv_reply" +PM__intrinsic<> _recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any): "recv_reply" +PM__intrinsic<> _recv_reply(j:any,p:any,&x:any): "recv_reply" +PM__intrinsic<> _bcast_shared(&x:any): "broadcast_shared" +PM__intrinsic<> _bcast_shared(&x:any,p:int): "broadcast_shared" +type _ct is array_slice,^*(,,,,),any^any,^^(any) +proc PM__sync_messages(x)<>:_sync_messages(x) +PM__if_compiling +proc _sync_messages(x:_ct):_do_sync_messages(_core(x)) +proc _sync_messages(x:_ct,y:_ct):_do_sync_messages(_core(x),_core(y)) +proc _core(x:any^any)=x +proc _core(x:^^(any))=x +proc _core(x:array_slice)=_core(x._a) +proc _core(x:^*(,,,,))=_core(_v2(x)) +PM__intrinsic<> _do_sync_messages(arg...:^^(any) or any^any): "sync_mess" +PM__else +PM__intrinsic<> _sync_messages(arg...:_ct): "sync_mess" +PM__endif +proc _tup(x:tuple)=x +proc _tup(arg...)=tuple(arg...) +proc _tup(x:null)=x +proc _tup%(x:invar) shared=_tup(x) +PM__intrinsic<> PM__broadcast(&b:any,a:int): "broadcast" +PM__intrinsic<> PM__broadcast(b:any,a:int)->(=b) : "broadcast_val" +PM__intrinsic<> get_remote%(r:any,s:any,h:any,a:shared any^dshape,b:int,c:int)->(%a) : "get_remote_distr" +PM__intrinsic<> put_remote%(r:any,s:any,h:any,a:shared any^dshape,b:any,c:int,d:int): "put_remote_distr" +// ******************************************************** +// OTHER COMMUNICATING & ARRAY OPERATIONS +// ******************************************************** +proc map(p:proc,x:any^any) { + var z=array(p.(_arb(x)),#x) + for i in z, j in x:i=p.(j) +} +proc map(p:proc,x:any^any,y:any^any) { + var z=array(p.(_arb(x),_arb(y)),#x) + for i in z,j in x,k in y:i=p.(j,k) +} +proc map(p:proc,x:any^mshape,y:any^dshape) { + var z=array(p.(_arb(x),_arb(y)),#(y)) + for i in z,j in x,k in y:i=p.(j,k) +} +proc map_const(p:proc,x:any^mshape,y:any){ + var z=array(p.(_arb(x),y),#x) + for i in z,j in x:i=p.(j,y) +} +proc +(x:num^any,y:num^any)=map($+,x,y) +proc -(x:num^any,y:num^any)=map($-,x,y) +proc *(x:num^any,y:num^any)=map($*,x,y) +proc /(x:num^any,y:num^any)=map($/,x,y) +proc **(x:num^any,y:num^any)=map($**,x,y) +proc mod(x:real_num^any,y:real_num^any)=map($mod,x,y) +proc max(x:real_num^any,y:real_num^any)=map($max,x,y) +proc min(x:real_num^any,y:real_num^any)=map($min,x,y) +proc +(x:num^any,y:any)=map_const($+,x,y) +proc -(x:num^any,y:any)=map_const($-,x,y) +proc *(x:num^any,y:any)=map_const($*,x,y) +proc /(x:num^any,y:any)=map_const($/,x,y) +proc **(x:num^any,y:any)=map_const($**,x,y) +proc mod(x:real_num^any,y:real_num)=map_const($mod,x,y) +proc max(x:real_num^any,y:real_num)=map_const($max,x,y) +proc min(x:real_num^any,y:real_num)=map_const($min,x,y) +PM__intrinsic _pack(v:any,any,any,d:any)->(PM__dim v,d) : "pack" +proc pack(v:any^mshape,m:bool^mshape) { + test "arrays do not conform"=>conform(#v,#m) + result =_pack(v,m,n,tuple(0..n-1)) where n=count(m) +} + +proc pack(vv:array,mm:array) { + var v=vv + var m=mm + return _pack(v,m,n,tuple(0..n-1)) where n=count(m) +} + +// Reduction +type associative_proc is $+,$*,$max,$min,$&,$|,$xor,$++,$==,... +PM__if_compiling +proc reduce(p:proc,x:array(,mshape)) { + var s=_get_aelem(x,0) + foreach i in 1..size(#x)-1 { + s=p.(s,_get_aelem(x,i)) + } + return s +} +PM__else +proc reduce(p:proc,x:array(,mshape)) { + var y=x + var n=size(x) + while n>1 { + var m=(n+1)/2 + forall k in m..n-1 { + PM__setaelem(&y,k-m,p.(_get_aelem(y,k-m),_get_aelem(y,k)) <>) + } + n=m + } + return _get_aelem(y,0) +} + +PM__endif +proc reduce(p:proc,y:array)=_reduce(p,reduce(p,PM__local(y))) +proc _reduce_for_assign%(p:invar associative_proc,y,init:invar){ + chan yy=y + return reduce%(p,yy,init) +} +proc _reduce_for_assign%(p:invar $-,y,init:invar){ + chan yy=y + return init - _reduce%($+,yy,init) +} +proc _reduce_for_assign%(p:invar $/,y,init:invar){ + chan yy=y + return init / _reduce%($*,yy,init) +} +proc reduce%(p:invar proc,y:chan,init)=^(p.(init,__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>)),uniform) +proc _reduce%(p:invar proc,y:chan)=^(__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>),uniform) +proc _reduce_on_node%(p:invar,y:invar) PM__node=reduce(p,y) +proc __reduce_on_node%(p:invar,y:invar) PM__node=_reduce(p,y) +proc _reduce(p:proc,y) { + var x=array(y,[0..0]) + var z=array(y,[0..0]) + var n=this_nnode() + var i=1 + until i>n-1 { + other=_this_node() xor i + if other=y._lo and x<=y._hi +proc match_switch_case(x:real_num,y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:int_literal,y:_crange)=(x>=y._lo and x<=y._hi) as +proc match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi +proc match_switch_case(x:,y:)=y inc x +type _crange is rec{_lo,_hi} +proc PM__caserange(x,y)=x..y +proc PM__caserange(x:fix(int),y:fix(int))=new _crange{ + _lo=x,_hi=y +} + +// Conditional operators +proc PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> same_type(y,z) { + var r=z + if x { + r=y + } + return r +} + +proc PM__if(x:'true,y,z)=y +proc PM__if(x:'false,y,z)=z +proc PM__if(x:'true,y:literal,z)=y +proc PM__if(x:'false,y,z:literal)=z +proc PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> same_type(y,z) { + var r=z + if match(w,x) { + r=y + } + return r +} + +proc PM__switch(w:fix(int),x:fix(int),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z) +proc PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z) +proc PM__switch(w,x,y,arg...)=PM__switch(w,x,y,PM__switch(w,arg...)) + +// Assignment +proc PM__assign_or_init(a,b)<>=a { + PM__assign_var(&^(a),b) +} + +proc PM__assign_or_init(a:,b)=PM__dup(b as a) + +proc PM__assign_var(&a,b) { + PM__assign(&a,b) +} + +proc PM__assign(&a:any,b:any) { + _assign(&a,c) where c=b as a +} + +type assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,... + +proc PM__assign(&a:any,b:any,c:assignment_operator) { + PM__assign(&a,c.(a,b)) +} + +proc PM__assign(&a:any,b:any,c:proc) { + test "Not a recognised assignment operator"=>'false +} + +proc check_assign_types(x,y){ + test "Type mismatch in assignment"=>same_type(x,y) +} +proc _assign(&a,b) { + _assign_element(&a,b) +} +proc _assign(&a:contains(farray),b) { + _assign_structure(&a,b) +} +proc _assign_structure(&a,b)<>{ + _assign_element(&a,b) +} +proc _assign_structure(&a:farray,b){ + _array_assign(&a,b,'true) +} +PM__intrinsic _assign_element(&any,any): "assign" + + +// Other variable operations +PM__intrinsic PM__clone(x:any)->(=x) : "clone" +proc PM__dup(PM__dup) <>=PM__clone(PM__dup) +PM__intrinsic PM__dup(x:fix int)->(int) : "clone" +PM__intrinsic PM__dup(x:fix real)->(real) : "clone" +PM__intrinsic PM__dup(x:fix string)->(string) : "clone" +PM__intrinsic PM__dup(x:fix bool)->(bool) : "clone" +PM__intrinsic PM__getref(x:any)->(=x) : "get_rf" +PM__intrinsic<> same_type(x:any,y:any)->(==x,y) : "logical_return" +proc ==(x:any,y:any) { + test "Cannot apply ""=="" to different types"=> same_type(x,y) + var ok=true + _eq(x,y,&ok) + return ok +} +proc /=(x:any,y:any) { + test "Cannot apply ""/="" to different types"=> same_type(x,y) + var ok=true + _eq(x,y,&ok) + return not ok +} +proc _eq(x:any,y:any,&ok) <> { + ok=ok and x==y +} + +PM__intrinsic PM__copy_out(x:any)->(=x) : "clone" +PM__intrinsic PM__copy_back(x:any)->(=x) : "assign" +proc next_enum(x:int)=x+convert(1,x) +proc next_enum(x:int,y:int)=x+convert(y,x) + +PM__intrinsic<> PM__element_at(x:any,y:int_literal)->(|x):"elem" + +proc elements(x)=_elements(x,1) +proc _elements(x,i:int_literal) { + const e + if '(i==num_elements(x)) { + e=_cons(PM__element_at(x,i),_list_end) + } else { + e=_cons(PM__element_at(x,i),_elements(x,i+1)) + } + return e +} + +// Type values +PM__intrinsic<> typeof(x:any)->(type x) : "make_type_val" +proc is(x,t)=t inc typeof(x) +proc isnt(x,t)=not(x is t) +proc as(x,t:)...=PM__cast(x,t) +proc as(x,t)=PM__cast(x,typeof(t)) +PM__intrinsic<> inc(x:,y:)->( inc x,y) : "type_include_fold" +proc ==(x:,y:)=x inc y and y inc x +PM__intrinsic<> error_type()->(?0) : "call" + +// Debugging +PM__intrinsic<> _dump(any,any): "new_dump" +proc PM__dump(x)<>:_dump("Value:",x) +proc PM__dump(y,x)<>:if y:_dump("Value:",x) +proc PM__dump%(x)<>{ + print("$"++here) + _dump(string(here),x) +} +proc PM__dump%(y:bool,x)<>{ + if y:_dump(string(here),x) +} +proc PM__dump%(y,x){ + test "Selection expression in '$$dump' not 'bool'" => 'false + $$infer_type(y) +} +PM__intrinsic<> old_dump(any): "dump" +proc old_dumpit(a) { + old_dump(a) + return a +} + +PM__intrinsic<> old_dump_id(any): "dump_id" + +proc PM__filesys()=1 diff --git a/pmc/Makefile b/pmc/Makefile index 3349517..7784a3f 100755 --- a/pmc/Makefile +++ b/pmc/Makefile @@ -27,7 +27,7 @@ PC=mpifort FFLAGS= -I../src/ -g -fbounds-check -fcheck=mem # -Wall PFLAGS= -I../src/ -g -fbounds-check -fcheck=mem -PMCODE= sysdep.o scomp.o kinds.o memory.o hash.o opts.o lib.o types.o symbol.o vmdefs.o parser.o linker.o sysdefs.o codegen.o infer.o wcoder.o optimise.o cfortran.o main.o +PMCODE= sysdep.o scomp.o kinds.o memory.o hash.o opts.o lib.o types.o symbol.o vmdefs.o ast.o parser.o linker.o sysdefs.o cnodes.o codegen.o infer.o wcoder.o optimise.o cfortran.o main.o all : pmc @@ -68,8 +68,10 @@ lib.o : ../src/lib.f90 symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o vmdefs.o : ../src/vmdefs.f90 lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o $(FC) $(FFLAGS) -c $< +ast.o : ../src/ast.f90 vmdefs.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o + $(FC) $(FFLAGS) -c $< -parser.o : ../src/parser.f90 vmdefs.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o +parser.o : ../src/parser.f90 ast.o vmdefs.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o $(FC) $(FFLAGS) -c $< types.o : ../src/types.f90 lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o @@ -81,13 +83,16 @@ linker.o : ../src/linker.f90 parser.o lib.o symbol.o opts.o hash.o memory.o kin sysdefs.o : ../src/sysdefs.f90 vmdefs.o parser.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o $(FC) $(FFLAGS) -c $< -codegen.o : ../src/codegen.f90 parser.o symbol.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o +cnodes.o : ../src/cnodes.f90 parser.o symbol.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o + $(FC) $(FFLAGS) -c $< + +codegen.o : ../src/codegen.f90 cnodes.o ast.o symbol.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o $(FC) $(FFLAGS) -c $< -infer.o : ../src/infer.f90 codegen.o parser.o symbol.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o +infer.o : ../src/infer.f90 codegen.o cnodes.o ast.o symbol.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o $(FC) $(FFLAGS) -c $< -wcoder.o : ../src/wcoder.f90 infer.o codegen.o parser.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o +wcoder.o : ../src/wcoder.f90 infer.o cnodes.o ast.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o $(FC) $(FFLAGS) -c $< optimise.o : ../src/optimise.f90 ../src/rtime.inc wcoder.o infer.o codegen.o linker.o parser.o sysdefs.o types.o lib.o symbol.o opts.o hash.o memory.o kinds.o scomp.o sysdep.o diff --git a/src/array.f90 b/src/array.f90 index 0ad9968..05a8920 100755 --- a/src/array.f90 +++ b/src/array.f90 @@ -65,7 +65,9 @@ module pm_array contains + !============================================================================= ! Zero any unused (according to ve) elements of vector of long ints + !============================================================================= function vector_zero_unused(context,v,ve,zero) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ve @@ -100,12 +102,14 @@ function vector_zero_unused(context,v,ve,zero) result(ptr) include 'fvkind.inc' end function vector_zero_unused + !============================================================================= ! Make an array, or vector of arrays ! Defined by four vectors: ! vec - vector of vectors of elements (for all arrays in array vector) ! dom - vector of array domain values ! len - vector of array lengths (num's of elements) ! off - vector giving offset of first element of each array in vec + !============================================================================= function make_array(context,akind,typno,vec,dom,len,off) result(ptr) type(pm_context),pointer:: context integer(pm_p),intent(in):: akind @@ -126,7 +130,9 @@ function make_array(context,akind,typno,vec,dom,len,off) result(ptr) include 'ftypeno.inc' end function make_array - ! LHS value for single array element !!! Needs to use ve + !============================================================================= + ! LHS value for single array element + !============================================================================= function make_elem_ref(context,array,aindex,ve,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: array,aindex,ve @@ -193,7 +199,9 @@ function make_elem_ref(context,array,aindex,ve,errno) result(ptr) include 'fesize.inc' end function make_elem_ref + !============================================================================= ! Dereference an array element LHS reference + !============================================================================= function get_elem_ref(context,p,esize,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: p @@ -219,7 +227,9 @@ function get_elem_ref(context,p,esize,errno) result(ptr) include 'ftypeof.inc' end function get_elem_ref + !============================================================================= ! Get element from reference to struct/rec .n + !============================================================================= function elem_ref_get_struct_elem(context,v,n,esize) result(w) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -252,7 +262,9 @@ function elem_ref_get_struct_elem(context,v,n,esize) result(w) include 'fnewnc.inc' end function elem_ref_get_struct_elem + !============================================================================= ! Return domain of an array / reference to array + !============================================================================= function array_dom(context,v,esize) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -289,7 +301,9 @@ function array_dom(context,v,esize) result(ptr) include 'ftypeof.inc' end function array_dom - ! Return size of an array + !============================================================================= + ! Return size of an array or reference to array + !============================================================================= function array_size(context,v,esize) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -325,9 +339,11 @@ function array_size(context,v,esize) result(ptr) include 'ftypeof.inc' end function array_size + !============================================================================= ! Make an array with j elements having intial value val ! domain dom ! (vector inputs yield vector of arrays) + !============================================================================= function make_array_dim(context,typno,val,dom,j,ve) result(ptr) type(pm_context),pointer:: context integer,intent(in):: typno @@ -357,10 +373,12 @@ function make_array_dim(context,typno,val,dom,j,ve) result(ptr) include 'fisnull.inc' include 'fesize.inc' end function make_array_dim - + + !============================================================================= ! Make an array with j elements having intial value val ! domain dom ! (vector inputs yield vector of arrays) + !============================================================================= function make_array_vdim(context,typno,val,dom,j,ve) result(ptr) type(pm_context),pointer:: context integer,intent(in):: typno @@ -389,7 +407,9 @@ function make_array_vdim(context,typno,val,dom,j,ve) result(ptr) include 'fesize.inc' end function make_array_vdim + !============================================================================= ! Create array with same elements (by ref) but new domain + !============================================================================= function array_redim(context,tno,array,dom) result(ptr) type(pm_context),pointer:: context integer,intent(in):: tno @@ -403,7 +423,9 @@ function array_redim(context,tno,array,dom) result(ptr) array%data%ptr(array%offset+pm_array_offset)) end function array_redim + !============================================================================= ! Build array from vector of values + !============================================================================= function make_array_from_vect(context,typno,vec,dom,esize,import_vec) result(ptr) type(pm_context),pointer:: context integer,intent(in):: typno @@ -438,7 +460,9 @@ function make_array_from_vect(context,typno,vec,dom,esize,import_vec) result(ptr include 'fesize.inc' end function make_array_from_vect + !============================================================================= ! Number of elements-1 in vector of arrays + !============================================================================= function array_vector_esize(array) result(size) type(pm_ptr),intent(in):: array integer(pm_ln):: size @@ -447,7 +471,9 @@ function array_vector_esize(array) result(size) include 'fesize.inc' end function array_vector_esize + !============================================================================= ! Size-1 of a vector + !============================================================================= recursive function vector_esize(v) result(esize) type(pm_ptr),intent(in):: v integer(pm_ln):: esize @@ -456,7 +482,7 @@ recursive function vector_esize(v) result(esize) select case(tno) case(pm_array_type,pm_const_array_type) esize=vector_esize(v%data%ptr(v%offset+pm_array_length)) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) esize=vector_esize(v%data%ptr(v%offset+2_pm_p)) case default esize=pm_fast_esize(v) @@ -466,7 +492,9 @@ recursive function vector_esize(v) result(esize) include 'fesize.inc' end function vector_esize + !============================================================================= ! Number of leaves in a vector + !============================================================================= recursive function vector_num_leaves(v) result(n) type(pm_ptr),intent(in):: v integer:: n @@ -475,7 +503,7 @@ recursive function vector_num_leaves(v) result(n) select case(tno) case(pm_array_type,pm_const_array_type) n=vector_num_leaves(v%data%ptr(v%offset+pm_array_vect))+pm_array_size-3 - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) n=0 do i=2,pm_fast_esize(v) n=n+vector_num_leaves(v%data%ptr(v%offset+i)) @@ -487,8 +515,10 @@ recursive function vector_num_leaves(v) result(n) include 'ftypeof.inc' include 'fesize.inc' end function vector_num_leaves - + + !============================================================================= ! Return array element value for given index + !============================================================================= function array_index(context,array,index,ve,esize,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: array,index,ve @@ -556,6 +586,10 @@ function array_index(context,array,index,ve,esize,errno) result(ptr) include 'fisnull.inc' end function array_index + !============================================================================= + ! Return array element value for given index + ! - does the work p=array[idx] with array defined by + !============================================================================= recursive subroutine array_vect_index(context,p,v,idx,offset,esize) type(pm_context),pointer:: context type(pm_ptr),intent(in):: p,v,idx,offset @@ -600,7 +634,7 @@ recursive subroutine array_vect_index(context,p,v,idx,offset,esize) off%data%ln(off%offset+i)=0_pm_ln endif enddo - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) root=>pm_add_root(context,pm_null_obj) do j=2,pm_fast_esize(p) root%ptr=pm_new(context,pm_pointer,esize+1_pm_ln) @@ -727,7 +761,9 @@ recursive subroutine array_vect_index(context,p,v,idx,offset,esize) include 'fesize.inc' end subroutine array_vect_index + !============================================================================= ! Set array element at given index to given value (e) + !============================================================================= subroutine array_set_index(context,array,index,e,ve,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: array,index,e,ve @@ -786,6 +822,10 @@ subroutine array_set_index(context,array,index,e,ve,errno) include 'ftypeof.inc' end subroutine array_set_index + !============================================================================= + ! Set array element + ! - does the work array[idx]=p with array defined by + !============================================================================= recursive subroutine array_vect_set_index(context,v,idx,offset,p,esize,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: p,v,idx,offset @@ -822,7 +862,7 @@ recursive subroutine array_vect_set_index(context,v,idx,offset,p,esize,errno) p,i,errno) endif enddo - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) root=>pm_add_root(context,pm_null_obj) do j=2,pm_fast_esize(p) root%ptr=pm_new(context,pm_pointer,esize+1_pm_ln) @@ -961,6 +1001,9 @@ recursive subroutine array_vect_set_index(context,v,idx,offset,p,esize,errno) include 'fesize.inc' end subroutine array_vect_set_index + !============================================================================= + ! Pack array v + !============================================================================= function array_pack(context,v,t,m,n,d) result(ptr) type(pm_context),pointer:: context integer:: t @@ -989,6 +1032,10 @@ function array_pack(context,v,t,m,n,d) result(ptr) include 'fesize.inc' end function array_pack + !============================================================================= + ! Pack array v using boolean vector m + ! !!! Incomplete + !============================================================================= recursive function vector_pack(context,v,m,n) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,m @@ -1017,7 +1064,7 @@ recursive function vector_pack(context,v,m,n) result(ptr) int(v%data%ptr(v%offset+pm_array_typeof)%offset),& vv,dv,lv,ov) call pm_delete_register(context,reg) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) reg=>pm_register(context,'vpack2',vv) vv=pm_fast_new(context,pm_usr,int(pm_fast_esize(v),pm_p)) vv%data%ptr(vv%offset)=v%data%ptr(v%offset) @@ -1043,6 +1090,7 @@ recursive function vector_pack(context,v,m,n) result(ptr) ptr%data%i(ptr%offset:ptr%offset+esize)=& pack(v%data%i(v%offset:v%offset+esize2),& m%data%l(m%offset:m%offset+esize2)) + end select contains include 'fesize.inc' @@ -1050,6 +1098,9 @@ recursive function vector_pack(context,v,m,n) result(ptr) include 'fnew.inc' end function vector_pack + !============================================================================= + ! Create a new polymorphic vector (ve must be shrunk) + !============================================================================= function poly_new(context,v,ve,esize) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ve @@ -1076,6 +1127,10 @@ function poly_new(context,v,ve,esize) result(ptr) include 'fnewnc.inc' end function poly_new + + !============================================================================= + ! Assign polymorphic values from w into existing vector v + !============================================================================= subroutine poly_get(context,v,w,ve,esize,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,w,ve @@ -1110,6 +1165,9 @@ subroutine poly_get(context,v,w,ve,esize,errno) include 'fesize.inc' end subroutine poly_get + !============================================================================= + ! Return vector of bool for which polymorphic type is equal to tno + !============================================================================= function poly_check_type(context,v,tno,ve,esize) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ve @@ -1144,13 +1202,15 @@ function poly_check_type(context,v,tno,ve,esize) result(ptr) include 'fvkind.inc' include 'fesize.inc' end function poly_check_type - + + !============================================================================= ! Import vector using information in import_vec ! import_vec(0) : esize of imported vector ! import_vec(1) : offset into vector being imported ! import_vec(2) : offset into element ! import_vec(3) : total size of imported vector ! import_vec(4:) : size of each segment + !============================================================================= function import_vector(context,v,import_vec) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,import_vec @@ -1166,8 +1226,10 @@ function import_vector(context,v,import_vec) result(ptr) contains include 'fesize.inc' end function import_vector - + + !============================================================================= ! Re-export elements of imported vector e back to v + !============================================================================= recursive subroutine export_vector(context,v,e,import_vec) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,e,import_vec @@ -1176,15 +1238,15 @@ recursive subroutine export_vector(context,v,e,import_vec) integer:: k,errno tno=pm_fast_typeof(v) if(pm_fast_typeof(e)/=tno) then - write(*,*) trim(pm_typ_as_string(context,tno)),'<>',& - trim(pm_typ_as_string(context,pm_fast_typeof(e))) + write(*,*) trim(pm_type_as_string(context,tno)),'<>',& + trim(pm_type_as_string(context,pm_fast_typeof(e))) call pm_panic('export_vector') endif n=pm_fast_esize(v) select case(tno) case(pm_array_type,pm_const_array_type) continue - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do k=2,n call export_vector(context,& v%data%ptr(v%offset+k),& @@ -1342,7 +1404,10 @@ recursive subroutine export_vector(context,v,e,import_vec) include 'ftypeof.inc' include 'fesize.inc' end subroutine export_vector - + + !============================================================================= + ! Export vector v, creating a new vector + !============================================================================= function export_vector_as_new(context,v,import_vec,ve) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,import_vec,ve @@ -1395,8 +1460,10 @@ function export_vector_as_new(context,v,import_vec,ve) result(ptr) include 'ftypeof.inc' end function export_vector_as_new + !============================================================================= ! For any group (defined by import_vec) if any index has a true ! in v then set all that group true in w (else false) + !============================================================================= function vector_if_needed(context,v,import_vec) result(w) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,import_vec @@ -1438,8 +1505,10 @@ function vector_if_needed(context,v,import_vec) result(w) include 'fesize.inc' end function vector_if_needed + !============================================================================= ! For any group (defined by import_vec) if any index has a true ! in v then next element true in w (else false) + !============================================================================= function vector_export_if_needed(context,v,import_vec) result(w) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,import_vec @@ -1451,7 +1520,7 @@ function vector_export_if_needed(context,v,import_vec) result(w) if(vk==pm_tiny_int) then w=v else - w=pm_new(context,pm_logical,pm_fast_esize(import_vec)-3) + w=pm_new(context,pm_logical,max(1_pm_ln,pm_fast_esize(import_vec)-3)) if(vk==pm_null) then k=0 do i=4,pm_fast_esize(import_vec) @@ -1497,12 +1566,15 @@ function vector_export_if_needed(context,v,import_vec) result(w) enddo endif endif + contains include 'fvkind.inc' include 'fesize.inc' end function vector_export_if_needed - + + !============================================================================= ! Build a vector by replicating a scalar value + !============================================================================= recursive function make_vector(context,v,j,dispv,dispj,vsize,full_copy) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,j @@ -1562,7 +1634,7 @@ recursive function make_vector(context,v,j,dispv,dispj,vsize,full_copy) result(p v%data%ptr(v%offset+pm_elemref_offset),& j,dispv,dispj,siz,full_copy)) call pm_delete_root(context,root) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) root=>pm_new_as_root(context,pm_usr,pm_fast_esize(v)+1_pm_ln) ptr=root%ptr ptr%data%ptr(ptr%offset)=v%data%ptr(v%offset) @@ -1706,7 +1778,7 @@ recursive function make_vector(context,v,j,dispv,dispj,vsize,full_copy) result(p enddo enddo case default - write(*,*) '%%',trim(pm_typ_as_string(context,tno)),tno,pm_dref_type + write(*,*) '%%',trim(pm_type_as_string(context,tno)),tno,pm_dref_type call pm_panic('Make vector') end select contains @@ -1714,8 +1786,10 @@ recursive function make_vector(context,v,j,dispv,dispj,vsize,full_copy) result(p include 'fesize.inc' end function make_vector + !============================================================================= ! Make a copy of a vector ! size==-1 means use source size + !============================================================================= recursive function copy_vector(context,v,ve,start,size) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ve @@ -1803,7 +1877,10 @@ recursive function copy_vector(context,v,ve,start,size) result(ptr) include 'ftypeof.inc' include 'ftiny.inc' end function copy_vector - + + !============================================================================= + ! Copy a distributed reference + !============================================================================= recursive function copy_dref(context,v,size,same_proc,ve) result(w) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -1853,7 +1930,10 @@ recursive function copy_dref(context,v,size,same_proc,ve) result(w) contains include 'ftypeof.inc' end function copy_dref - + + !============================================================================= + ! Array assignment of lhs(ix) <- rhs(iy) + !============================================================================= subroutine array_assign(context,lhs,ix,rhs,iy,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: lhs,rhs @@ -1901,8 +1981,10 @@ subroutine array_assign(context,lhs,ix,rhs,iy,errno) include 'fesize.inc' include 'ftypeof.inc' end subroutine array_assign - + + !============================================================================= ! Make an empty copy of a vector with a new length + !============================================================================= recursive function empty_copy_vector(context,v,size) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -1964,7 +2046,9 @@ recursive function empty_copy_vector(context,v,size) result(ptr) include 'ftiny.inc' end function empty_copy_vector + !============================================================================ ! Make a vector by replicating v[offset] + !============================================================================ recursive function vector_from_scalar(context,v,offset,esize,is_const) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -2045,6 +2129,9 @@ recursive function vector_from_scalar(context,v,offset,esize,is_const) result(pt include 'ftiny.inc' end function vector_from_scalar + !============================================================================= + ! Assign lhs <- rhs, masked by ve + !============================================================================= recursive subroutine vector_assign(context,lhs,rhs,ve,errno,esize) type(pm_context),pointer:: context type(pm_ptr),intent(in):: lhs,rhs,ve @@ -2060,8 +2147,8 @@ recursive subroutine vector_assign(context,lhs,rhs,ve,errno,esize) tno=pm_fast_typeof(lhs) !!$ if(full_type(lhs)/=full_type(rhs)) then !!$ errno=vector_type_error -!!$ write(*,*) 'Full types',pm_typ_as_string(context,full_type(lhs)),& -!!$ pm_typ_as_string(context,full_type(rhs)) +!!$ write(*,*) 'Full types',pm_type_as_string(context,full_type(lhs)),& +!!$ pm_type_as_string(context,full_type(rhs)) !!$ !call pm_dump_tree(context,6,lhs,2) !!$ !call pm_dump_tree(context,6,rhs,2) !!$ return @@ -2103,7 +2190,7 @@ recursive subroutine vector_assign(context,lhs,rhs,ve,errno,esize) lhs%data%ptr(lhs%offset+pm_elemref_offset),& rhs,esize,errno) call pm_delete_root(context,root) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do i=2,pm_fast_esize(lhs) call vector_assign(context,& lhs%data%ptr(lhs%offset+i),& @@ -2314,8 +2401,8 @@ recursive subroutine vector_assign(context,lhs,rhs,ve,errno,esize) endif case default - write(*,*) 'vector assign',trim(pm_typ_as_string(context,int(tno))),tno,& - 2595,trim(pm_typ_as_string(context,2595)) + write(*,*) 'vector assign',trim(pm_type_as_string(context,int(tno))),tno,& + 2595,trim(pm_type_as_string(context,2595)) end select contains @@ -2325,7 +2412,9 @@ recursive subroutine vector_assign(context,lhs,rhs,ve,errno,esize) include 'fvkind.inc' end subroutine vector_assign - ! Test element-by_element equality of two vectors + !============================================================================= + ! Test element-by_element equality of two vectors: eq <- v1 == v2 + !============================================================================= recursive subroutine vector_eq(context,v1,v2,eq,esize,ve) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v1,v2,ve @@ -2403,7 +2492,7 @@ recursive subroutine vector_eq(context,v1,v2,eq,esize,ve) endif enddo endif - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do k=2,pm_fast_esize(v1) call vector_eq(context,v1%data%ptr(v1%offset+k),& v2%data%ptr(v2%offset+k),eq,esize,ve) @@ -2736,6 +2825,9 @@ recursive subroutine vector_eq(context,v1,v2,eq,esize,ve) include 'fvkind.inc' end subroutine vector_eq + !============================================================================= + ! Check that all(v1(istart:+isize)==v2(istart2:+isize)) + !============================================================================= recursive function vector_all_eq(context,v1,v2,istart1,istart2,isize) result(ok) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v1,v2 @@ -2780,7 +2872,7 @@ recursive function vector_all_eq(context,v1,v2,istart1,istart2,isize) result(ok) vec2%data%ptr(vec2%offset+j),start1,start2,size1) if(.not.ok) return enddo - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do k=2,pm_fast_esize(v1) if(.not.vector_all_eq(context,v1%data%ptr(v1%offset+k),& v2%data%ptr(v2%offset+k),istart1,istart2,isize)) then @@ -2842,9 +2934,11 @@ recursive function vector_all_eq(context,v1,v2,istart1,istart2,isize) result(ok) include 'fvkind.inc' end function vector_all_eq + !============================================================================= ! Compute a vector of indices ! start, start+step, .., end ! Each index repeated elsize times + !============================================================================= function vector_iota(context,& elsize,start,end,step,import_vec) result(ptr) type(pm_context),pointer:: context @@ -2883,18 +2977,21 @@ function vector_iota(context,& if(idx>iend) idx=istart endif enddo - enddo + enddo + !call pm_dump_tree(context,6,vec,2) ptr=vec contains include 'fesize.inc' include 'fisnull.inc' end function vector_iota + !============================================================================= ! Compute a vector of indices ! start, start+step, .., ! Each index repeated elsize times ! The sequence truncated to siz elements ! and truncated to start first elements in + !============================================================================= function vector_iota_trunc(context,& elsize,start,end,step,first,siz,import_vec) result(ptr) type(pm_context),pointer:: context @@ -2948,7 +3045,9 @@ function vector_iota_trunc(context,& include 'fisnull.inc' end function vector_iota_trunc + !============================================================================= ! Calculate indices within block cyclic tile + !============================================================================= subroutine vector_bc(context,ndim,arg,start,end,step,ostart,oend,ostep,& begin,finish,tot,off) type(pm_context),pointer:: context @@ -3204,7 +3303,9 @@ subroutine vector_bc(context,ndim,arg,start,end,step,ostart,oend,ostep,& if(k-off/=tot) call pm_panic('vector_bc') end subroutine vector_bc - + !============================================================================= + ! Produce vector of 1-D indices for a given import vector + !============================================================================= subroutine vector_indices(imp,idx) type(pm_ptr):: imp,idx integer(pm_ln):: i,j,k @@ -3218,8 +3319,10 @@ subroutine vector_indices(imp,idx) contains include 'fesize.inc' end subroutine vector_indices - + + !============================================================================= ! Get elements from a vector (indices start at 0) + !============================================================================= recursive function vector_get_elems(context,v,ix,errno,keeparrays) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ix @@ -3263,7 +3366,7 @@ recursive function vector_get_elems(context,v,ix,errno,keeparrays) result(ptr) int(v%data%ptr(v%offset+pm_array_typeof)%offset),& vec,dom,len,off) call pm_delete_register(context,reg) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) root=>pm_new_as_root(context,pm_usr,pm_fast_esize(v)+1) ptr=root%ptr ptr%data%ptr(ptr%offset)=v%data%ptr(v%offset) @@ -3400,7 +3503,9 @@ recursive function vector_get_elems(context,v,ix,errno,keeparrays) result(ptr) include 'fesize.inc' end function vector_get_elems - ! Set elements in a vector + !============================================================================= + ! Set elements in a vector v[ix]=e masked by ve + !============================================================================= recursive subroutine vector_set_elems(context,v,ix,e,ve,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ix,e,ve @@ -3411,8 +3516,8 @@ recursive subroutine vector_set_elems(context,v,ix,e,ve,errno) type(pm_ptr):: len,off,avec,len2,off2,avec2 tno=pm_fast_typeof(v) if(full_type(e)/=full_type(v)) then - write(*,*) trim(pm_typ_as_string(context,tno)),& - '<-->',trim(pm_typ_as_string(context,pm_fast_typeof(e))) + write(*,*) trim(pm_type_as_string(context,tno)),& + '<-->',trim(pm_type_as_string(context,pm_fast_typeof(e))) errno=vector_type_error return endif @@ -3437,7 +3542,7 @@ recursive subroutine vector_set_elems(context,v,ix,e,ve,errno) call array_assign(context,v,ix%data%ln(ix%offset+i),e,i,errno) enddo endif - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do k=2,pm_fast_esize(v) call vector_set_elems(context,v%data%ptr(v%offset+k),& ix,e%data%ptr(e%offset+k),ve,errno) @@ -3677,6 +3782,9 @@ recursive subroutine vector_set_elems(context,v,ix,e,ve,errno) include 'fvkind.inc' end subroutine vector_set_elems + !============================================================================= + ! Assign single element of a vector v[j]=e + !============================================================================= recursive subroutine assign_single(context,v,j,e,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,e @@ -3696,7 +3804,7 @@ recursive subroutine assign_single(context,v,j,e,errno) call assign_single(context,v%data%ptr(v%offset+pm_array_dom),j,& e%data%ptr(e%offset+pm_array_dom),errno) call array_assign(context,v,j,e,0_pm_ln,errno) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do k=2,pm_fast_esize(v) call assign_single(context,v%data%ptr(v%offset+k),j,& e%data%ptr(e%offset+k),errno) @@ -3739,8 +3847,9 @@ recursive subroutine assign_single(context,v,j,e,errno) include 'fesize.inc' end subroutine assign_single - - ! Copy elements of vector e to elements of vector v + !============================================================================= + ! Copy elements of vector e to elements of vector v v(ix) <- e(iy) + !============================================================================= recursive subroutine vector_copy_elems(context,v,e,ix,iy,n,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,e @@ -3764,7 +3873,7 @@ recursive subroutine vector_copy_elems(context,v,e,ix,iy,n,errno) call array_assign(context,v,ix(i),e,iy(i),errno) if(errno/=0) return enddo - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) do k=2,pm_fast_esize(v) call vector_copy_elems(context,& v%data%ptr(v%offset+k),& @@ -3882,7 +3991,9 @@ recursive subroutine vector_copy_elems(context,v,e,ix,iy,n,errno) include 'fesize.inc' end subroutine vector_copy_elems + !============================================================================= ! Copy a range of elements from one vector to another + !============================================================================= recursive subroutine vector_copy_range(context,v,start1,e,start2,siz,errno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,e @@ -3893,7 +4004,7 @@ recursive subroutine vector_copy_range(context,v,start1,e,start2,siz,errno) type(pm_ptr):: p k=pm_fast_typeof(v) select case(k) - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) if(k/=pm_fast_typeof(e)) then errno=vector_type_error return @@ -3963,26 +4074,36 @@ recursive subroutine vector_copy_range(context,v,start1,e,start2,siz,errno) include 'fesize.inc' end subroutine vector_copy_range + !============================================================================= + ! Dump v to std out with indent of depth + !============================================================================= recursive subroutine vector_dump(context,v,depth) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v integer,intent(in):: depth character(len=80):: spaces=' ' integer:: k - type(pm_ptr):: name + type(pm_ptr):: name,p integer:: tno,i if(depth>=35) then write(*,*) spaces(1:depth*2),'...' endif k=pm_fast_typeof(v) - !write(*,*) 'k=',k + write(*,*) 'k=',k select case(k) case(pm_array_type,pm_const_array_type) - write(*,*) spaces(1:depth*2),'Array (',v%data%hash,v%offset - call vector_dump(context,v%data%ptr(v%offset+pm_array_vect),depth+1) - write(*,*) spaces(1:depth*2),') over (' - call vector_dump(context,v%data%ptr(v%offset+pm_array_dom),depth+1) - write(*,*) spaces(1:depth*2),')' + p=v%data%ptr(v%offset+pm_array_vect) + p=p%data%ptr(p%offset) + write(*,*) 'vkind=',pm_fast_vkind(p) + if(pm_fast_vkind(p)==pm_string) then + write(*,*) spaces(1:depth*2),trim(pm_value_as_string(context,p)) + else + write(*,*) spaces(1:depth*2),'Array (',v%data%hash,v%offset + call vector_dump(context,v%data%ptr(v%offset+pm_array_vect),depth+1) + write(*,*) spaces(1:depth*2),') over (' + call vector_dump(context,v%data%ptr(v%offset+pm_array_dom),depth+1) + write(*,*) spaces(1:depth*2),')' + endif case(pm_dref_type,pm_dref_shared_type) if(k==pm_dref_type) then write(*,*) spaces(1:depth*2),'D-ref (' @@ -3993,25 +4114,28 @@ recursive subroutine vector_dump(context,v,depth) call vector_dump(context,v%data%ptr(v%offset+i),depth+1) enddo write(*,*) spaces(1:depth*2),')' - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) tno=full_type(v) - name=pm_typ_vect(context,tno) - name=pm_name_val(context,pm_tv_name(name)) - tno=name%data%i(name%offset) - if(k==pm_struct_type) then - write(*,*) spaces(1:depth*2),'struct ',& - trim(pm_name_as_string(context,tno)),'(' + name=pm_type_vect(context,tno) + if(pm_tv_kind(name)==pm_type_is_tuple) then + write(*,*) spaces(1:depth*2),'(:' + do i=2,pm_fast_esize(v) + call vector_dump(context,v%data%ptr(v%offset+i),depth+2) + enddo + write(*,*) spaces(1:depth*2),':)' else + name=pm_name_val(context,pm_tv_name(name)) + tno=name%data%i(name%offset) write(*,*) spaces(1:depth*2),'rec ',& trim(pm_name_as_string(context,tno)),'(' + do i=1,pm_fast_esize(name) + tno=name%data%i(name%offset+i) + write(*,*) spaces(1:depth*2+2),& + trim(pm_name_as_string(context,tno)),'=' + call vector_dump(context,v%data%ptr(v%offset+i+1),depth+2) + enddo + write(*,*) spaces(1:depth*2),')' endif - do i=1,pm_fast_esize(name) - tno=name%data%i(name%offset+i) - write(*,*) spaces(1:depth*2+2),& - trim(pm_name_as_string(context,tno)),'=' - call vector_dump(context,v%data%ptr(v%offset+i+1),depth+2) - enddo - write(*,*) spaces(1:depth*2),')' case(pm_name) write(*,*) spaces(1:depth*2),'''',trim(pm_name_as_string(context,int(v%offset))) case(pm_proc) @@ -4019,7 +4143,7 @@ recursive subroutine vector_dump(context,v,depth) trim(pm_name_as_string(context,int(v%offset))),'}' case(pm_type) write(*,*) spaces(1:depth*2),'type{',& - trim(pm_typ_as_string(context,int(v%offset))),'}' + trim(pm_type_as_string(context,int(v%offset))),'}' case default call pm_dump_tree(context,6,v,depth) end select @@ -4027,9 +4151,12 @@ recursive subroutine vector_dump(context,v,depth) contains include 'ftypeof.inc' include 'fesize.inc' - + include 'fvkind.inc' end subroutine vector_dump - + + !============================================================================= + ! Dump v using output subroutine output with indent of depth + !============================================================================= recursive subroutine vector_dump_to(context,v,j,output,depth) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v @@ -4054,17 +4181,21 @@ end subroutine output k=pm_fast_typeof(v) select case(k) case(pm_array_type,pm_const_array_type) - call output(context,spaces(1:depth*2)//'Array (') w=v%data%ptr(v%offset+pm_array_vect) w=w%data%ptr(w%offset+j) - esize=vector_esize(w) - do jj=0,min(5,esize) - call vector_dump_to(context,w,jj,output,depth+1) - enddo - if(esize>5) call output(context,spaces(1:depth*2+2)//'...') - call output(context,spaces(1:depth*2)//') over (') - call vector_dump_to(context,v%data%ptr(v%offset+pm_array_dom),j,output,depth+1) - call output(context,spaces(1:depth*2)//')') + if(pm_fast_vkind(w)==pm_string) then + call output(context,spaces(1:depth*2)//trim(pm_value_as_string(context,w))) + else + call output(context,spaces(1:depth*2)//'Array (') + esize=vector_esize(w) + do jj=0,min(5,esize) + call vector_dump_to(context,w,jj,output,depth+1) + enddo + if(esize>5) call output(context,spaces(1:depth*2+2)//'...') + call output(context,spaces(1:depth*2)//') over (') + call vector_dump_to(context,v%data%ptr(v%offset+pm_array_dom),j,output,depth+1) + call output(context,spaces(1:depth*2)//')') + endif case(pm_dref_type,pm_dref_shared_type) if(k==pm_dref_type) then call output(context,spaces(1:depth*2)//'D-ref (') @@ -4075,36 +4206,39 @@ end subroutine output call vector_dump_to(context,v%data%ptr(v%offset+i),j,output,depth+1) enddo call output(context,spaces(1:depth*2)//')') - case(pm_struct_type,pm_rec_type) + case(pm_rec_type) tno=full_type(v) - name=pm_typ_vect(context,tno) - name=pm_name_val(context,pm_tv_name(name)) - tno=name%data%i(name%offset) - if(k==pm_struct_type) then - call output(context,spaces(1:depth*2)//'struct '//& - trim(pm_name_as_string(context,tno))//'(') + name=pm_type_vect(context,tno) + if(pm_tv_kind(name)==pm_type_is_tuple) then + call output(context,spaces(1:depth*2)//'(:') + do i=2,pm_fast_esize(v) + call vector_dump_to(context,v%data%ptr(v%offset+i),j,output,depth+2) + enddo + call output(context,spaces(1:depth*2)//':)') else + name=pm_name_val(context,pm_tv_name(name)) + tno=name%data%i(name%offset) call output(context,spaces(1:depth*2)//'rec '//& trim(pm_name_as_string(context,tno))//'(') + do i=1,pm_fast_esize(name) + name1=name%data%i(name%offset+i) + if(abs(name1)>=sym_d1.and.abs(name1)<=sym_d7) then + call output(context,spaces(1:depth*2+2)//& + achar(iachar('1')+name1-sym_d1)//'=') + else + call output(context,spaces(1:depth*2+2)//& + trim(pm_name_as_string(context,name1))//'=') + endif + call vector_dump_to(context,v%data%ptr(v%offset+i+1),j,output,depth+2) + enddo + call output(context,spaces(1:depth*2)//')') endif - do i=1,pm_fast_esize(name) - name1=name%data%i(name%offset+i) - if(abs(name1)>=sym_d1.and.abs(name1)<=sym_d7) then - call output(context,spaces(1:depth*2+2)//& - achar(iachar('1')+name1-sym_d1)//'=') - else - call output(context,spaces(1:depth*2+2)//& - trim(pm_name_as_string(context,name1))//'=') - endif - call vector_dump_to(context,v%data%ptr(v%offset+i+1),j,output,depth+2) - enddo - call output(context,spaces(1:depth*2)//')') case(pm_name) call output(context,spaces(1:depth*2)//trim(pm_name_as_string(context,int(v%offset)))) case(pm_null) call output(context,spaces(1:depth*2)//'null') case(pm_type) - call output(context,spaces(1:depth*2)//trim(pm_typ_as_string(context,int(v%offset)))) + call output(context,spaces(1:depth*2)//trim(pm_type_as_string(context,int(v%offset)))) case(pm_proc) call output(context,spaces(1:depth*2)//'proc('//& trim(pm_name_as_string(context,int(v%offset)))//')') @@ -4115,17 +4249,18 @@ end subroutine output case(pm_int:pm_complex256) call output(context,spaces(1:depth*2)//trim(pm_number_as_string(context,v,j))) case default - call output(context,spaces(1:depth*2)//'?'//trim(pm_typ_as_string(context,k))) + call output(context,spaces(1:depth*2)//'?'//trim(pm_type_as_string(context,k))) end select contains include 'ftypeof.inc' include 'fesize.inc' - + include 'fvkind.inc' end subroutine vector_dump_to - + !============================================================================= ! Calculate total array vector size from array lengths vector + !============================================================================= function total_size(v) result(siz) type(pm_ptr),intent(in):: v integer(pm_ln):: siz @@ -4134,7 +4269,9 @@ function total_size(v) result(siz) include 'fesize.inc' end function total_size + !============================================================================= ! Check that two vectors of longs are identical + !============================================================================= function all_equal(len,len2) result(ok) type(pm_ptr),intent(in):: len,len2 logical:: ok @@ -4146,8 +4283,10 @@ function all_equal(len,len2) result(ok) include 'fesize.inc' end function all_equal + !============================================================================= ! Calculate array offsets vector for contiguous elements ! from array length vector + !============================================================================= function array_offsets(context,len) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: len @@ -4158,8 +4297,10 @@ function array_offsets(context,len) result(ptr) include 'fesize.inc' end function array_offsets + !============================================================================= ! Calculate array offsets vector for contiguous elements ! from array length vector (set pre-allocated vector) + !============================================================================= subroutine set_offsets(off,len) type(pm_ptr):: len,off integer(pm_ln):: i,s @@ -4172,9 +4313,11 @@ subroutine set_offsets(off,len) include 'fesize.inc' end subroutine set_offsets + !============================================================================= ! For vector of arrays (defined by len(gth) and off(set) vectors) ! and vector of indices, compute vector of locations in array ! element vector + !============================================================================= function index_vector(context,len,off,idx,ve,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: len,off,idx,ve @@ -4198,9 +4341,11 @@ function index_vector(context,len,off,idx,ve,errno) result(ptr) include 'fesize.inc' end function index_vector + !============================================================================= ! For vector of arrays (defined by len(gth) and off(set) vectors) ! and vector of indices, combined with indirection vector, ! compute vector of locations in array element vector + !============================================================================= function index_vector_indirect(context,len,off,idx,ind,ve,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: len,off,idx,ind,ve @@ -4226,9 +4371,11 @@ function index_vector_indirect(context,len,off,idx,ind,ve,errno) result(ptr) include 'ftypeof.inc' end function index_vector_indirect + !============================================================================= ! For vector of arrays (defined by len(gth) and off(set) vectors) ! and vector of indices, compute vector of locations in array ! element vector, excluding inactive locations (as defined by ve) + !============================================================================= function index_vector_used(context,len,off,idx,ve,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: len,off,idx,ve @@ -4291,7 +4438,9 @@ function index_vector_used(context,len,off,idx,ve,errno) result(ptr) include 'fvkind.inc' end function index_vector_used + !============================================================================= ! Compute indices for all elements in an array + !============================================================================= function index_vector_all(context,len,off) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: len,off @@ -4313,8 +4462,10 @@ function index_vector_all(context,len,off) result(ptr) include 'fesize.inc' end function index_vector_all + !============================================================================= ! For vector of arrays defined by (len,off) and vector of arrays of indices - ! defined by (len2[disp...],idx), calculate vector of array element locations + ! defined by (len2[disp...],idx), calculate vector of array element locations + !============================================================================= function index_vector_nested(context,len,off,idx,import_vec,errno) result(ptr) type(pm_context),pointer:: context type(pm_ptr),intent(in):: len,off,idx,import_vec @@ -4353,18 +4504,22 @@ function index_vector_nested(context,len,off,idx,import_vec,errno) result(ptr) include 'fesize.inc' end function index_vector_nested - function vector_make_string(context,ve,v,buf_size,fmt) result(str) + !============================================================================= + ! Apply fmt to each element of v to create vector of strings + !============================================================================= + function vector_make_string(context,ve,v,buf_size,fmt,wid,ndp) result(str) type(pm_context),pointer:: context type(pm_ptr),intent(in):: ve,v integer,intent(in):: buf_size + type(pm_ptr),intent(in),optional:: wid,ndp type(pm_ptr):: str - integer(pm_ln):: vsize,esize,i,j,jj,k + integer(pm_ln):: vsize,esize,i,j,jj,k,n interface - subroutine fmt(xv,xk,xs) + subroutine fmt(xv,xk,xn,xs) use pm_kinds use pm_memory type(pm_ptr),intent(in):: xv - integer(pm_ln),intent(in):: xk + integer(pm_ln),intent(in):: xk,xn character(len=*),intent(out):: xs end subroutine fmt end interface @@ -4382,9 +4537,15 @@ end subroutine fmt j=0 do i=0,vsize k=ve%data%ln(ve%offset+i) - call fmt(v,k,mess) - vec%data%ptr(vec%offset+k)=pm_new_string(context,trim(mess)) - len%data%ln(len%offset+k)=len_trim(mess) + if(present(ndp)) n=ndp%data%ln(ndp%offset+k) + call fmt(v,k,n,mess) + if(present(wid)) then + vec%data%ptr(vec%offset+k)=pm_new_string_of_width(context,trim(mess),wid%data%ln(wid%offset+k)) + len%data%ln(len%offset+k)=abs(wid%data%ln(wid%offset+k)) + else + vec%data%ptr(vec%offset+k)=pm_new_string(context,trim(mess)) + len%data%ln(len%offset+k)=len_trim(mess) + endif enddo str=make_array(context,pm_array_type,int(pm_string_type),vec,len,len,off) call pm_delete_register(context,reg) @@ -4392,6 +4553,117 @@ end subroutine fmt include 'fesize.inc' end function vector_make_string + ! Integer format + subroutine fmt_i(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=10):: mess + mess=' ' + write(mess,'(i10)') v%data%i(v%offset+n) + str=adjustl(mess) + end subroutine fmt_i + + ! Long integer format + subroutine fmt_ln(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=20):: mess + mess=' ' + write(mess,'(i20)') v%data%ln(v%offset+n) + str=adjustl(mess) + end subroutine fmt_ln + + + subroutine fmt_lln(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=25):: mess + mess=' ' + write(mess,'(i25)') v%data%lln(v%offset+n) + str=adjustl(mess) + end subroutine fmt_lln + + subroutine fmt_i32(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=10):: mess + mess=' ' + write(mess,'(i10)') v%data%i32(v%offset+n) + str=adjustl(mess) + end subroutine fmt_i32 + + subroutine fmt_i64(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=20):: mess + mess=' ' + write(mess,'(i20)') v%data%i64(v%offset+n) + str=adjustl(mess) + end subroutine fmt_i64 + + subroutine fmt_r(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=15):: mess + mess=' ' + write(mess,'(g15.8)') v%data%r(v%offset+n) + str=adjustl(mess) + end subroutine fmt_r + + subroutine fmt_d(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=25):: mess + mess=' ' + write(mess,'(g25.15)') v%data%d(v%offset+n) + str=adjustl(mess) + end subroutine fmt_d + + subroutine fmt_l(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + if(v%data%l(v%offset+n)) then + str='TRUE ' + else + str='FALSE ' + endif + end subroutine fmt_l + + subroutine fmt_r_dp(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=15):: mess,fmt + mess=' ' + write(fmt,'("(G15.",i2,")")') min(abs(m),10) + write(mess,fmt=fmt) v%data%r(v%offset+n) + str=adjustl(mess) + end subroutine fmt_r_dp + + subroutine fmt_d_dp(v,n,m,str) + type(pm_ptr),intent(in):: v + integer(pm_ln),intent(in):: n,m + character(len=*),intent(out):: str + character(len=25):: mess,fmt + mess=' ' + write(fmt,'("(G25.",i2,")")') min(abs(m),20) + write(mess,fmt=fmt) v%data%d(v%offset+n) + str=adjustl(mess) + end subroutine fmt_d_dp + + + !================================================================================= + ! Concatenate strings in each element of v1 and v2: str <- v1 ++ v2 masked by ve + ! -- ve must be shrunk + !================================================================================== function vector_concat_string(context,ve,v1,v2) result(str) type(pm_context),pointer:: context type(pm_ptr),intent(in):: ve,v1,v2 @@ -4437,6 +4709,9 @@ function vector_concat_string(context,ve,v1,v2) result(str) include 'fesize.inc' end function vector_concat_string + !============================================================================= + ! Get string for v[ve[i] where ve must be shrunk + !============================================================================= subroutine vector_get_string(context,v,ve,i,str) type(pm_context),pointer:: context type(pm_ptr),intent(in):: v,ve @@ -4461,7 +4736,10 @@ subroutine vector_get_string(context,v,ve,i,str) contains include 'fesize.inc' end subroutine vector_get_string - + + !============================================================================= + ! Make a vector of unitialised strings + !============================================================================= function make_string_vector(context,val,esize) result(str) type(pm_context),pointer:: context type(pm_ptr),intent(in):: val @@ -4471,365 +4749,294 @@ function make_string_vector(context,val,esize) result(str) type(pm_reg),pointer:: reg reg=>pm_register(context,'make_str',len,off,vec) len=pm_new(context,pm_long,esize+1) - len%data%ln(len%offset:len%offset+esize)=pm_fast_esize(val) + len%data%ln(len%offset:len%offset+esize)=pm_fast_esize(val)+1 off=pm_new(context,pm_long,esize+1) off%data%ln(off%offset:off%offset+esize)=0 vec=pm_new(context,pm_pointer,esize+1) - vec%data%ptr(vec%offset:vec%offset+esize)=val + if(pm_fast_esize(val)<0) then + vec%data%ptr(vec%offset:vec%offset+esize)=pm_fast_newnc(context,pm_string,1) + else + vec%data%ptr(vec%offset:vec%offset+esize)=val + endif str=make_array(context,pm_array_type,int(pm_string_type),vec,len,len,off) call pm_delete_register(context,reg) contains include 'fnewnc.inc' include 'fesize.inc' end function make_string_vector - - subroutine fmt_i(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=10):: mess - mess=' ' - write(mess,'(i10)') v%data%i(v%offset+n) - str=adjustl(mess) - end subroutine fmt_i - - subroutine fmt_ln(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=20):: mess - mess=' ' - write(mess,'(i20)') v%data%ln(v%offset+n) - str=adjustl(mess) - end subroutine fmt_ln - - subroutine fmt_lln(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=25):: mess - mess=' ' - write(mess,'(i25)') v%data%lln(v%offset+n) - str=adjustl(mess) - end subroutine fmt_lln - - subroutine fmt_i32(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=10):: mess - mess=' ' - write(mess,'(i10)') v%data%i32(v%offset+n) - str=adjustl(mess) - end subroutine fmt_i32 - - subroutine fmt_i64(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=20):: mess - mess=' ' - write(mess,'(i20)') v%data%i64(v%offset+n) - str=adjustl(mess) - end subroutine fmt_i64 - subroutine fmt_r(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=15):: mess - mess=' ' - write(mess,'(g15.8)') v%data%r(v%offset+n) - str=adjustl(mess) - end subroutine fmt_r - - subroutine fmt_d(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - character(len=25):: mess - mess=' ' - write(mess,'(g25.15)') v%data%d(v%offset+n) - str=adjustl(mess) - end subroutine fmt_d - - subroutine fmt_l(v,n,str) - type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n - character(len=*),intent(out):: str - if(v%data%l(v%offset+n)) then - str='TRUE ' - else - str='FALSE ' - endif - end subroutine fmt_l +!!$ subroutine advance_dim(val,max,overflow,n) +!!$ integer(pm_ln),dimension(*),intent(inout):: val,max +!!$ integer(pm_ln),dimension(*),intent(inout):: overflow +!!$ integer(pm_ln),intent(in):: n +!!$ integer(pm_ln):: i +!!$ do i=1,n +!!$ val(i)=val(i)+overflow(i) +!!$ enddo +!!$ do i=1,n +!!$ overflow(i)=merge(1_pm_ln,0_pm_ln,val(i)>=max(i)) +!!$ val(i)=merge(0_pm_ln,val(i),val(i)>=max(i)) +!!$ enddo +!!$ end subroutine advance_dim +!!$ +!!$ function advance(context,val,max,ok) result(mask) +!!$ type(pm_context),pointer:: context +!!$ type(pm_ptr),intent(inout):: val +!!$ type(pm_ptr),intent(in)::max +!!$ type(pm_ptr),intent(in),optional:: ok +!!$ type(pm_ptr):: mask +!!$ integer(pm_ln),allocatable,dimension(:):: overflow +!!$ integer(pm_ln):: i,esize +!!$ integer:: j +!!$ type(pm_ptr):: v,m +!!$ esize=pm_fast_esize(val%data%ptr(val%offset+2)) +!!$ allocate(overflow(0:esize)) +!!$ overflow=1 +!!$ do j=2,pm_fast_esize(val) +!!$ v=val%data%ptr(val%offset+j) +!!$ m=max%data%ptr(max%offset+j) +!!$ call advance_dim(v%data%ln(v%offset:),m%data%ln(m%offset:),overflow,esize+1) +!!$ enddo +!!$ mask=pm_new(context,pm_logical,esize+1) +!!$ if(present(ok)) then +!!$ do i=0,esize +!!$ mask%data%l(mask%offset+i)=overflow(i)==0.and.ok%data%l(ok%offset+i) +!!$ enddo +!!$ else +!!$ do i=0,esize +!!$ mask%data%l(mask%offset+i)=overflow(i)==0 +!!$ enddo +!!$ endif +!!$ deallocate(overflow) +!!$ contains +!!$ include 'fesize.inc' +!!$ end function advance +!!$ +!!$ function init_loop(context,v) result(w) +!!$ type(pm_context),pointer:: context +!!$ type(pm_ptr),intent(in):: v +!!$ type(pm_ptr):: w +!!$ integer(pm_ln):: esize,n,i +!!$ type(pm_ptr):: p +!!$ type(pm_root),pointer:: root +!!$ esize=pm_fast_esize(v%data%ptr(v%offset+2)) +!!$ n=pm_fast_esize(v) +!!$ root=>pm_new_as_root(context,pm_usr,n) +!!$ w=root%ptr +!!$ w%data%ptr(w%offset)=v%data%ptr(v%offset) +!!$ w%data%ptr(w%offset+1)=v%data%ptr(v%offset+1) +!!$ do i=2,n +!!$ p=pm_assign_new(context,w,i,pm_long,esize+1,.false.) +!!$ p%data%ln(p%offset:p%offset+esize)=0 +!!$ enddo +!!$ call pm_delete_root(context,root) +!!$ contains +!!$ include 'fesize.inc' +!!$ end function init_loop - subroutine advance_dim(val,max,overflow,n) - integer(pm_ln),dimension(*),intent(inout):: val,max - integer(pm_ln),dimension(*),intent(inout):: overflow - integer(pm_ln),intent(in):: n - integer(pm_ln):: i - do i=1,n - val(i)=val(i)+overflow(i) - enddo - do i=1,n - overflow(i)=merge(1_pm_ln,0_pm_ln,val(i)>=max(i)) - val(i)=merge(0_pm_ln,val(i),val(i)>=max(i)) - enddo - end subroutine advance_dim - - function advance(context,val,max,ok) result(mask) - type(pm_context),pointer:: context - type(pm_ptr),intent(inout):: val - type(pm_ptr),intent(in)::max - type(pm_ptr),intent(in),optional:: ok - type(pm_ptr):: mask - integer(pm_ln),allocatable,dimension(:):: overflow - integer(pm_ln):: i,esize - integer:: j - type(pm_ptr):: v,m - esize=pm_fast_esize(val%data%ptr(val%offset+2)) - allocate(overflow(0:esize)) - overflow=1 - do j=2,pm_fast_esize(val) - v=val%data%ptr(val%offset+j) - m=max%data%ptr(max%offset+j) - call advance_dim(v%data%ln(v%offset:),m%data%ln(m%offset:),overflow,esize+1) - enddo - mask=pm_new(context,pm_logical,esize+1) - if(present(ok)) then - do i=0,esize - mask%data%l(mask%offset+i)=overflow(i)==0.and.ok%data%l(ok%offset+i) - enddo - else - do i=0,esize - mask%data%l(mask%offset+i)=overflow(i)==0 - enddo - endif - deallocate(overflow) - contains - include 'fesize.inc' - end function advance - - function init_loop(context,v) result(w) - type(pm_context),pointer:: context - type(pm_ptr),intent(in):: v - type(pm_ptr):: w - integer(pm_ln):: esize,n,i - type(pm_ptr):: p - type(pm_root),pointer:: root - esize=pm_fast_esize(v%data%ptr(v%offset+2)) - n=pm_fast_esize(v) - root=>pm_new_as_root(context,pm_usr,n) - w=root%ptr - w%data%ptr(w%offset)=v%data%ptr(v%offset) - w%data%ptr(w%offset+1)=v%data%ptr(v%offset+1) - do i=2,n - p=pm_assign_new(context,w,i,pm_long,esize+1,.false.) - p%data%ln(p%offset:p%offset+esize)=0 - enddo - call pm_delete_root(context,root) - contains - include 'fesize.inc' - end function init_loop +!!$ recursive function ptr_vec_get_type(context,& +!!$ vec,disps,start,finish) result(outvec) +!!$ type(pm_context),pointer:: context +!!$ type(pm_ptr),intent(in):: vec,disps +!!$ integer(pm_ln):: start,finish +!!$ type(pm_ptr):: outvec +!!$ integer(pm_ln):: esize,j,k,n +!!$ integer:: vkind +!!$ type(pm_ptr):: p,pvec +!!$ type(pm_root),pointer:: root1,root2 +!!$ p=vec%data%ptr(vec%offset) +!!$ vkind=pm_fast_vkind(p) +!!$ esize=finish-start +!!$ select case(vkind) +!!$ case(pm_int) +!!$ outvec=pm_new(context,pm_int,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%i(outvec%offset+j)=& +!!$ p%data%i(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_long) +!!$ outvec=pm_new(context,pm_long,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%ln(outvec%offset+j)=& +!!$ p%data%ln(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_int8) +!!$ outvec=pm_new(context,pm_int8,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%i8(outvec%offset+j)=& +!!$ p%data%i8(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_int16) +!!$ outvec=pm_new(context,pm_int16,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%i16(outvec%offset+j)=& +!!$ p%data%i16(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_int32) +!!$ outvec=pm_new(context,pm_int32,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%i32(outvec%offset+j)=& +!!$ p%data%i32(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_int64) +!!$ outvec=pm_new(context,pm_int64,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%i64(outvec%offset+j)=& +!!$ p%data%i64(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_int128) +!!$ outvec=pm_new(context,pm_int128,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%i128(outvec%offset+j)=& +!!$ p%data%i128(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_single) +!!$ outvec=pm_new(context,pm_single,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%r(outvec%offset+j)=& +!!$ p%data%r(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_double) +!!$ outvec=pm_new(context,pm_double,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%d(outvec%offset+j)=& +!!$ p%data%d(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_real32) +!!$ outvec=pm_new(context,pm_real32,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%r32(outvec%offset+j)=& +!!$ p%data%r32(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_real64) +!!$ outvec=pm_new(context,pm_real64,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%r64(outvec%offset+j)=& +!!$ p%data%r64(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_real128) +!!$ outvec=pm_new(context,pm_real128,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%r128(outvec%offset+j)=& +!!$ p%data%r128(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_single_complex) +!!$ outvec=pm_new(context,pm_single_complex,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%c(outvec%offset+j)=& +!!$ p%data%c(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_double_complex) +!!$ outvec=pm_new(context,pm_double_complex,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%dc(outvec%offset+j)=& +!!$ p%data%dc(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_complex64) +!!$ outvec=pm_new(context,pm_complex64,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%c64(outvec%offset+j)=& +!!$ p%data%c64(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_complex128) +!!$ outvec=pm_new(context,pm_complex128,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%c128(outvec%offset+j)=& +!!$ p%data%c128(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_complex256) +!!$ outvec=pm_new(context,pm_complex256,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%c256(outvec%offset+j)=& +!!$ p%data%c256(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_logical) +!!$ outvec=pm_new(context,pm_logical,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%l(outvec%offset+j)=& +!!$ p%data%l(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_packed_logical) +!!$ outvec=pm_new(context,pm_packed_logical,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%pl(outvec%offset+j)=& +!!$ p%data%pl(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_undef:pm_null,pm_pointer:pm_stack) +!!$ outvec=pm_new(context,pm_pointer,esize) +!!$ k=0 +!!$ do j=0,esize +!!$ p=vec%data%ptr(vec%offset+j+start) +!!$ outvec%data%ptr(outvec%offset+j)=& +!!$ p%data%ptr(p%offset+disps%data%ln(disps%offset+j)) +!!$ enddo +!!$ case(pm_usr) +!!$ n=pm_fast_esize(vec%data%ptr(vec%offset)) +!!$ root1=>pm_new_as_root(context,pm_pointer,n) +!!$ root2=>pm_new_as_root(context,pm_pointer,esize) +!!$ outvec=root1%ptr +!!$ pvec=root2%ptr +!!$ do j=1,n +!!$ do k=0,esize +!!$ p=vec%data%ptr(vec%offset+k+start) +!!$ pvec%data%ptr(pvec%offset+k)=p%data%ptr(p%offset+j) +!!$ enddo +!!$ call pm_ptr_assign(context,outvec,j,& +!!$ ptr_vec_get_type(context,pvec,disps,0_pm_ln,esize)) +!!$ enddo +!!$ call pm_delete_root(context,root1) +!!$ call pm_delete_root(context,root2) +!!$ end select +!!$ contains +!!$ include 'fvkind.inc' +!!$ include 'fesize.inc' +!!$ end function ptr_vec_get_type - recursive function ptr_vec_get_type(context,& - vec,disps,start,finish) result(outvec) - type(pm_context),pointer:: context - type(pm_ptr),intent(in):: vec,disps - integer(pm_ln):: start,finish - type(pm_ptr):: outvec - integer(pm_ln):: esize,j,k,n - integer:: vkind - type(pm_ptr):: p,pvec - type(pm_root),pointer:: root1,root2 - p=vec%data%ptr(vec%offset) - vkind=pm_fast_vkind(p) - esize=finish-start - select case(vkind) - case(pm_int) - outvec=pm_new(context,pm_int,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%i(outvec%offset+j)=& - p%data%i(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_long) - outvec=pm_new(context,pm_long,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%ln(outvec%offset+j)=& - p%data%ln(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_int8) - outvec=pm_new(context,pm_int8,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%i8(outvec%offset+j)=& - p%data%i8(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_int16) - outvec=pm_new(context,pm_int16,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%i16(outvec%offset+j)=& - p%data%i16(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_int32) - outvec=pm_new(context,pm_int32,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%i32(outvec%offset+j)=& - p%data%i32(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_int64) - outvec=pm_new(context,pm_int64,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%i64(outvec%offset+j)=& - p%data%i64(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_int128) - outvec=pm_new(context,pm_int128,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%i128(outvec%offset+j)=& - p%data%i128(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_single) - outvec=pm_new(context,pm_single,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%r(outvec%offset+j)=& - p%data%r(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_double) - outvec=pm_new(context,pm_double,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%d(outvec%offset+j)=& - p%data%d(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_real32) - outvec=pm_new(context,pm_real32,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%r32(outvec%offset+j)=& - p%data%r32(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_real64) - outvec=pm_new(context,pm_real64,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%r64(outvec%offset+j)=& - p%data%r64(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_real128) - outvec=pm_new(context,pm_real128,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%r128(outvec%offset+j)=& - p%data%r128(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_single_complex) - outvec=pm_new(context,pm_single_complex,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%c(outvec%offset+j)=& - p%data%c(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_double_complex) - outvec=pm_new(context,pm_double_complex,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%dc(outvec%offset+j)=& - p%data%dc(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_complex64) - outvec=pm_new(context,pm_complex64,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%c64(outvec%offset+j)=& - p%data%c64(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_complex128) - outvec=pm_new(context,pm_complex128,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%c128(outvec%offset+j)=& - p%data%c128(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_complex256) - outvec=pm_new(context,pm_complex256,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%c256(outvec%offset+j)=& - p%data%c256(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_logical) - outvec=pm_new(context,pm_logical,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%l(outvec%offset+j)=& - p%data%l(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_packed_logical) - outvec=pm_new(context,pm_packed_logical,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%pl(outvec%offset+j)=& - p%data%pl(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_undef:pm_null,pm_pointer:pm_stack) - outvec=pm_new(context,pm_pointer,esize) - k=0 - do j=0,esize - p=vec%data%ptr(vec%offset+j+start) - outvec%data%ptr(outvec%offset+j)=& - p%data%ptr(p%offset+disps%data%ln(disps%offset+j)) - enddo - case(pm_usr) - n=pm_fast_esize(vec%data%ptr(vec%offset)) - root1=>pm_new_as_root(context,pm_pointer,n) - root2=>pm_new_as_root(context,pm_pointer,esize) - outvec=root1%ptr - pvec=root2%ptr - do j=1,n - do k=0,esize - p=vec%data%ptr(vec%offset+k+start) - pvec%data%ptr(pvec%offset+k)=p%data%ptr(p%offset+j) - enddo - call pm_ptr_assign(context,outvec,j,& - ptr_vec_get_type(context,pvec,disps,0_pm_ln,esize)) - enddo - call pm_delete_root(context,root1) - call pm_delete_root(context,root2) - end select - contains - include 'fvkind.inc' - include 'fesize.inc' - end function ptr_vec_get_type - + !============================================================================= + ! Shrink a ve to the list-of-indices form + ! - Convert logical mask to vector of active indices + ! - Convert null make to vecror of consecutive indices + ! - Leave a list of indices alone + !============================================================================= function shrink_ve(context,mask,esize,n) result(ind) type(pm_context),pointer:: context type(pm_ptr),intent(in):: mask @@ -4869,18 +5076,25 @@ function shrink_ve(context,mask,esize,n) result(ind) include 'fisnull.inc' include 'ftiny.inc' end function shrink_ve - + + !============================================================================= + ! Return the type of an interpreter object + !============================================================================= function full_type(v) result(tno) type(pm_ptr):: v integer:: tno tno=pm_fast_typeof(v) - if(tno>=pm_struct_type) then + if(tno>=pm_rec_type) then tno=v%data%ptr(v%offset+1_pm_p)%offset endif contains include 'ftypeof.inc' end function full_type + !============================================================================= + ! Compute intersection of two monotonic sequences a1(1:n1) and a2(1:n1) + ! with result stored in a3(1:n3) -- a3 must have enough space + !============================================================================= subroutine intersect_aseq(a1,n1,a2,n2,a3,n3) integer(pm_ln),dimension(*),intent(in):: a1,a2 integer(pm_ln),intent(in):: n1,n2 @@ -4970,6 +5184,9 @@ subroutine intersect_aseq(a1,n1,a2,n2,a3,n3) endif end subroutine intersect_aseq + !============================================================================= + ! Check if monotonic sequenc a1(1:n1) includes monotonic sequence a2(1:n2) + !============================================================================= function aseq_includes(a1,n1,a2,n2) result(ok) integer(pm_ln),dimension(*),intent(in):: a1,a2 integer(pm_ln),intent(in):: n1,n2 @@ -5042,6 +5259,9 @@ function aseq_includes(a1,n1,a2,n2) result(ok) endif end function aseq_includes + !============================================================================= + ! Find index of v in monotonic sequence a(1:n) + !============================================================================= function aseq_index(a,n,v) result(index) integer(pm_ln),dimension(*),intent(in):: a integer(pm_ln),intent(in):: n @@ -5080,6 +5300,10 @@ function aseq_index(a,n,v) result(index) endif end function aseq_index + !================================================================================ + ! a3(1:n3) is set to a vector of indices of elements of monotonic sequence + ! a2(1:n2) in monotic sequnce a1(1:n1), excluding elements of a2 not found in a1 + !================================================================================ subroutine overlap_aseq(a1,n1,a2,n2,a3,n3) integer(pm_ln),dimension(*),intent(in):: a1,a2 integer(pm_ln),intent(in):: n1,n2 @@ -5169,6 +5393,10 @@ subroutine overlap_aseq(a1,n1,a2,n2,a3,n3) endif end subroutine overlap_aseq + !============================================================================= + ! Set a3 to overlap of a1 and a2 and a4 to overlap of a2 and a1 + ! where overlap is as defined for overlap_aseq + !============================================================================= subroutine overlap_aseq2(a1,n1,a2,n2,a3,a4,n3) integer(pm_ln),dimension(*),intent(in):: a1,a2 integer(pm_ln),intent(in):: n1,n2 @@ -5261,7 +5489,12 @@ subroutine overlap_aseq2(a1,n1,a2,n2,a3,a4,n3) endif endif end subroutine overlap_aseq2 - + + !============================================================================= + ! Intersect two blocked sequences (l1..h1 by st1 width wd1) and + ! (l2..h3 by st2 width wd2) giving sequence a(1:n) + ! - array a must have enough space + !============================================================================= subroutine intersect_bseq(l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2,a,n) integer(pm_ln),intent(in):: l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2 integer(pm_ln),dimension(*),intent(out):: a @@ -5358,6 +5591,13 @@ subroutine intersect_bseq(l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2,a,n) n=k-1 end subroutine intersect_bseq + + !============================================================================= + ! Overlap two blocked sequences (l1..h1 by st1 width wd1) and + ! (l2..h3 by st2 width wd2) giving sequence a(1:n) of indices of second sequence + ! in the first sequence + ! - array a must have enough space + !============================================================================= subroutine overlap_bseq(l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2,a,n) integer(pm_ln),intent(in):: l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2 integer(pm_ln),dimension(*),intent(out):: a @@ -5466,6 +5706,13 @@ subroutine overlap_bseq(l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2,a,n) n=k-1 end subroutine overlap_bseq + !============================================================================= + ! Overlap two blocked sequences (l1..h1 by st1 width wd1) and + ! (l2..h3 by st2 width wd2) giving sequences a1(1:n) of indices of second sequence + ! in the first sequence and a2(1:n) of indices of first sequence in the second + ! sequence + ! - arrays a1 and a2 must have enough space + !============================================================================= subroutine overlap_bseq2(l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2,a1,a2,n) integer(pm_ln),intent(in):: l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2 integer(pm_ln),dimension(*),intent(out):: a1,a2 @@ -5602,6 +5849,11 @@ subroutine overlap_bseq2(l1,h1,wd1,st1,al1,l2,h2,wd2,st2,al2,a1,a2,n) n=k-1 end subroutine overlap_bseq2 + !============================================================================= + ! Replace each element x of a1(1:n1) by x+lo..x+hi creating sequence a2(1:n2) + ! eliminating any repeating elements + ! - a2 must have enough space + !============================================================================= subroutine expand_aseq(a1,n1,lo,hi,a2,n2) integer(pm_ln),dimension(*),intent(in):: a1 integer(pm_ln),intent(in):: n1,lo,hi @@ -5675,7 +5927,11 @@ subroutine interior_index_aseq(a1,lo,hi,a2,n) a2(i)=k enddo end subroutine interior_index_aseq - + + !============================================================================= + ! Intersecrion of two sequences (l1..u1 by s1) with length n1 and + ! (l2..u2 by s2) with length n2 giving sequence (l3..u3 by s3) of length n3 + !============================================================================= subroutine intersect_seq(l1,u1,s1,n1,l2,u2,s2,n2,l3,u3,s3,n3) integer(pm_ln),intent(in):: l1,u1,s1,n1,l2,u2,s2,n2 integer(pm_ln),intent(out):: l3,u3,s3,n3 @@ -5726,6 +5982,10 @@ subroutine intersect_seq(l1,u1,s1,n1,l2,u2,s2,n2,l3,u3,s3,n3) endif end subroutine intersect_seq + !============================================================================= + ! Extended GCD algorithm + ! find g, u and v such that ua + vb = g + !============================================================================= subroutine extended_gcd(a,b,u,v,g) integer(pm_ln),intent(in):: a,b integer(pm_ln),intent(out):: u,v,g @@ -5755,7 +6015,5 @@ subroutine extended_gcd(a,b,u,v,g) g=old_r end subroutine extended_gcd - - end module pm_array diff --git a/src/ast.f90 b/src/ast.f90 new file mode 100644 index 0000000..a6726ea --- /dev/null +++ b/src/ast.f90 @@ -0,0 +1,479 @@ +! +! PM (Parallel Models) Programming Language +! +! Released under the MIT License (MIT) +! +! Copyright (c) Tim Bellerby, 2024 +! +! Permission is hereby granted, free of charge, to any person obtaining a copy +! of this software and associated documentation files (the "Software"), to deal +! in the Software without restriction, including without limitation the rights +! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is +! furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in +! all copies or substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +! THE SOFTWARE. + +! Definitions for abstract syntax tree +! and some more general definition of flag values etc. + +module pm_ast + use pm_sysdep + use pm_compbase + use pm_kinds + use pm_memory + use pm_lib + use pm_options + use pm_hash + use pm_symbol + use pm_vmdefs + use pm_types + + ! Langauge features + integer,parameter:: num_comm_args=6 + + ! Offsets into module objects + integer,parameter:: modl_name=1 + integer,parameter:: modl_link=2 + integer,parameter:: modl_last=3 + integer,parameter:: modl_stmts=4 + integer,parameter:: modl_include=5 + integer,parameter:: modl_proc=6 + integer,parameter:: modl_type=7 + integer,parameter:: modl_param=8 + integer,parameter:: modl_local=3 + + ! Offsets into parser node objects of various kinds + integer,parameter:: node_magic=0 + integer,parameter:: node_symbol=1 + integer,parameter:: node_modl=2 + integer,parameter:: node_lineno=3 + integer,parameter:: node_charno=4 + integer,parameter:: node_args=5 + + ! Type parse nodes + integer,parameter:: type_name=node_args + integer,parameter:: type_number=node_args+1 + integer,parameter:: type_module=node_args+2 + integer,parameter:: type_params=node_args+3 + integer,parameter:: type_constraints=node_args+4 + integer,parameter:: type_link=node_args+5 + integer,parameter:: type_parents=node_args+6 + integer,parameter:: type_includes=node_args+7 + integer,parameter:: type_num_args=8 + + ! Proc parse nodes + integer,parameter:: proc_name=node_args + integer,parameter:: proc_link=node_args+1 + integer,parameter:: proc_module=node_args+2 + integer,parameter:: proc_flags=node_args+3 + integer,parameter:: proc_params=node_args+4 + integer,parameter:: proc_keys=node_args+5 + integer,parameter:: proc_amplocs=node_args+6 + integer,parameter:: proc_when=node_args+7 + integer,parameter:: proc_coded_results=node_args+8 + integer,parameter:: proc_coded_type=node_args+9 + integer,parameter:: proc_numret=node_args+10 + integer,parameter:: proc_result_types=node_args+11 + + ! Alternative final sections for 'proc' parse nodes + + ! - user procs + integer,parameter:: proc_reduce=node_args+12 + integer,parameter:: proc_check=node_args+13 + integer,parameter:: proc_result=node_args+14 + integer,parameter:: proc_stmts=node_args+15 + integer,parameter:: proc_code_tree=node_args+16 + integer,parameter:: proc_num_args=17 + + ! - built in procs + integer,parameter:: proc_retas=node_args+12 + integer,parameter:: proc_opcode=node_args+13 + integer,parameter:: proc_opcode2=node_args+14 + integer,parameter:: proc_data=node_args+15 + integer,parameter:: proc_coded_builtin=node_args+16 + integer,parameter:: sysproc_num_args=17 + + ! Values for proc flags + integer,parameter:: proccall_is_comm= 1 + integer,parameter:: proccall_is_ref = 2 + integer,parameter:: proccall_is_general = 4 + integer,parameter:: proccall_is_block = 8 + + integer,parameter:: proccall_is_inline= 16 + integer,parameter:: proccall_is_no_inline= 32 + integer,parameter:: proccall_is_yield= 64 + + integer,parameter:: proccall_is_lhs= 128 + integer,parameter:: proc_is_cond= 256 + integer,parameter:: proc_is_uncond= 512 + integer,parameter:: proc_run_complete= 2**10 + integer,parameter:: proc_run_local= 2**11 + integer,parameter:: proc_run_shared= 2**12 + integer,parameter:: proc_run_always= 2**13 + integer,parameter:: proc_is_open= 2**14 + integer,parameter:: proc_is_abstract= 2**15 + integer,parameter:: proc_is_generator = 2**16 + integer,parameter:: proc_needs_type = 2**17 + integer,parameter:: proc_is_recursive = 2**18 + integer,parameter:: proc_unfinished = 2**19 + + integer,parameter:: proc_is_impure = 2**20 + integer,parameter:: proc_is_not_inlinable = 2**21 + integer,parameter:: proc_has_for = 2**22 + integer,parameter:: proc_is_not_pure_each = 2**23 + integer,parameter:: proc_has_vkeys = 2**24 + integer,parameter:: proc_is_dcomm = 2**25 + integer,parameter:: proc_is_file = 2**26 + integer,parameter:: proc_prints_out = 2**27 + + ! Proc flags that can be taken as taints + integer,parameter:: proc_taints = proc_is_impure & + + proc_is_not_inlinable + proc_has_for & + + proc_is_dcomm + proc_is_file & + + proc_prints_out + + integer,parameter:: proc_must_run= proc_is_dcomm & + + proc_is_file + proc_prints_out + + ! Flags for proc calls + integer,parameter:: call_ignore_rules= 512 + integer,parameter:: call_is_fixed = 2**10 + integer,parameter:: call_is_assign_call = 2**11 + integer,parameter:: call_is_vararg = 2**12 + integer,parameter:: call_inline_when_compiling = 2**13 + integer,parameter:: call_dup_result = 2**14 + integer,parameter:: call_is_cond = 2**15 + integer,parameter:: call_is_no_touch = 2**16 + integer,parameter:: call_is_unlabelled = 2**17 + integer,parameter:: call_takes_uninit = 2**18 + integer,parameter:: call_converts_uninit = 2**19 + integer,parameter:: call_keep_literals = 2**20 + +contains + + !====================================================== + ! Check that a node is valid + !====================================================== + subroutine check_node(node) + type(pm_ptr),intent(in):: node + if(pm_fast_vkind(node)==pm_pointer) then + if(node%data%ptr(node%offset)%offset/=9876) then + call pm_panic('Bad parse node') + endif + endif + contains + include 'fvkind.inc' + end subroutine check_node + + !======================================================= + ! Check that a node is valid and not a tiny int or value + !======================================================= + subroutine check_ptr_node(node) + type(pm_ptr),intent(in):: node + if(pm_fast_vkind(node)==pm_pointer) then + if(node%data%ptr(node%offset)%offset/=9876) then + call pm_panic('Bad parse node') + endif + else + call pm_panic('not ptr parser node') + endif + contains + include 'fvkind.inc' + end subroutine check_ptr_node + + !====================================================== + ! Return symbol associated with a node + !====================================================== + function node_sym(node) result(n) + type(pm_ptr),intent(in):: node + integer:: n + if(pm_fast_vkind(node)/=pm_pointer) then + n=0 + else + if(pm_debug_checks) call check_node(node) + n=node%data%ptr(node%offset+node_symbol)%offset + endif + contains + include 'fvkind.inc' + end function node_sym + + !====================================================== + ! Number of arguments in a node + !====================================================== + function node_numargs(node) result(n) + type(pm_ptr),intent(in):: node + integer:: n + if(pm_fast_vkind(node)/=pm_pointer) then + n=0 + else + if(pm_debug_checks) call check_node(node) + n=pm_fast_esize(node)-node_args+1 + endif + contains + include 'fesize.inc' + include 'fvkind.inc' + end function node_numargs + + !====================================================== + ! Return n-th argument of a node + !====================================================== + function node_arg(node,n) result(p) + type(pm_ptr),intent(in):: node + integer,intent(in):: n + type(pm_ptr):: p + if(pm_debug_checks) then + call check_ptr_node(node) + if(n<0.or.node_args+n-1>pm_fast_esize(node)) & + call pm_panic('node_arg - n out of range') + endif + p=node%data%ptr(node%offset+node_args+n-1) + contains + include 'fesize.inc' + end function node_arg + + !====================================================== + ! Return n-th argument of a node as a number + ! (that argument should be tiny-int) + !====================================================== + function node_num_arg(node,n) result(num) + type(pm_ptr),intent(in):: node + integer,intent(in):: n + integer:: num + type(pm_ptr):: p + if(pm_debug_checks) then + call check_ptr_node(node) + if(n<0.or.node_args+n-1>pm_fast_esize(node)) & + call pm_panic('node_arg - n out of range') + endif + p=node%data%ptr(node%offset+node_args+n-1) + num=p%offset + contains + include 'fesize.inc' + end function node_num_arg + + !====================================================== + ! Return n-th slot in a node (not the same as argument) + !====================================================== + function node_get(node,n) result(p) + type(pm_ptr),intent(in):: node + integer,intent(in):: n + type(pm_ptr):: p + if(pm_debug_checks) then + call check_ptr_node(node) + if(n<0.or.n>pm_fast_esize(node)) & + call pm_panic('node_get - n out of range') + endif + p=node%data%ptr(node%offset+n) + contains + include 'fesize.inc' + end function node_get + + !====================================================== + ! Return n-th slot in a node (not the same as argument) + ! as a number (must be tiny int) + !====================================================== + function node_get_num(node,n) result(num) + type(pm_ptr),intent(in):: node + integer,intent(in):: n + integer:: num + type(pm_ptr):: p + if(pm_debug_checks) then + call check_ptr_node(node) + if(n<0.or.n>pm_fast_esize(node)) & + call pm_panic('node_get_num - n out of range') + endif + p=node%data%ptr(node%offset+n) + num=p%offset + contains + include 'fesize.inc' + end function node_get_num + + !====================================================== + ! Set n-th slot in a node (not the same as argument) + ! to a number (tiny int) + !====================================================== + subroutine node_set_num(node,n,num) + type(pm_ptr),intent(in):: node + integer,intent(in):: n + integer,intent(in):: num + if(pm_debug_checks) then + call check_ptr_node(node) + if(n<0.or.n>pm_fast_esize(node)) & + call pm_panic('node_get_num - n out of range') + endif + node%data%ptr(node%offset+n)%offset=num + contains + include 'fesize.inc' + end subroutine node_set_num + + !====================================================== + ! Get the line number associated with a node + !====================================================== + function node_get_lineno(node) result(n) + type(pm_ptr),intent(in):: node + integer:: n + if(pm_debug_checks) & + call check_ptr_node(node) + n=node%data%ptr(node%offset+node_lineno)%offset + end function node_get_lineno + + !====================================================== + ! Get the character position (in source) associated + ! with a node + !====================================================== + function node_get_charno(node) result(n) + type(pm_ptr),intent(in):: node + integer:: n + if(pm_debug_checks) & + call check_ptr_node(node) + n=node%data%ptr(node%offset+node_charno)%offset + end function node_get_charno + + !====================================================== + ! Get the module object associated with a node + !====================================================== + function node_get_modl(node) result(modl) + type(pm_ptr),intent(in):: node + type(pm_ptr):: modl + if(pm_debug_checks) & + call check_ptr_node(node) + modl=node%data%ptr(node%offset+node_modl) + contains + include 'fvkind.inc' + end function node_get_modl + + !====================================================== + ! Get the module name associated with a node + !====================================================== + function node_get_modl_name(node) result(name) + type(pm_ptr),intent(in):: node + integer:: name + type(pm_ptr):: modl + if(pm_debug_checks) & + call check_ptr_node(node) + modl=node_get_modl(node) + name=modl%data%ptr(modl%offset+modl_name)%offset + end function node_get_modl_name + + + !====================================================== + ! Dump a module (debugging) + !====================================================== + subroutine dump_module(context,iunit,ptr) + type(pm_context),pointer:: context + integer,intent(in):: iunit + type(pm_ptr),intent(in):: ptr + character(len=100):: str + character(len=7),dimension(modl_include:modl_param):: dnames = & + (/ & + 'include',& + 'proc ',& + 'type ',& + 'param '/) + integer:: i,j,k,m + type(pm_ptr):: keys,vals,p + call pm_name_string(context,int(ptr%data%ptr(ptr%offset+1)%offset),str) + write(iunit,*) 'Module: ',trim(str) + write(iunit,*) 'Stmts:' + call dump_parse_tree(context,iunit,ptr%data%ptr(ptr%offset+modl_stmts),2) + do k=0,modl_local,modl_local + if(k==modl_local) then + write(iunit,*) 'Local:' + m=modl_proc + else + ! m=modl_include + m=modl_proc + endif + do j=m,modl_param + write(iunit,*) dnames(j),& + marked(ptr%data%ptr(ptr%offset+j+k)),'::' + keys=pm_dict_keys(context,ptr%data%ptr(ptr%offset+j+k)) + vals=pm_dict_vals(context,ptr%data%ptr(ptr%offset+j+k)) + write(iunit,*) marked(keys),marked(vals) + do i=1,pm_dict_size(context,ptr%data%ptr(ptr%offset+j+k)) + call pm_name_string(context,& + int(keys%data%ptr(keys%offset+i-1)%offset),str) + write(iunit,*) ' ',trim(str),'::' + write(iunit,*) marked(vals%data%ptr(vals%offset+i-1)) + p=vals%data%ptr(vals%offset+i-1) + call dump_parse_tree(context,iunit,& + p%data%ptr(p%offset),2) + enddo + enddo + enddo + end subroutine dump_module + + !====================================================== + ! Dump a parser tree (debugging) + !====================================================== + recursive subroutine dump_parse_tree(context,iunit,ptr,depth) + type(pm_context),pointer:: context + integer,intent(in):: iunit + type(pm_ptr),intent(in):: ptr + integer,intent(in):: depth + integer:: i, sym + character(len=80),parameter:: spaces = ' ' + character(len=100):: str + if(depth>30) then + write(iunit,*) spaces(:depth*2),'>>>' + return + endif + if(pm_fast_vkind(ptr)==pm_pointer) then + if(ptr%offset<=0) then + write(iunit,*) spaces(1:depth*2),'INVALID PTR' + return + elseif(ptr%data%ptr(ptr%offset)%offset/=9876) then + if(ptr%data%ptr(ptr%offset)%offset==9875) then + write(iunit,*) spaces(1:depth*2),'REUSED NODE',& + ptr%offset,ptr%data%hash,ptr%data%esize + else + write(iunit,*) spaces(1:depth*2),'INVALID NODE' + return + endif + endif + sym=ptr%data%ptr(ptr%offset+1)%offset + if(sym>0.and.sym<=num_syshook) then + write(iunit,*) spaces(1:depth*2),sym_names(sym),ptr%data%esize,& + 'line',node_get_lineno(ptr),& + 'Marked:',marked(ptr),& + ptr%data%hash,ptr%offset,ptr%offset+ptr%data%esize + else if(sym==0) then + call pm_name_string(context,int(ptr%data%ptr(ptr%offset+1)%offset),str) + write(iunit,*) spaces(1:depth*2),'Module: ',trim(str) + return + else + write(iunit,*) spaces(1:depth*2),'???',trim(pm_name_as_string(context,sym)) + return + endif + do i=node_args,ptr%data%esize + call dump_parse_tree(context,iunit,ptr%data%ptr(ptr%offset+i),& + depth+1) + enddo + else if(pm_fast_isnull(ptr)) then + write(iunit,*) spaces(1:depth*2),'NULL' + else if(pm_fast_isname(ptr)) then + call pm_name_string(context,int(ptr%offset),str) + write(iunit,*) spaces(1:depth*2),'Name:',trim(str) + else if(pm_fast_istiny(ptr)) then + write(iunit,*) spaces(1:depth*2),'Tiny number:',ptr%offset + else + call pm_dump_tree(context,iunit,ptr,depth) + endif + contains + include 'fvkind.inc' + include 'fisnull.inc' + include 'fisname.inc' + include 'fistiny.inc' + end subroutine dump_parse_tree + +end module pm_ast diff --git a/src/cfortran.f90 b/src/cfortran.f90 index 6c53051..38a313f 100644 --- a/src/cfortran.f90 +++ b/src/cfortran.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -38,6 +38,7 @@ module pm_backend implicit none logical,parameter:: debug_g=.false. + logical,parameter:: debug_opt=.false. ! Various limits integer,parameter:: ftn_max_line=130 @@ -46,21 +47,21 @@ module pm_backend integer,parameter:: max_levels=256 integer,parameter:: max_loop_stack=10*1024 + ! Variable descriptor type gvar integer:: tno ! Type - integer:: flags ! Flags from previous stage - integer:: gflags ! Flags applied in this stage + integer:: flags ! Flags integer:: state ! State engine (determines if needs to be stored as vector) integer:: start ! First instruction point var is used integer:: finish ! Last instruction point var is used - integer:: lthis ! Parallel context + integer:: depth ! Parallel context integer:: link ! Linked list of variables in creation order integer:: elink ! Linked list of variables in destruction order integer:: index ! Vector to store this variable (may be shared) integer:: free ! List of variables free for reuse (*not unused records*) integer:: oindex ! Index of variable in output from wordcode generator - integer:: outer_lthis ! Outermost parallel context in which variable is referenced + integer:: outer_depth ! Outermost parallel context in which variable is referenced logical:: finish_on_assign ! Last statement using this variable is assignment to another variable integer:: name ! PM name of variable @@ -78,13 +79,14 @@ module pm_backend integer,parameter:: var_state_closed=5 ! Local flags for variables - integer,parameter:: var_is_recycled=1 - integer,parameter:: var_is_async=2 - integer,parameter:: var_is_else_disabled=4 - integer,parameter:: var_is_comm_op_par=8 - integer,parameter:: var_is_used=16 - integer,parameter:: var_is_reused=32 - integer,parameter:: var_is_stacked_ve=64 + integer,parameter:: var_is_recycled= 1*v_extra_flags + integer,parameter:: var_is_async= 2*v_extra_flags + integer,parameter:: var_is_else_disabled=4*v_extra_flags + integer,parameter:: var_is_comm_op_par= 8*v_extra_flags + integer,parameter:: var_is_used= 16*v_extra_flags + integer,parameter:: var_is_reused= 32*v_extra_flags + integer,parameter:: var_is_stacked_ve= 64*v_extra_flags + integer,parameter:: var_is_modified= 128*v_extra_flags ! Loop modes integer,parameter:: loop_is_none=0 @@ -123,12 +125,12 @@ module pm_backend ! Current proc type(pm_ptr):: fn - integer:: taints + integer:: taints,name,rvar,pvar,vevar ! Wordcodes for current proc integer,dimension(:),pointer:: codes integer,dimension(:),pointer:: vars - + ! Variables integer:: nvars,index integer,dimension(:),allocatable:: varindex @@ -137,7 +139,11 @@ module pm_backend ! Parallel loop frames type(gloop),dimension(0:max_loop_stack):: lstack - integer:: lthis,ltop + integer:: depth,ltop + + ! Standard scopes + integer,dimension(0:max_loop_stack):: cstack + integer:: ctop ! VE used by last instruction previously coded integer:: last_ve @@ -156,6 +162,13 @@ module pm_backend character(len=ftn_max_line):: linebuffer integer:: n,outunit integer:: line_breaks + + ! Stack used for various purposes + integer,dimension(:),allocatable:: wstack + integer:: wtop,wbot,wfree,nwfree,wmax + + ! Book-keeping for various optimisations + integer:: local_taints end type gen_state @@ -208,6 +221,7 @@ subroutine gen_prog(context,p,poly_cache,typeset,iunit) g%line_breaks=0 g%n=0 + ! Program code call out_line_noindent(g,'PROGRAM PM') i=iunit @@ -239,6 +253,7 @@ subroutine gen_procs ! Generate procedure to create required MPI types call gen_mpi_types(g) + end subroutine gen_procs ! Output type definitions (called from rtime.inc) @@ -252,6 +267,24 @@ end subroutine out_types end subroutine gen_prog + function g_proc_taints(g,n) result(taints) + type(gen_state):: g + integer,intent(in):: n + integer:: taints + type(pm_ptr):: p + p=pm_dict_val(g%context,g%procs,int(n+1,pm_p)) + p=p%data%ptr(p%offset+2) + taints=p%offset + end function g_proc_taints + + subroutine g_print_out(g,iunit,index,tsets) + type(gen_state):: g + integer,intent(in):: iunit,index + logical,intent(in),optional:: tsets + call print_comp_proc(g%context,iunit,g%name,index,g%rvar,g%vevar,g%pvar,& + g%codes,1,g%vars,g%procs,g%fn%data%ptr(g%fn%offset:),2,.true.,g%wstack,tsets,& + oindex=g%vardata%oindex) + end subroutine g_print_out !=========================================== ! Generate code for a single procedure @@ -260,7 +293,7 @@ subroutine gen_proc(g,p,no) type(gen_state):: g type(pm_ptr),intent(in)::p integer,intent(in):: no - integer:: i,n,rvar,pvar,vevar,name + integer:: i,n,rvar,pvar,vevar,name,start type(pm_ptr)::q,taint,keys logical:: iscomm @@ -277,16 +310,12 @@ subroutine gen_proc(g,p,no) keys=p%data%ptr(p%offset+3) g%taints=taint%offset iscomm=iand(int(taint%offset),proc_is_comm)/=0 - - ! Output spacing / comment - call out_new_line(g) - call out_line_noindent(g,' !'//& - trim(pm_name_as_string(g%context,name))) - if(debug_g) then - write(*,*) 'OUT START> ',& - trim(pm_name_as_string(g%context,q%data%i(q%offset+2))) - endif + g%rvar=rvar + g%pvar=pvar + g%vevar=vevar + g%name=name + ! Set up variable data tables q=p%data%ptr(p%offset+1) g%vars=>q%data%i(q%offset:q%offset+pm_fast_esize(q)) @@ -296,25 +325,39 @@ subroutine gen_proc(g,p,no) g%nvars=0 g%varindex(1:n)=0 - ! Output procedure header - if(iand(int(taint%offset),proc_is_recursive)/=0) & - call out_str(g,'RECURSIVE ') - if(iand(int(taint%offset),proc_is_impure)==0) & - call out_str(g,'PURE ') - call out_str(g,'SUBROUTINE PM__P') - call out_idx(g,no) - if(pm_opts%ftn_name_procs.and.no>0) then - call out_ftn_name(g,name) - endif + call g_print_out(g,67,no+1) + + call init_g + ! Create variables + if(vevar/=-1) then + call create_var(g,vevar,.false.) + endif + if(.not.pm_fast_isnull(keys)) then + do i=0,pm_fast_esize(keys) + call create_var(g,keys%data%i(keys%offset+i),.false.) + enddo + endif + if(pvar/=-1) call create_var(g,pvar,.false.) + if(size(g%codes)>0) call create_vars_for_block(g,comp_op_start) + if(rvar/=-1) call create_var(g,rvar,.false.) + + start=comp_op_start + g%depth=1 + g%cstack(g%depth)=bset_new(g,0) + if(size(g%codes)>0)call record_vars_for_block(g,start) + + call g_print_out(g,69,no+1,.true.) + ! Phase I - analyse variable use to determine variable lifetimes ! and which variables need to be ! stored as vectors ! Also output necessary variable definition lines here - call init_g + g%ltop=-1 + g%depth=0 call g_new_frame(g) - g%lstack(g%lthis)%loop_mode=loop_is_none + g%lstack(g%depth)%loop_mode=loop_is_none if(vevar/=-1) then call use_var(g,vevar) call cross_var(g,vevar) @@ -330,12 +373,30 @@ subroutine gen_proc(g,p,no) ! Phase II - analyse variable lifetimes to merge variables do i=0,g%ltop - g%lthis=i + g%depth=i call sort_var_list(g) call alloc_var_list(g) enddo ! Phase III - output necessary definition lines + ! Output procedure header + ! Output spacing / comment + call out_new_line(g) + call out_line_noindent(g,' !'//& + trim(pm_name_as_string(g%context,name))) + if(debug_g) then + write(*,*) 'OUT START> ',& + trim(pm_name_as_string(g%context,q%data%i(q%offset+2))) + endif + if(iand(int(taint%offset),proc_is_recursive)/=0) & + call out_str(g,'RECURSIVE ') + if(iand(int(taint%offset),proc_is_impure)==0) & + call out_str(g,'PURE ') + call out_str(g,'SUBROUTINE PM__P') + call out_idx(g,no) + if(pm_opts%ftn_name_procs.and.no>0) then + call out_ftn_name(g,name) + endif call out_char(g,'(') if(iscomm) then call out_str(g,'N1,') @@ -391,10 +452,17 @@ subroutine gen_proc(g,p,no) include 'fesize.inc' include 'fisnull.inc' subroutine init_g - g%lthis=0 + g%depth=0 g%ltop=0 g%lalt=-1 g%loop_contains_shared=.false. + if(allocated(g%wstack)) deallocate(g%wstack) + allocate(g%wstack(max_code_size)) + g%wtop=0 + g%wbot=max_code_size+1 + g%wmax=max_code_size + g%wfree=0 + g%nwfree=0 end subroutine init_g end subroutine gen_proc @@ -412,153 +480,1345 @@ function g_procname(g,n) result(name) end function g_procname !************************************************ - ! PHASE I - VARIABLE ASSIGNMENT + ! PHASE I - VARIABLE CREATION !************************************************ !=========================================== - ! Variable assignment phase for a code block + ! Create a variable entry for variables + ! referenced by any operation in the block !=========================================== - recursive subroutine gen_var_block(g,loc) + recursive subroutine create_vars_for_block(g,loc) type(gen_state):: g integer,intent(in):: loc integer:: l - if(debug_g) write(*,*) 'VAR BLOCK>' + if(debug_g) write(*,*) 'CREATE VARS FOR BLOCK>' l=loc + g%depth=g%depth+1 do while(l>0) - if(debug_g) write(*,*) 'DO VAR>',l - g%lstack(g%lthis)%idx=g%lstack(g%lthis)%idx+1 - call gen_var_op(g,l) + call create_vars_for_op(g,l) l=g%codes(l) - if(debug_g) write(*,*) 'NEXT VAR',l enddo - if(debug_g) write(*,*) 'END VAR BLOCK>' - end subroutine gen_var_block + g%depth=g%depth-1 + if(debug_g) write(*,*) 'END CREATE VARS FOR BLOCK>' + end subroutine create_vars_for_block - !================================================== - ! Variable assignment phase for a single operation - !================================================== - recursive subroutine gen_var_op(g,l) + !================================================ + ! Create a variable entry for variables + ! referenced by any operation in the comm block + !=============================================== + recursive subroutine create_vars_for_comm_block(g,loc) + type(gen_state):: g + integer,intent(in):: loc + integer:: l,save_depth + if(debug_g) write(*,*) 'CREATE VARS FOR COMM BLOCK>' + l=loc + g%depth=g%depth+1 + do while(l>0) + call create_vars_for_op(g,l) + l=g%codes(l) + enddo + g%depth=g%depth-1 + if(debug_g) write(*,*) 'END CREATE VARS FOR COMM BLOCK>' + end subroutine create_vars_for_comm_block + + !=========================================== + ! Create a variable entry for any variable + ! referenced by an operation + !=========================================== + recursive subroutine create_vars_for_op(g,l) type(gen_state):: g integer,intent(in):: l - integer:: opcode,opcode2,n,arg - integer:: i,j,a,save_lthis,ll,var1,idx1 - logical:: save_loop_contains_shared - if(pm_debug_level>0) then - if(l>size(g%codes)) then - write(*,*) 'l=',l,size(g%codes) - call pm_panic('gen_var_op bad l') + integer:: opcode,n,a,is,i,flags + opcode=g%codes(l+comp_op_opcode) + n=iand(g%codes(l+comp_op_nargs),comp_op_nargs_mask) + a=l+comp_op_arg0 + call create_var(g,g%codes(a),.false.) + flags=op_flags(opcode) + if(iand(flags,op_1_block+op_2_blocks)/=0) then + if(iand(flags,op_has_comm_block)/=0) then + call create_vars_for_comm_block(g,g%codes(a+1)) + is=2 + elseif(iand(flags,op_1_block)/=0) then + call create_vars_for_block(g,g%codes(a+1)) + is=2 + else ! op_2_blocks + call create_vars_for_block(g,g%codes(a+1)) + call create_vars_for_block(g,g%codes(a+2)) + is=3 endif + else + is=1 endif + do i=is,n-1 + call create_var(g,g%codes(a+i),g%codes(a+i)<0) + enddo + !g%codes(l+comp_op_line)=-999 + end subroutine create_vars_for_op + + !===================================================== + ! Create a variable entry/entries for given argument + !===================================================== + recursive subroutine create_var(g,avar,modify) + type(gen_state),intent(inout):: g + integer,intent(in):: avar + logical,intent(in):: modify + integer:: kind,state,i,j,var,flags,tno + if(avar==0.or.avar==shared_op_flag) return + var=abs(avar) + if(debug_g) write(*,*) 'CREATE VAR> ',var,g_index(g,var),& + g%depth + kind=g_kind(g,var) + select case(kind) + case(v_is_group) + do i=1,g_v1(g,var) + call create_var(g,g_ptr(g,var,i),modify) + enddo + case(v_is_sub,v_is_vsub) + call create_var(g,g_v1(g,var),modify) + call create_var(g,g_v2(g,var),modify) + case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) + call create_var(g,g_v1(g,var),modify) + case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) + continue + case(v_is_cove) + call create_var(g,g_v2(g,var),modify) + g%varindex(var)=g%varindex(g_v2(g,var)) + case(v_is_alias) + call create_var(g,g_v1(g,var),modify) + g%varindex(var)=g%varindex(g_v1(g,var)) + case(v_is_chan_vect) + call create_var(g,g_v1(g,var),modify) + g%varindex(var)=g%varindex(g_v1(g,var)) + case default + i=g%varindex(var) + if(i==0) then + g%nvars=g%nvars+1 + if(debug_g) write(*,*) 'CREATE>',var,g%nvars + i=g%nvars + if(kind==v_is_parve) then + g%vardata(i)%tno=pm_logical + flags=v_is_param + g%vardata(i)%name=0 + elseif(kind==v_is_ve) then + call create_var(g,g_v1(g,var),modify) + g%vardata(i)%tno=pm_logical + flags=0 + g%vardata(i)%name=0 + else + flags=g_v2(g,var) + tno=g_type(g,var) + g%vardata(i)%tno=tno + if(iand(flags,v_is_array_par_vect)==0) then + g%vardata(i)%name=g_v1(g,var) + else + g%vardata(i)%name=0 + endif + endif + g%vardata(i)%depth=g%depth + g%vardata(i)%flags=flags + g%vardata(i)%state=var_state_unused + g%vardata(i)%index=0 + g%vardata(i)%oindex=var + g%varindex(var)=i + if(debug_g) write(*,*) 'NEW VAR>',var,i, g%vardata(i)%link + else + g%vardata(i)%depth=min(g%depth,g%vardata(i)%depth) + if(modify) g%vardata(i)%flags=ior(g%vardata(i)%flags,var_is_modified) + endif + end select + end subroutine create_var + + + !=========================================== + ! Create access sets for each operation + ! - including accesses from operations in + ! nested blocks + !=========================================== + recursive subroutine record_vars_for_block(g,loc) + type(gen_state):: g + integer,intent(inout):: loc + integer:: l,p + if(debug_g) write(*,*) 'RECORD VARS FOR BLOCK>' + l=loc + p=0 + do while(l>0) + call record_vars_for_op(g,l,p,loc) + p=l + l=g%codes(l) + enddo + if(debug_g) write(*,*) 'END RECORD VARS FOR BLOCK>' + end subroutine record_vars_for_block + + recursive subroutine record_vars_for_op(g,l,pre,blk) + type(gen_state):: g + integer,intent(in):: l,pre + integer,intent(inout):: blk + integer:: opcode,n,nret,a,is,i,flags,bset,acc + integer:: save_local_taints,vset,invar_vset,proc_taints + save_local_taints=g%local_taints + g%local_taints=0 opcode=g%codes(l+comp_op_opcode) - opcode2=g%codes(l+comp_op_opcode2) n=iand(g%codes(l+comp_op_nargs),comp_op_nargs_mask) + nret=iand(g%codes(l+comp_op_nargs),comp_op_nret_mask)/comp_op_nret_div a=l+comp_op_arg0 - - if(debug_g) then - write(*,*) 'l=',l,n,op_names(opcode) - write(*,*) 'VAR OP> ',g%lstack(g%lthis)%idx,l,op_names(opcode),n,& - '>>',g%codes(l:l+comp_op_arg0+n-1) + flags=op_flags(opcode) + + if(iand(flags,op_1_block+op_2_blocks)/=0) then + if(iand(flags,op_has_comm_block)/=0) then + call push_block + call record_vars_for_block(g,g%codes(a+1)) + call pop_block + call schedule_comm_block(g,g%codes(a+1)) + is=2 + elseif(iand(flags,op_has_loop_block)/=0) then + call push_block + call record_vars_for_block(g,g%codes(a+1)) + call pop_block + invar_vset=vset_extract_from_bset(g,bset,& + acc_read+acc_write,acc_read) + call loop_invar_motion_block(g,g%codes(a+1),& + pre,blk,invar_vset,g%depth) + call vset_drop(g,invar_vset) + is=2 + elseif(iand(flags,op_1_block)/=0) then + call push_block + call record_vars_for_block(g,g%codes(a+1)) + call pop_block + is=2 + else ! op_2_blocks + call push_block + call record_vars_for_block(g,g%codes(a+1)) + call record_vars_for_block(g,g%codes(a+2)) + call pop_block + is=3 + endif + else + is=1 endif - - select case(opcode) - case(op_if,op_if_shared,op_if_restart) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call gen_var_block(g,g%codes(a+2)) - call use_var(g,g%codes(a+3)) - case(op_if_shared_node) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call gen_var_block(g,g%codes(a+2)) - case(op_over,op_skip_empty) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call cross_all_vars(g) - case(op_head_node) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - case(op_loop) - save_loop_contains_shared=g%loop_contains_shared - g%loop_contains_shared=.false. - var1=g%lstack(g%lthis)%varlist - idx1=g%lstack(g%lthis)%idx - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call extend_finish_to_loop(g,idx1,g%lstack(g%lthis)%idx,var1) - call use_var(g,g%codes(a+2)) - if(g%loop_contains_shared) then - g%codes(l+comp_op_opcode2)=ior(g%codes(l+comp_op_opcode2),2) + g%local_taints=ior(g%local_taints,flags) + if(opcode==op_call.or.opcode==op_comm_call) then + proc_taints=g_proc_taints(g,g%codes(l+comp_op_opcode2)) + if(iand(proc_taints,proc_is_dcomm)/=0) then + g%local_taints=ior(g%local_taints,op_is_comm) endif - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_loop,op_comm_loop_par) - save_loop_contains_shared=g%loop_contains_shared - var1=g%lstack(g%lthis)%varlist - idx1=g%lstack(g%lthis)%idx - call cross_all_vars(g) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call extend_finish_to_loop(g,idx1,g%lstack(g%lthis)%idx,var1) - call use_var(g,g%codes(a+2)) - call cross_all_vars(g) - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_proc) - save_loop_contains_shared=g%loop_contains_shared - call use_var(g,g%codes(a)) - call gen_var_comm_block(g,g%codes(a+1)) - g%loop_contains_shared=save_loop_contains_shared - case(op_inline_shared) - save_loop_contains_shared=g%loop_contains_shared - call use_var(g,g%codes(a)) - call gen_var_shared_block(g,g%codes(a+1)) - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_block) - save_loop_contains_shared=g%loop_contains_shared - call use_var(g,g%codes(a)) - call use_var(g,g%codes(a+2)) - call gen_var_comm_block(g,g%codes(a+1)) - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_call,op_dref,op_wrap) - call cross_all_vars(g) - do i=0,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - call use_var(g,g%codes(a+i)) + if(iand(proc_taints,proc_is_file)/=0) then + g%local_taints=ior(g%local_taints,op_is_file) + endif + if(iand(proc_taints,proc_prints_out)/=0) then + g%local_taints=ior(g%local_taints,op_prints_out) + endif + endif + vset=vset_new(g,g%codes(l+comp_op_line),g%local_taints) + g%codes(l+comp_op_line)=vset + call record_var_access(g,g%codes(a),acc_read) + if(opcode==op_assign) then + acc=acc_read+acc_write + if(g_kind(g,g%codes(a+1))==v_is_basic) then + acc=acc_write + endif + if(iand(pm_type_flags(g%context,g_type(g,g%codes(a+1))),& + pm_type_has_array+pm_type_has_poly)/=0) then + acc=ior(acc,acc_alloc) + endif + call record_var_access(g,g%codes(a+1),acc) + call record_var_access(g,g%codes(a+2),acc_read) + else +!!$ if(iand(flags,op_allocates)/=0.and..false.) then +!!$ call record_var_access(g,g%codes(a+1),acc_write+acc_alloc) +!!$ else + + do i=is,is+nret-1 + call record_var_access(g,g%codes(a+i),acc_write) enddo - case(op_init_var) - call use_var(g,g%codes(a)) - call use_var(g,g%codes(a+1)) - case(op_comm_inline) !!! Obsolete? - call cross_all_vars(g) - case(op_sync) - call cross_all_vars(g) - case(op_broadcast_val,& - op_sync_mess,op_break_loop,& - op_read_file_tile,op_write_file_tile,op_broadcast,& - op_broadcast_shared,op_nested_loop,& - op_blocked_loop,op_isend_offset,op_irecv_offset,& - op_recv_offset,op_recv_offset_resend,op_isend_reply,& - op_recv_reply,op_isend_req,op_isend_assn,op_active,op_get_size) - call cross_all_vars(g) - do i=0,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) +!!$ endif + + do i=is+nret,n-1 + call record_var_access(g,g%codes(a+i),& + merge(acc_read+acc_write,acc_read,g%codes(a+i)<0)) enddo - case(op_remote_send_call,op_collect_call) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=6,n-1 !!! Dont use or cross outputs - call use_var(g,g%codes(a+i)) + if(iand(flags,op_1_block+op_2_blocks)/=0) then + call bset_push_to_stack(g,bset) + endif + + endif + call vset_augment(g,vset) + + g%local_taints=ior(save_local_taints,g%local_taints) + contains + + subroutine push_block + bset=bset_new(g,0) + g%depth=g%depth+1 + g%cstack(g%depth)=bset + !write(*,*) 'push to ',g%depth + end subroutine push_block + + subroutine pop_block + g%depth=g%depth-1 + g%codes(l+comp_op_line)=bset + !write(*,*) 'pop to',g%depth + end subroutine pop_block + + end subroutine record_vars_for_op + + + !===================================================== + ! Create a variable entry/entries for given argument + !===================================================== + recursive subroutine record_var_access(g,avar,mode) + type(gen_state),intent(inout):: g + integer,intent(in):: avar,mode + integer:: kind,i,j,var + if(avar==0.or.avar==shared_op_flag) return + var=abs(avar) + if(debug_g) write(*,*) 'RECORD VAR ACCESS> ',var,g_index(g,var),& + g%depth,g%lstack(g%depth)%idx !,g_kind(g,var),g_v1(g,var) + kind=g_kind(g,var) + select case(kind) + case(v_is_group) + do i=1,g_v1(g,var) + call record_var_access(g,g_ptr(g,var,i),mode) + enddo + case(v_is_sub,v_is_vsub) + call record_var_access(g,g_v1(g,var),mode) + call record_var_access(g,g_v2(g,var),mode) + case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) + call record_var_access(g,g_v1(g,var),mode) + case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) + continue + case(v_is_cove) + call record_var_access(g,g_v2(g,var),mode) + case(v_is_alias) + call record_var_access(g,g_v1(g,var),mode) + case(v_is_chan_vect) + call record_var_access(g,g_v1(g,var),mode) + case default + i=g%varindex(var) + call add_var_access(g,i,mode) + do j=g%vardata(i)%depth+1,g%depth + call bset_add(g,g%cstack(j),i,mode) + enddo + end select + end subroutine record_var_access + + !=============================================== + ! Add a variable access to the vset + ! which must be on top of the lower wstack + !=============================================== + subroutine add_var_access(g,var,mode) + type(gen_state),intent(inout):: g + integer,intent(in):: var,mode + if(g%wtop+1>=g%wbot) call grow_wstack(g) + g%wtop=g%wtop+1 + g%wstack(g%wtop)=mode+var*acc_mult + end subroutine add_var_access + + !*********************************************** + ! Loop invariant motion + ! look for operations that only use read-only + ! entries to the loop block (which must + ! be updated as operations are moved) + !*********************************************** + + !=============================================== + ! Apply invariant motion to a block + ! (which may be nested) + !=============================================== + recursive subroutine loop_invar_motion_block(g,blk,& + loop_preop,loop_blk,invar_vset,loop_depth) + type(gen_state),intent(inout):: g + integer,intent(inout):: blk,loop_blk + integer,intent(in):: loop_preop,invar_vset,loop_depth + integer:: p,l + p=0 + l=blk + do while(l>0) + call loop_invar_motion_op(g,l,p,blk,loop_preop,& + loop_blk,invar_vset,loop_depth) + p=l + l=g%codes(l) + enddo + end subroutine loop_invar_motion_block + + !=============================================== + ! Apply invariant motion to an operation + ! moving it if required + !=============================================== + recursive subroutine loop_invar_motion_op(g,& + op,preop,blk,& + loop_preop,loop_blk,invar_vset,loop_depth) + type(gen_state),intent(inout):: g + integer,intent(in):: op,preop,loop_preop,invar_vset,loop_depth + integer,intent(inout):: blk,loop_blk + integer:: i,j,v,a,old_top,old_depth,depth,op_vset,opcode,flags,taints + integer,parameter:: cannot_move=op_is_comm+op_prints_out+op_is_file + opcode=g%codes(op+comp_op_opcode) + flags=op_flags(opcode) + op_vset=g%codes(op+comp_op_line) + taints=vset_taints(g,op_vset) + if(iand(taints,cannot_move)==0) then + if(vset_invar(g,invar_vset,op_vset)) then + do i=1,vset_size(g,op_vset) + call vset_get(g,op_vset,i,v,a) + if(iand(a,acc_write)==0) then + if(iand(a,acc_read)/=0) then + ! Abandon - RW access + return + elseif(iand(g%vardata(v)%flags,var_is_modified)/=0) then + ! Abandon - modified in loop + return + endif + endif + enddo + do i=1,vset_size(g,op_vset) + call vset_get(g,op_vset,i,v,a) + if(iand(a,acc_write)==0) then + call add_var_access(g,v,acc_read) + old_depth=g%vardata(v)%depth + g%vardata(v)%depth=loop_depth + do j=loop_depth,old_depth-1 + call bset_add(g,g%cstack(i),v,acc_read) + enddo + endif + enddo + call vset_augment(g,invar_vset) + call move_op(g,blk,preop,loop_blk,loop_preop) + return + endif + endif + if(iand(flags,op_1_block+op_2_blocks)/=0) then + if(iand(flags,op_has_comm_block+op_has_loop_block)==0) then + if(vset_includes_a_bset_read(g,invar_vset,vset_loc(g,op_vset))) then + call loop_invar_motion_block(g,g%codes(op+comp_op_arg0+1),& + loop_preop,loop_blk,invar_vset,loop_depth) + if(iand(flags,op_2_blocks)/=0) then + call loop_invar_motion_block(g,g%codes(op+comp_op_arg0+2),& + loop_preop,loop_blk,invar_vset,loop_depth) + endif + endif + endif + endif + end subroutine loop_invar_motion_op + + ! ************************************************************* + ! This performs a list scheduling of a block of instructions + ! in a communicating block + ! ************************************************************* + recursive subroutine schedule_comm_block(g,ptr_to_start) + type(gen_state):: g + + ! Relative priorities of each kind of instruction + integer,parameter:: instr_precedes_loop=0 + integer,parameter:: instr_is_comm=1 + integer,parameter:: instr_is_std=2 + integer,parameter:: instr_is_sync_recv=3 + integer,parameter:: instr_is_sync=4 + integer,parameter:: instr_follows_loop=5 + + integer,parameter:: instr_is_shared=16 + integer,parameter:: instr_is_loop_break=32 + integer,parameter:: instr_priority_mask=15 + + type instruction + integer(pm_ln):: bloom,wbloom + integer:: index + integer:: ve,cove + integer:: kind + integer:: taints + integer:: vset + end type instruction + + integer,intent(inout):: ptr_to_start + integer:: ninstr,ll,i,j,k,num_scheduled + integer:: instr_ptr,instr_scheduled + integer:: curr_priority,new_priority + logical:: have_shared,have_non_shared + type(instruction),allocatable,dimension(:):: instr + integer(pm_ln),dimension(:,:,:),allocatable:: mask + integer,allocatable,dimension(:):: nafter + + if(debug_opt) write(*,*) 'SCHEDULE BLOCK>',ptr_to_start + + ninstr=0 + ll=ptr_to_start + do while(ll/=0) + ninstr=ninstr+1 + ll=g%codes(ll) + enddo + + if(ninstr<3) return + + write(72,*) 'Schedule',ninstr + + allocate(instr(ninstr)) + allocate(nafter(ninstr),source=0) + + ! Process each instruction to get information + have_shared=.false. + have_non_shared=.false. + i=0 + ll=ptr_to_start + do while(ll/=0) + i=i+1 + call process_instr(instr(i),ll) + if(iand(instr(i)%kind,instr_is_shared)/=0) have_shared=.true. + if(iand(instr(i)%kind,instr_is_shared)==0) have_non_shared=.true. + ll=g%codes(ll) + enddo + + if(.not.(have_shared.and.have_non_shared)) then + ! No need to schedule + write(72,*) 'No sched',have_shared,have_non_shared + goto 10 + endif + + ! Compute nafter(instr) - number of instructions that must follow instr + ! due to a direct clash (RaW, WaW or WaW conflict) + do i=1,ninstr + do j=1,i-1 + if(conflict(j,i)) nafter(j)=nafter(j)+1 + enddo + enddo + + ! Find last instruction + instr_ptr=0 + j=-1 + curr_priority=-1 + do i=1,ninstr + if(nafter(i)==0) then + new_priority=solo_priority(instr(i)) + if(new_priority>=curr_priority) then + j=i + curr_priority=new_priority + endif + endif + enddo + instr_scheduled=j + call schedule(instr_scheduled) + + ! Schedule remaining instructions + do num_scheduled=2,ninstr + write(72,*) 'Scheduling',num_scheduled + curr_priority=-1 + j=-1 + do i=1,ninstr + if(instr(i)%kind<0) cycle + if(i=curr_priority) then + j=i + curr_priority=new_priority + endif + endif + enddo + instr_scheduled=j + call schedule(instr_scheduled) + write(72,*) 'scheduled',instr_scheduled + if(debug_opt) write(*,*) 'scheduled',num_scheduled,' of ',ninstr + enddo + ptr_to_start=instr_ptr + +10 continue + + deallocate(instr) + deallocate(nafter) + + contains + + subroutine process_instr(instr,l) + type(instruction),intent(inout):: instr + integer,intent(in):: l + integer:: j,opcode,n,a,m,kind,taints,v,acc + opcode=g%codes(l+comp_op_opcode) + if(debug_opt) write(*,*) 'Process instr>',l,op_names(opcode) + n=g%codes(l+comp_op_nargs) + a=l+comp_op_arg0 + instr%index=l + instr%bloom=0 + instr%wbloom=0 + instr%ve=g%codes(a) + if(g%codes(a)>0) then + instr%cove=g_v2(g,g%codes(a)) + else + instr%cove=0 + endif + instr%vset=g%codes(l+comp_op_line) + do j=1,vset_size(g,instr%vset) + call vset_get(g,instr%vset,j,v,acc) + if(acc/=0) then + instr%bloom=bloom(instr%bloom,v) + endif + if(iand(acc,acc_write)/=0) then + instr%wbloom=bloom(instr%wbloom,v) + endif + enddo + taints=vset_taints(g,instr%vset) + instr%taints=taints + kind=instr_is_std + if(iand(taints,op_precedes_loop)/=0) then + kind=instr_precedes_loop + elseif(iand(taints,op_is_sync+op_is_sync_recv+op_is_send+op_is_recv)==op_is_sync) then + kind=instr_is_sync + elseif(iand(taints,op_is_sync_recv+op_is_sync)/=0) then + kind=instr_is_sync_recv + elseif(iand(taints,op_is_send+op_is_recv)/=0) then + kind=instr_is_comm + endif + + instr%kind=kind + end subroutine process_instr + + function bloom(bloom_in,v) result(bloom_out) + integer(pm_ln),intent(in):: bloom_in + integer,intent(in):: v + integer(pm_ln):: bloom_out + bloom_out=ibset(bloom_in,mod(v,bit_size(bloom_in))) + end function bloom + + function conflict(i,j) result(conflicting) + integer,intent(in):: i,j + logical:: conflicting + if(iand(instr(i)%kind,instr_is_loop_break)/=0.and.& + iand(instr(j)%kind,instr_is_shared)==0) then + conflicting=.true. + return + endif + if(iand(iand(instr(i)%taints,instr(j)%taints),& + op_is_comm+op_is_file+op_prints_out)/=0) then + conflicting=.true. + return + endif + if(ior(iand(instr(i)%wbloom,instr(j)%bloom),& + iand(instr(i)%bloom,instr(j)%wbloom))==0) then + conflicting=.false. + return + endif + conflicting=vset_clash(g,instr(i)%vset,instr(j)%vset) + end function conflict + + subroutine schedule(i) + integer,intent(in):: i + integer:: index + if(debug_opt) then + write(*,*) 'Scheduled:',i + write(*,*) op_names(g%codes(instr(i)%index+2)) + endif + index=instr(i)%index + g%codes(index)=instr_ptr + instr_ptr=index + instr(i)%kind=-999 + end subroutine schedule + + ! Priority of instruction considered alone + function solo_priority(i) result(priority) + type(instruction),intent(in):: i + integer:: priority + priority=iand(i%kind,instr_priority_mask+instr_is_shared) + end function solo_priority + + ! Priority of instruction in light of last + ! scheduled instruction + function co_priority(i) result(priority) + type(instruction),intent(in):: i + integer:: priority + priority=0 + if(iand(i%kind,instr_is_shared)==& + iand(instr(instr_scheduled)%kind,instr_is_shared)) then + priority=priority+4 + endif + if(i%ve==instr(instr_scheduled)%ve) then + priority=priority+2 + elseif(i%cove==instr(instr_scheduled)%ve) then + priority=priority+1 + endif + priority=iand(i%kind,instr_priority_mask)+priority*(instr_priority_mask+1) + end function co_priority + + end subroutine schedule_comm_block + + subroutine move_op(g,blk,preop,blk2,preop2) + type(gen_state),intent(inout):: g + integer,intent(in):: preop,preop2 + integer,intent(inout):: blk,blk2 + integer:: op,op2,link + if(preop==0) then + op=blk + elseif(preop>0) then + op=g%codes(preop) + else + op=g%wstack(-preop) + endif + if(preop2==0) then + op2=blk2 + blk2=op + elseif(preop2>0) then + op2=g%codes(preop2) + g%codes(preop2)=op + else + op2=g%wstack(-preop2) + g%wstack(-preop2)=op + endif + if(op>0) then + link=g%codes(op) + g%codes(op)=op2 + else + link=g%wstack(-op) + g%wstack(-op)=op2 + endif + if(preop==0) then + blk=op2 + elseif(preop>0) then + g%codes(preop)=op2 + else + g%wstack(-preop)=op2 + endif + end subroutine move_op + + + !=============================================== + ! Create a new block import/export set + !=============================================== + function bset_new(g,blk) result(bset) + type(gen_state),intent(inout):: g + integer,intent(in):: blk + integer:: bset + integer:: i + if(g%wtop>=g%wbot) call grow_wstack(g) + g%wbot=g%wbot-3 + i=g%wbot + g%wstack(i)=blk + g%wstack(i+1)=0 + g%wstack(i+2)=0 + bset=i-g%wmax + end function bset_new + + !=============================================== + ! Add a variable to a given block import/export + ! set + !=============================================== + subroutine bset_add(g,bset,var,mode) + type(gen_state),intent(inout):: g + integer,intent(in):: bset,var,mode + integer:: head,tail,i + if(debug_g) then + write(*,*) 'Add ',var,' to ',bset + endif + if(g%wtop>=g%wbot) call grow_wstack(g) + head=bset + tail=g%wstack(g%wmax+head+1) + do while(tail/=0.and.g%wstack(g%wmax+tail)/acc_mult' + l=loc + do while(l>0) + if(debug_g) write(*,*) 'DO VAR>',l + g%lstack(g%depth)%idx=g%lstack(g%depth)%idx+1 + call gen_var_op(g,l) + l=g%codes(l) + if(debug_g) write(*,*) 'NEXT VAR',l + enddo + if(debug_g) write(*,*) 'END VAR BLOCK>' + end subroutine gen_var_block + + !============================================================= + ! Assign variables for a block with comm operations + !============================================================= + subroutine gen_var_comm_block(g,blk) + type(gen_state):: g + integer,intent(in):: blk + integer:: save_depth,ll + save_depth=g%depth + if(debug_g) write(*,*) 'VAR COMM BLK>',blk + call g_new_frame(g) + ll=blk + do while(ll>0) + g%lstack(g%depth)%idx=g%lstack(g%depth)%idx+1 + call gen_var_op(g,ll) + ll=g%codes(ll) + enddo + g%depth=save_depth + if(debug_g) write(*,*) 'VAR COMM BLK>',blk + end subroutine gen_var_comm_block + + !============================================================= + ! Assign variables for inline shared proc body + !============================================================= + subroutine gen_var_shared_block(g,blk) + type(gen_state):: g + integer,intent(in):: blk + integer:: save_depth,ll + if(debug_g) write(*,*) 'VAR SHARED BLK>',blk + save_depth=g%depth + call g_new_frame(g) + g%lstack(g%depth)%loop_mode=loop_is_none + ll=blk + do while(ll>0) + g%lstack(g%depth)%idx=g%lstack(g%depth)%idx+1 + call gen_var_op(g,ll) + ll=g%codes(ll) + enddo + call sort_var_list(g) + g%depth=save_depth + if(debug_g) write(*,*) 'END VAR SHARED BLK>',blk + end subroutine gen_var_shared_block + + + !================================================== + ! Assign variables for a single operation + !================================================== + recursive subroutine gen_var_op(g,l) + type(gen_state):: g + integer,intent(in):: l + integer:: opcode,opcode2,n,arg + integer:: i,j,a,save_depth,ll,var1,idx1 + logical:: save_loop_contains_shared + if(pm_debug_level>0) then + if(l>size(g%codes)) then + write(*,*) 'l=',l,size(g%codes) + call pm_panic('gen_var_op bad l') + endif + endif + opcode=g%codes(l+comp_op_opcode) + opcode2=g%codes(l+comp_op_opcode2) + n=iand(g%codes(l+comp_op_nargs),comp_op_nargs_mask) + a=l+comp_op_arg0 + + if(debug_g) then + write(*,*) 'l=',l,n,op_names(opcode) + write(*,*) 'VAR OP> ',g%lstack(g%depth)%idx,l,op_names(opcode),n,& + '>>',g%codes(l:l+comp_op_arg0+n-1) + endif + + select case(opcode) + case(op_if,op_if_shared,op_if_restart) + call use_var(g,g%codes(a)) + call gen_var_block(g,g%codes(a+1)) + call gen_var_block(g,g%codes(a+2)) + call use_var(g,g%codes(a+3)) + case(op_if_shared_node) + call use_var(g,g%codes(a)) + call gen_var_block(g,g%codes(a+1)) + call gen_var_block(g,g%codes(a+2)) + case(op_over,op_skip_empty) + call cross_all_vars(g) + call use_var(g,g%codes(a)) + call gen_var_block(g,g%codes(a+1)) + call cross_all_vars(g) + case(op_head_node) + call use_var(g,g%codes(a)) + call gen_var_block(g,g%codes(a+1)) + case(op_loop) + save_loop_contains_shared=g%loop_contains_shared + g%loop_contains_shared=.false. + var1=g%lstack(g%depth)%varlist + idx1=g%lstack(g%depth)%idx + call use_var(g,g%codes(a)) + call gen_var_block(g,g%codes(a+1)) + call extend_finish_to_loop(g,idx1,g%lstack(g%depth)%idx,var1) + call use_var(g,g%codes(a+2)) + if(g%loop_contains_shared) then + g%codes(l+comp_op_opcode2)=ior(g%codes(l+comp_op_opcode2),2) + endif + g%loop_contains_shared=save_loop_contains_shared + case(op_comm_loop,op_comm_loop_par) + save_loop_contains_shared=g%loop_contains_shared + var1=g%lstack(g%depth)%varlist + idx1=g%lstack(g%depth)%idx + call cross_all_vars(g) + call use_var(g,g%codes(a)) + call gen_var_block(g,g%codes(a+1)) + call extend_finish_to_loop(g,idx1,g%lstack(g%depth)%idx,var1) + call use_var(g,g%codes(a+2)) + call cross_all_vars(g) + g%loop_contains_shared=save_loop_contains_shared + case(op_comm_proc) + save_loop_contains_shared=g%loop_contains_shared + call use_var(g,g%codes(a)) + call gen_var_comm_block(g,g%codes(a+1)) + g%loop_contains_shared=save_loop_contains_shared + case(op_inline_shared) + save_loop_contains_shared=g%loop_contains_shared + call use_var(g,g%codes(a)) + call gen_var_shared_block(g,g%codes(a+1)) + g%loop_contains_shared=save_loop_contains_shared + case(op_comm_block) + save_loop_contains_shared=g%loop_contains_shared + call use_var(g,g%codes(a)) + call use_var(g,g%codes(a+2)) + call gen_var_comm_block(g,g%codes(a+1)) + g%loop_contains_shared=save_loop_contains_shared + case(op_comm_call,op_dref,op_wrap) + call cross_all_vars(g) + do i=0,n-1 + call use_var(g,g%codes(a+i)) + call cross_var(g,g%codes(a+i)) + call use_var(g,g%codes(a+i)) + enddo + case(op_init_var) + call use_var(g,g%codes(a)) + call use_var(g,g%codes(a+1)) + case(op_comm_inline) !!! Obsolete? + call cross_all_vars(g) + case(op_sync) + call cross_all_vars(g) + case(op_broadcast_val,& + op_sync_mess,op_break_loop,& + op_read_file_tile,op_write_file_tile,op_broadcast,& + op_broadcast_shared,op_nested_loop,& + op_blocked_loop,op_isend_offset,op_irecv_offset,& + op_recv_offset,op_recv_offset_resend,op_isend_reply,& + op_recv_reply,op_isend_req,op_isend_assn,op_active,op_get_size) + call cross_all_vars(g) + do i=0,n-1 + call use_var(g,g%codes(a+i)) call cross_var(g,g%codes(a+i)) enddo - save_lthis=g%lthis + case(op_remote_send_call,op_collect_call) + call cross_all_vars(g) + call use_var(g,g%codes(a)) + do i=6,n-1 !!! Dont use or cross outputs + call use_var(g,g%codes(a+i)) + call cross_var(g,g%codes(a+i)) + enddo + save_depth=g%depth call g_new_frame(g) call use_var(g,g%codes(a+4)) call cross_var(g,g%codes(a+4)) call use_var(g,g%codes(a+5)) call cross_var(g,g%codes(a+5)) call gen_var_block(g,g%codes(a+1)) - g%lthis=save_lthis + g%depth=save_depth call gen_var_block(g,g%codes(a+2)) call cross_all_vars(g) call use_var(g,g%codes(a)) @@ -573,14 +1833,14 @@ recursive subroutine gen_var_op(g,l) call use_var(g,g%codes(a+i)) call cross_var(g,g%codes(a+i)) enddo - save_lthis=g%lthis + save_depth=g%depth call g_new_frame(g) call use_var(g,g%codes(a+4)) call cross_var(g,g%codes(a+4)) call use_var(g,g%codes(a+8)) call cross_var(g,g%codes(a+8)) call gen_var_block(g,g%codes(a+1)) - g%lthis=save_lthis + g%depth=save_depth call gen_var_block(g,g%codes(a+2)) call cross_all_vars(g) call use_var(g,g%codes(a)) @@ -595,14 +1855,14 @@ recursive subroutine gen_var_op(g,l) call use_var(g,g%codes(a+i)) call cross_var(g,g%codes(a+i)) enddo - save_lthis=g%lthis + save_depth=g%depth call g_new_frame(g) call use_var(g,g%codes(a+2)) call cross_var(g,g%codes(a+2)) call use_var(g,g%codes(a+3)) call cross_var(g,g%codes(a+3)) call gen_var_block(g,g%codes(a+1)) - g%lthis=save_lthis + g%depth=save_depth call cross_all_vars(g) call use_var(g,g%codes(a)) do i=5,n-1 @@ -615,7 +1875,7 @@ recursive subroutine gen_var_op(g,l) call use_var(g,g%codes(a+4)) call cross_var(g,g%codes(a+4)) call cross_all_vars(g) - save_lthis=g%lthis + save_depth=g%depth call g_new_frame(g) call cross_all_vars(g) call use_var(g,g%codes(a+2)) @@ -628,7 +1888,7 @@ recursive subroutine gen_var_op(g,l) endif call gen_var_block(g,g%codes(a+1)) call cross_all_vars(g) - g%lthis=save_lthis + g%depth=save_depth case(op_do_at) call use_var(g,g%codes(a)) if(opcode2==0) then @@ -646,52 +1906,184 @@ recursive subroutine gen_var_op(g,l) call use_var(g,g%codes(a+i)) enddo end select - - if(debug_g) write(*,*) 'END VAR OP> ',l,op_names(opcode) - - end subroutine gen_var_op - - !============================================================= - ! Variable assignment phase for a block with comm operations - !============================================================= - subroutine gen_var_comm_block(g,blk) - type(gen_state):: g - integer,intent(in):: blk - integer:: save_lthis,ll - save_lthis=g%lthis - if(debug_g) write(*,*) 'VAR COMM BLK>',blk - call g_new_frame(g) - ll=blk - do while(ll>0) - g%lstack(g%lthis)%idx=g%lstack(g%lthis)%idx+1 - call gen_var_op(g,ll) - ll=g%codes(ll) - enddo - g%lthis=save_lthis - if(debug_g) write(*,*) 'VAR COMM BLK>',blk - end subroutine gen_var_comm_block - - !============================================================= - ! Variable assignment phase for inline shared proc body - !============================================================= - subroutine gen_var_shared_block(g,blk) - type(gen_state):: g - integer,intent(in):: blk - integer:: save_lthis,ll - if(debug_g) write(*,*) 'VAR SHARED BLK>',blk - save_lthis=g%lthis - call g_new_frame(g) - g%lstack(g%lthis)%loop_mode=loop_is_none - ll=blk - do while(ll>0) - g%lstack(g%lthis)%idx=g%lstack(g%lthis)%idx+1 - call gen_var_op(g,ll) - ll=g%codes(ll) - enddo - call sort_var_list(g) - g%lthis=save_lthis - if(debug_g) write(*,*) 'END VAR SHARED BLK>',blk - end subroutine gen_var_shared_block + + if(debug_g) write(*,*) 'END VAR OP> ',l,op_names(opcode) + + end subroutine gen_var_op + + !================================================================= + ! Use a variable - called in variable allocation phase + ! Employs simple state engine to determine how a variable needs + ! to be stored + !================================================================= + recursive subroutine use_var(g,avar,isassign) + type(gen_state),intent(inout):: g + integer,intent(in):: avar + logical,intent(in),optional:: isassign + integer:: kind,state,i,j,var,flags,tno,oldstate + integer,parameter,dimension(var_state_unused:var_state_closed):: new_state=(/& + var_state_used, & ! var_state_unused + var_state_used, & ! var_state_open + var_state_used, & ! var_state_used + var_state_crossing, & ! var_state_used_before + var_state_crossing, & ! var_state_crossing + var_state_used & ! var_state_closed + /) + if(avar==0.or.avar==shared_op_flag) return + var=abs(avar) + if(debug_g) write(*,*) 'USE VAR> ',var,g_index(g,var),g%depth,g%lstack(g%depth)%idx !,g_kind(g,var),g_v1(g,var) + kind=g_kind(g,var) + select case(kind) + case(v_is_group) + do i=1,g_v1(g,var) + call use_var(g,g_ptr(g,var,i),isassign) + enddo + case(v_is_sub,v_is_vsub) + call use_var(g,g_v1(g,var),isassign) + call use_var(g,g_v2(g,var),isassign) + case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) + call use_var(g,g_v1(g,var),isassign) + case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) + continue + case(v_is_cove) + call use_var(g,g_v2(g,var),isassign) + g%varindex(var)=g%varindex(g_v2(g,var)) + case(v_is_alias) + call use_var(g,g_v1(g,var),isassign) + g%varindex(var)=g%varindex(g_v1(g,var)) + case(v_is_chan_vect) + call use_var(g,g_v1(g,var),isassign) + g%varindex(var)=g%varindex(g_v1(g,var)) + case default + i=g%varindex(var) + if(g%vardata(i)%state==var_state_unused) then + if(kind==v_is_ve) then + call use_var(g,g_v1(g,var)) + endif + flags=g%vardata(i)%flags + if(iand(g%taints,proc_is_comm)/=0.and.& + iand(flags,v_is_param+v_is_result)/=0) then + if(iand(flags,v_is_shared)/=0) then + g%vardata(i)%state=var_state_used + g%vardata(i)%depth=g%depth + else + g%vardata(i)%state=var_state_crossing + if(iand(flags,v_is_result)/=0) then + g%vardata(i)%depth=g%depth + else + g%vardata(i)%depth=g%depth+1 + endif + endif + else + g%vardata(i)%depth=g%depth + g%vardata(i)%state=var_state_used + endif + g%vardata(i)%outer_depth=g%vardata(i)%depth + g%vardata(i)%start=g%lstack(g%depth)%idx + g%vardata(i)%finish=g%vardata(i)%start + if(debug_g) write(*,*) 'START/FINISH=',g%vardata(i)%start + g%vardata(i)%link=g%lstack(g%depth)%varlist + g%lstack(g%depth)%varlist=i + !g%vardata(i)%oindex=var + g%vardata(i)%finish_on_assign=.false. + g%vardata(i)%free=0 + if(debug_g) write(*,*) 'NEW VAR>',var,i, g%vardata(i)%link + else + oldstate=g%vardata(i)%state + g%vardata(i)%state=new_state(g%vardata(i)%state) + g%vardata(i)%finish=g%lstack(g%vardata(i)%depth)%idx + if(debug_g) then + write(*,*) 'FINISH=',g%vardata(i)%start,g%vardata(i)%finish,g%vardata(i)%depth + endif + g%vardata(i)%outer_depth=g_common_frame(g,g%vardata(i)%outer_depth,g%depth) + g%vardata(i)%flags=ior(g%vardata(i)%flags,& + merge(var_is_reused,var_is_used,iand(g%vardata(i)%flags,var_is_used)/=0)) + if(debug_g) then + write(*,*) 'CONSIDER>',i,present(isassign) + endif + g%vardata(i)%finish_on_assign=present(isassign) + endif + end select + end subroutine use_var + + !=========================================================== + ! In variable allocation phase - flag all active variables + ! when a comm op is encountered + !============================================================ + subroutine cross_all_vars(g) + type(gen_state),intent(inout):: g + integer:: var + if(g%lstack(g%depth)%loop_mode==loop_is_none) return + g%loop_contains_shared=.true. + if(debug_g) write(*,*) 'CROSS ALL' + var=g%lstack(g%depth)%varlist + do while(var>0) + if(debug_g) write(*,*) 'CROSS',var,'IN CROSS ALL' + call cross_var_at_index(g,var) + var=g%vardata(var)%link + end do + if(debug_g) write(*,*) 'CROSSED ALL' + end subroutine cross_all_vars + + !============================================================ + ! Flag a single variable crossed by comm op + !============================================================ + subroutine cross_var_at_index(g,i) + type(gen_state),intent(inout):: g + integer,intent(in):: i + integer:: state + integer,parameter,dimension(var_state_unused:var_state_closed):: new_state=(/& + var_state_unused, & ! var_state_unused + var_state_open, & ! var_state_open + var_state_used_before, & ! var_state_used + var_state_used_before, & ! var_state_used_before + var_state_crossing, & ! var_state_crossing + var_state_closed & ! var_state_closed + /) + if(g%lstack(g%depth)%loop_mode==loop_is_none) return + if(i==0) return + if(g%vardata(i)%depth/=g%depth) return + if(iand(g%vardata(i)%flags,v_is_shared)/=0) return + state=g%vardata(i)%state + if(debug_g) write(*,*) 'Crossing',i,state,new_state(state) + g%vardata(i)%state=new_state(state) + end subroutine cross_var_at_index + + !================================================================== + ! Mark a variable as crossed (forced -not dependent on prior state) + !================================================================== + recursive subroutine cross_var(g,avar) + type(gen_state),intent(inout):: g + integer,intent(in):: avar + integer:: i,var + if(g%lstack(g%depth)%loop_mode==loop_is_none) return + if(avar==0.or.avar==shared_op_flag) return + var=abs(avar) + select case(g_kind(g,var)) + case(v_is_group) + do i=1,g_v1(g,var) + call cross_var(g,g_ptr(g,var,i)) + enddo + case(v_is_sub,v_is_vsub) + call cross_var(g,g_v1(g,var)) + call cross_var(g,g_v2(g,var)) + case(v_is_elem,v_is_unit_elem) + call cross_var(g,g_v1(g,var)) + case(v_is_alias) + call cross_var(g,g_v1(g,var)) + case(v_is_const,v_is_ctime_const,v_is_ve,v_is_cove) + continue + case default + i=g%varindex(var) + if(i/=0) then + if(g%vardata(i)%depth==g%depth.and.& + iand(g%vardata(i)%flags,v_is_shared)==0) then + !g%vardata(i)%state=var_state_crossing# + g%vardata(i)%flags=ior(g%vardata(i)%flags,var_is_comm_op_par) + endif + endif + end select + end subroutine cross_var !======================================================================= ! Reverse list of vars (varlist/link) for current loop context @@ -702,21 +2094,21 @@ subroutine sort_var_list(g) type(gen_state):: g integer:: v,v2 integer:: finish,next,nextv - v=g%lstack(g%lthis)%varlist - g%lstack(g%lthis)%varlist=0 - g%lstack(g%lthis)%evarlist=0 + v=g%lstack(g%depth)%varlist + g%lstack(g%depth)%varlist=0 + g%lstack(g%depth)%evarlist=0 do while(v>0) nextv=g%vardata(v)%link - g%vardata(v)%link=g%lstack(g%lthis)%varlist - g%lstack(g%lthis)%varlist=v - v2=g%lstack(g%lthis)%evarlist + g%vardata(v)%link=g%lstack(g%depth)%varlist + g%lstack(g%depth)%varlist=v + v2=g%lstack(g%depth)%evarlist finish=g%vardata(v)%finish if(v2==0) then - g%lstack(g%lthis)%evarlist=v + g%lstack(g%depth)%evarlist=v g%vardata(v)%elink=0 elseif(g%vardata(v2)%finish>=finish) then g%vardata(v)%elink=v2 - g%lstack(g%lthis)%evarlist=v + g%lstack(g%depth)%evarlist=v else do while(g%vardata(v2)%elink>0) next=g%vardata(v2)%elink @@ -731,13 +2123,13 @@ subroutine sort_var_list(g) if(debug_g) then write(*,*) 'REVERSE OUT VARLIST>' - v=g%lstack(g%lthis)%varlist + v=g%lstack(g%depth)%varlist do while(v>0) write(*,*) v,g%vardata(v)%start v=g%vardata(v)%link enddo write(*,*) 'SORT OUT EVARLIST>' - v=g%lstack(g%lthis)%evarlist + v=g%lstack(g%depth)%evarlist do while(v>0) write(*,*) v,g%vardata(v)%finish v=g%vardata(v)%elink @@ -754,9 +2146,9 @@ end subroutine sort_var_list subroutine alloc_var_list(g) type(gen_state):: g integer:: v,e,i - if(debug_g) write(*,*) 'ALLOCATING>',g%lthis - v=g%lstack(g%lthis)%varlist - e=g%lstack(g%lthis)%evarlist + if(debug_g) write(*,*) 'ALLOCATING>',g%depth + v=g%lstack(g%depth)%varlist + e=g%lstack(g%depth)%evarlist do while(v/=0.and.e/=0) i=min(g%vardata(v)%start,g%vardata(e)%finish+1) do while(g%vardata(e)%finish+1==i) @@ -783,7 +2175,7 @@ subroutine alloc_var_list(g) call deallocate_var(g,e) e=g%vardata(e)%elink enddo -!!$ v=g%lstack(g%lthis)%varlist +!!$ v=g%lstack(g%depth)%varlist !!$ do while(v/=0) !!$ write(34,*) g%vardata(v)%index,g_var_at_index_is_a_vect(g,v) !!$ v=g%vardata(v)%link @@ -809,7 +2201,7 @@ subroutine allocate_var(g,v) if(debug_g) write(*,*) 'no storage',tno elseif(tno>pm_string) then if(debug_g) write(*,*) 'Free hash',tno - key(1)=g%lthis + key(1)=g%depth key(2)=isvect key(3)=tno j=pm_ivect_lookup(g%context,g%freehash,key,3) @@ -819,7 +2211,7 @@ subroutine allocate_var(g,v) if(idx/=0) then p%offset=g%vardata(idx)%free call pm_dict_set_val(g%context,g%freehash,j,p) - g%vardata(idx)%gflags=ior(g%vardata(idx)%gflags,var_is_recycled) + g%vardata(idx)%flags=ior(g%vardata(idx)%flags,var_is_recycled) idx=abs(g%vardata(idx)%index) else g%index=g%index+1 @@ -829,11 +2221,11 @@ subroutine allocate_var(g,v) idx=-v endif else - if(debug_g) write(*,*) 'Freelist',tno,g%lstack(g%lthis)%free(isvect,tno) - if(g%lstack(g%lthis)%free(isvect,tno)/=0) then - idx=g%lstack(g%lthis)%free(isvect,tno) - g%lstack(g%lthis)%free(isvect,tno)=g%vardata(idx)%free - g%vardata(idx)%gflags=ior(g%vardata(idx)%gflags,var_is_recycled) + if(debug_g) write(*,*) 'Freelist',tno,g%lstack(g%depth)%free(isvect,tno) + if(g%lstack(g%depth)%free(isvect,tno)/=0) then + idx=g%lstack(g%depth)%free(isvect,tno) + g%lstack(g%depth)%free(isvect,tno)=g%vardata(idx)%free + g%vardata(idx)%flags=ior(g%vardata(idx)%flags,var_is_recycled) idx=abs(g%vardata(idx)%index) if(debug_g) write(*,*) 'get free',idx else @@ -843,7 +2235,7 @@ subroutine allocate_var(g,v) else idx=0 endif - if(debug_g) write(*,*) 'ALLOCATED>',v,idx,g%lthis + if(debug_g) write(*,*) 'ALLOCATED>',v,idx,g%depth g%vardata(v)%index=idx end subroutine allocate_var @@ -862,10 +2254,10 @@ subroutine deallocate_var(g,v) isvect=merge(2,1,g_var_at_index_is_a_vect(g,v)) if(debug_g) write(*,*) 'Deallocate',v,tno,isvect if(tno<=pm_string) then - g%vardata(v)%free=g%lstack(g%lthis)%free(isvect,tno) - g%lstack(g%lthis)%free(isvect,tno)=v + g%vardata(v)%free=g%lstack(g%depth)%free(isvect,tno) + g%lstack(g%depth)%free(isvect,tno)=v else - key(1)=g%lthis + key(1)=g%depth key(2)=isvect key(3)=tno j=pm_ivect_lookup(g%context,g%freehash,key,3) @@ -904,7 +2296,7 @@ function merge_vars(g,v,e,i) result(merged) merged=.false. else g%vardata(v)%index=abs(g%vardata(e)%index) - g%vardata(e)%gflags=ior(g%vardata(e)%gflags,var_is_recycled) + g%vardata(e)%flags=ior(g%vardata(e)%flags,var_is_recycled) if(debug_g) then write(*,*) 'MERGED>',g%vardata(v)%index endif @@ -915,202 +2307,6 @@ function merge_vars(g,v,e,i) result(merged) endif end function merge_vars - !================================================================= - ! Use a variable - called in variable allocation phase - ! Employs simple state engine to determine how a variable needs - ! to be stored - !================================================================= - recursive subroutine use_var(g,avar,isassign) - type(gen_state),intent(inout):: g - integer,intent(in):: avar - logical,intent(in),optional:: isassign - integer:: kind,state,i,j,var,flags,tno - integer,parameter,dimension(var_state_unused:var_state_closed):: new_state=(/& - var_state_used, & ! var_state_unused - var_state_used, & ! var_state_open - var_state_used, & ! var_state_used - var_state_crossing, & ! var_state_used_before - var_state_crossing, & ! var_state_crossing - var_state_used & ! var_state_closed - /) - if(avar==0.or.avar==shared_op_flag) return - var=abs(avar) - if(debug_g) write(*,*) 'USE VAR> ',var,g_index(g,var),g%lthis,g%lstack(g%lthis)%idx !,g_kind(g,var),g_v1(g,var) - kind=g_kind(g,var) - select case(kind) - case(v_is_group) - do i=1,g_v1(g,var) - call use_var(g,g_ptr(g,var,i),isassign) - enddo - case(v_is_sub,v_is_vsub) - call use_var(g,g_v1(g,var),isassign) - call use_var(g,g_v2(g,var),isassign) - case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) - call use_var(g,g_v1(g,var),isassign) - !g%varindex(var)=g%varindex(g_v1(g,var)) - case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) - continue - case(v_is_cove) - call use_var(g,g_v2(g,var),isassign) - g%varindex(var)=g%varindex(g_v2(g,var)) - case(v_is_alias) - call use_var(g,g_v1(g,var),isassign) - g%varindex(var)=g%varindex(g_v1(g,var)) - case(v_is_chan_vect) - call use_var(g,g_v1(g,var),isassign) - g%varindex(var)=g%varindex(g_v1(g,var)) - case default - i=g%varindex(var) - if(i==0) then - g%nvars=g%nvars+1 - if(debug_g) write(*,*) 'CREATE>',var,g%nvars - i=g%nvars - if(kind==v_is_parve) then - g%vardata(i)%tno=pm_logical - flags=v_is_param - g%vardata(i)%name=0 - elseif(kind==v_is_ve) then - call use_var(g,g_v1(g,var)) - g%vardata(i)%tno=pm_logical - flags=0 - g%vardata(i)%name=0 - else - flags=g_v2(g,var) - tno=g_type(g,var) - g%vardata(i)%tno=tno - if(iand(flags,v_is_array_par_vect)==0) then - g%vardata(i)%name=g_v1(g,var) - else - g%vardata(i)%name=0 - endif - endif - g%vardata(i)%flags=flags - if(iand(g%taints,proc_is_comm)/=0.and.& - iand(flags,v_is_param+v_is_result)/=0) then - if(iand(flags,v_is_shared)/=0) then - g%vardata(i)%state=var_state_used - g%vardata(i)%lthis=g%lthis - else - g%vardata(i)%state=var_state_crossing - if(iand(flags,v_is_result)/=0) then - g%vardata(i)%lthis=g%lthis - else - g%vardata(i)%lthis=g%lthis+1 - endif - endif - else - g%vardata(i)%lthis=g%lthis - g%vardata(i)%state=var_state_used - endif - g%vardata(i)%outer_lthis=g%vardata(i)%lthis - g%vardata(i)%start=g%lstack(g%lthis)%idx - g%vardata(i)%finish=g%vardata(i)%start - if(debug_g) write(*,*) 'START/FINISH=',g%vardata(i)%start - g%vardata(i)%index=0 - g%vardata(i)%link=g%lstack(g%lthis)%varlist - g%vardata(i)%gflags=0 - g%lstack(g%lthis)%varlist=i - g%vardata(i)%oindex=var - g%vardata(i)%finish_on_assign=.false. - g%vardata(i)%free=0 - g%varindex(var)=i - if(debug_g) write(*,*) 'NEW VAR>',var,i, g%vardata(i)%link - else - g%vardata(i)%state=new_state(g%vardata(i)%state) - g%vardata(i)%finish=g%lstack(g%vardata(i)%lthis)%idx - if(debug_g) then - write(*,*) 'FINISH=',g%vardata(i)%start,g%vardata(i)%finish,g%vardata(i)%lthis - endif - g%vardata(i)%outer_lthis=g_common_frame(g,g%vardata(i)%outer_lthis,g%lthis) - g%vardata(i)%gflags=ior(g%vardata(i)%gflags,& - merge(var_is_reused,var_is_used,iand(g%vardata(i)%gflags,var_is_used)/=0)) - if(debug_g) then - write(*,*) 'CONSIDER>',i,present(isassign) - endif - g%vardata(i)%finish_on_assign=present(isassign) - endif - end select - end subroutine use_var - - !=========================================================== - ! In variable allocation phase - flag all active variables - ! when a comm op is encountered - !============================================================ - subroutine cross_all_vars(g) - type(gen_state),intent(inout):: g - integer:: var - if(g%lstack(g%lthis)%loop_mode==loop_is_none) return - g%loop_contains_shared=.true. - if(debug_g) write(*,*) 'CROSS ALL' - var=g%lstack(g%lthis)%varlist - do while(var>0) - if(debug_g) write(*,*) 'CROSS',var,'IN CROSS ALL' - call cross_var_at_index(g,var) - var=g%vardata(var)%link - end do - if(debug_g) write(*,*) 'CROSSED ALL' - end subroutine cross_all_vars - - !============================================================ - ! Flag a single variable crossed by comm op - !============================================================ - subroutine cross_var_at_index(g,i) - type(gen_state),intent(inout):: g - integer,intent(in):: i - integer:: state - integer,parameter,dimension(var_state_unused:var_state_closed):: new_state=(/& - var_state_unused, & ! var_state_unused - var_state_open, & ! var_state_open - var_state_used_before, & ! var_state_used - var_state_used_before, & ! var_state_used_before - var_state_crossing, & ! var_state_crossing - var_state_closed & ! var_state_closed - /) - if(g%lstack(g%lthis)%loop_mode==loop_is_none) return - if(i==0) return - if(g%vardata(i)%lthis/=g%lthis) return - if(iand(g%vardata(i)%flags,v_is_shared)/=0) return - state=g%vardata(i)%state - if(debug_g) write(*,*) 'Crossing',i,state,new_state(state) - g%vardata(i)%state=new_state(state) - end subroutine cross_var_at_index - - !================================================================== - ! Mark a variable as crossed (forced -not dependent on prior state) - !================================================================== - recursive subroutine cross_var(g,avar) - type(gen_state),intent(inout):: g - integer,intent(in):: avar - integer:: i,var - if(g%lstack(g%lthis)%loop_mode==loop_is_none) return - if(avar==0.or.avar==shared_op_flag) return - var=abs(avar) - select case(g_kind(g,var)) - case(v_is_group) - do i=1,g_v1(g,var) - call cross_var(g,g_ptr(g,var,i)) - enddo - case(v_is_sub,v_is_vsub) - call cross_var(g,g_v1(g,var)) - call cross_var(g,g_v2(g,var)) - case(v_is_elem,v_is_unit_elem) - call cross_var(g,g_v1(g,var)) - case(v_is_alias) - call cross_var(g,g_v1(g,var)) - case(v_is_const,v_is_ctime_const,v_is_ve,v_is_cove) - continue - case default - i=g%varindex(var) - if(i/=0) then - if(g%vardata(i)%lthis==g%lthis.and.& - iand(g%vardata(i)%flags,v_is_shared)==0) then - !g%vardata(i)%state=var_state_crossing# - g%vardata(i)%gflags=ior(g%vardata(i)%gflags,var_is_comm_op_par) - endif - endif - end select - end subroutine cross_var - !============================================================ ! If a variable was created outside of an iterative loop ! then its lifetime must extend at least to the end of that @@ -1123,7 +2319,7 @@ subroutine extend_finish_to_loop(g,loop_start_idx,loop_finish_idx,last_var_befor ! Loop over vars created before loop var=last_var_before_loop do while(var>0) - if(g%vardata(var)%lthis==g%lthis) then + if(g%vardata(var)%depth==g%depth) then if(g%vardata(var)%finish>=loop_start_idx) then g%vardata(var)%finish=loop_finish_idx endif @@ -1162,7 +2358,7 @@ end subroutine gen_block recursive subroutine gen_op(g,loc) type(gen_state):: g integer,intent(in):: loc - integer:: opcode,opcode2,n,a,arg,save_lthis,l,ll,i,j,k,m,tno + integer:: opcode,opcode2,n,a,arg,save_depth,l,ll,i,j,k,m,tno logical:: ok,need_endif if(pm_debug_level>0) then @@ -1197,7 +2393,7 @@ recursive subroutine gen_op(g,loc) endif if(pm_opts%ftn_annotate) then - call out_char_idx(g,'!',merge(1000,0,g%lstack(g%lthis)%loop_active)+g%lthis) + call out_char_idx(g,'!',merge(1000,0,g%lstack(g%depth)%loop_active)+g%depth) call out_new_line(g) endif @@ -1256,7 +2452,7 @@ recursive subroutine gen_op(g,loc) do i=n/2,1,-1 call out_str(g,'DO I') call out_idx(g,i-1) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) call out_str(g,'=0,-1+') call out_arg(g,g%codes(a+i+n/2),arg_no_index) call out_new_line(g) @@ -1265,41 +2461,41 @@ recursive subroutine gen_op(g,loc) call out_arg(g,g%codes(a+i),0) call out_str(g,'=I') call out_idx(g,i-1) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) call out_new_line(g) enddo - call out_char_idx(g,'I',g%lthis) + call out_char_idx(g,'I',g%depth) call out_str(g,'=1+') call out_char_idx(g,'I',0) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) do i=2,n/2 call out_char(g,'+') call out_arg(g,g%codes(a+i+n/2-1),0) call out_str(g,'*(I') call out_idx(g,i-1) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) enddo do i=2,n/2 call out_char(g,')') enddo call out_new_line(g) - g%lstack(g%lthis)%nloops=n/2 - g%lstack(g%lthis)%loop_mode=loop_is_contig - g%lstack(g%lthis)%loop_active=.true. + g%lstack(g%depth)%nloops=n/2 + g%lstack(g%depth)%loop_mode=loop_is_contig + g%lstack(g%depth)%loop_active=.true. case(op_nested_loop) call gen_loop(g,l,.true.) - g%lstack(g%lthis)%loop_par=g%codes(a+1) - g%lstack(g%lthis)%loop_mode=loop_is_nested + g%lstack(g%depth)%loop_par=g%codes(a+1) + g%lstack(g%depth)%loop_mode=loop_is_nested case(op_blocked_loop) call gen_loop(g,l,.true.) - g%lstack(g%lthis)%loop_par=g%codes(a+n-1) - g%lstack(g%lthis)%loop_mode=loop_is_nested + g%lstack(g%depth)%loop_par=g%codes(a+n-1) + g%lstack(g%depth)%loop_mode=loop_is_nested call gen_loop(g,l,.false.) do i=1,n-2 call out_arg(g,g%codes(a+i),0) call out_str(g,'=I') call out_idx(g,i) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) call out_new_line(g) enddo case(op_skip_empty) @@ -1346,7 +2542,7 @@ recursive subroutine gen_op(g,loc) call out_ftn_name(g,g_procname(g,opcode2)) endif call out_str(g,'(N') - call out_idx(g,g%lthis) + call out_idx(g,g%depth) call out_char(g,',') if(g%codes(a)>0) then call out_call_arg(g,g%codes(a),arg_no_index+arg_comm_arg) @@ -1403,13 +2599,13 @@ recursive subroutine gen_op(g,loc) case(op_do_at) call gen_loop(g,l,.false.) if(opcode2==1) then - call out_simple(g,'IDO=I$N',n=g%lthis) + call out_simple(g,'IDO=I$N',n=g%depth) else call out_simple(g,'IDO=$2+1',l) endif - i=g_lthis(g,g%codes(a+merge(2,3,opcode2==1))) + i=g_depth(g,g%codes(a+merge(2,3,opcode2==1))) if(i/=0.and.g%lstack(i)%loop_active) then - write(*,*) 'lthis=',g%lthis,'from',g%codes(a+3) + write(*,*) 'depth=',g%depth,'from',g%codes(a+3) call pm_panic('Loop active in op_do_at') endif g%lalt=i @@ -1430,8 +2626,8 @@ recursive subroutine gen_op(g,loc) continue case(op_wrap) ! Save the current loop context for variable - !write(*,*) 'WRAP',g%lthis,'to',g%codes(a+1) - call g_set_v2(g,g%codes(a+1),g%lthis) + !write(*,*) 'WRAP',g%depth,'to',g%codes(a+1) + call g_set_v2(g,g%codes(a+1),g%depth) case(op_sync) call gen_loop(g,l,.true.) @@ -1522,8 +2718,8 @@ recursive subroutine gen_op(g,loc) !call out_line(g,'write(*,*) "ISEND_ASSN"') call out_simple(g,'JNODE=$2',l) if(n>6) then - call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%lthis) - call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$6,NREQ)',l,n=g%lthis) + call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%depth) + call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$6,NREQ)',l,n=g%depth) call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') call out_line(g,'CALL MPI_ISEND(NREQ,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)') call out_line(g,'PM__PUSH_MESSAGE(JMESS)') @@ -1554,8 +2750,8 @@ recursive subroutine gen_op(g,loc) call gen_active_check_start(g,l) call out_simple(g,'JNODE=$2',l) if(n>4) then - call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%lthis) - call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$5,NREQ)',l,n=g%lthis) + call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%depth) + call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$5,NREQ)',l,n=g%depth) call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') call gen_mpi_recv_part(g,g%codes(a+3),'PM__DATA_TAG','RECV',.true.,'RBUFFER%P','1','NREQ',mode_vect) else @@ -1735,7 +2931,7 @@ recursive subroutine gen_op(g,loc) call out_char(g,'(') if(g_is_vect(g,g%codes(a+1))) then call out_str(g,'IJ,I') - call out_idx(g,g%lthis) + call out_idx(g,g%depth) call out_str(g,')=') else call out_str(g,'IJ)=') @@ -1783,10 +2979,10 @@ recursive subroutine gen_op(g,loc) call gen_loop(g,l,.true.) call out_get_mpi_base_type(g,g_type(g,g%codes(a+3))) call out_simple(g,'CALL PM__FILE_SET_VIEW($2,JBASE,$#4,N$N,$5,$1,OFFSET)',l,& - n=g%lthis) + n=g%depth) call out_simple(g,'IF($1==0) THEN',l) call out_get_mpi_base_type(g,g_type(g,g%codes(a+5))) - call out_simple(g,'CALL PM__GET_MPI_TYPE(JBASE,N$N,JTYPE,JN,LNEW)',l,n=g%lthis) + call out_simple(g,'CALL PM__GET_MPI_TYPE(JBASE,N$N,JTYPE,JN,LNEW)',l,n=g%depth) if(opcode==op_read_file_tile) then call out_simple(g,'CALL MPI_FILE_READ_ALL($2,$#3,JN,JTYPE,MPI_STATUS_IGNORE,$1)',l) else @@ -1995,12 +3191,12 @@ subroutine gen_over_block(g,l,blk) type(gen_state):: g integer,intent(in):: l,blk type(gloop):: save_loop - save_loop=g%lstack(g%lthis) - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_none + save_loop=g%lstack(g%depth) + g%lstack(g%depth)%nloops=0 + g%lstack(g%depth)%loop_mode=loop_is_none call gen_block(g,blk) call gen_loop(g,l,.true.) - g%lstack(g%lthis)=save_loop + g%lstack(g%depth)=save_loop end subroutine gen_over_block !============================================================ @@ -2010,20 +3206,20 @@ subroutine gen_comm_block(g,l,lnew,nc) type(gen_state):: g integer,intent(in):: l,lnew character(len=*),intent(in):: nc - integer:: save_lthis,ll,save_last_ve + integer:: save_depth,ll,save_last_ve call gen_loop(g,l,.false.) save_last_ve=g%last_ve g%last_ve=0 g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_contig + save_depth=g%depth + g%depth=g%ltop + g%lstack(g%depth)%nloops=0 + g%lstack(g%depth)%loop_mode=loop_is_contig - if(pm_opts%ftn_annotate) call out_simple(g,'! BLOCK -> $N',n=g%lthis) - if(nc/=' ') call out_simple(g,'N$N='//nc,l,n=g%lthis) + if(pm_opts%ftn_annotate) call out_simple(g,'! BLOCK -> $N',n=g%depth) + if(nc/=' ') call out_simple(g,'N$N='//nc,l,n=g%depth) call gen_vect_alloc(g) - g%lstack(g%lthis)%loop_active=.false. + g%lstack(g%depth)%loop_active=.false. ll=lnew do while(ll>0) call gen_op(g,ll) @@ -2031,8 +3227,8 @@ subroutine gen_comm_block(g,l,lnew,nc) enddo call gen_loop(g,l,.true.) call gen_vect_dealloc(g) - if(pm_opts%ftn_annotate) call out_simple(g,'!ENDBLOCK -> $N',n=g%lthis) - g%lthis=save_lthis + if(pm_opts%ftn_annotate) call out_simple(g,'!ENDBLOCK -> $N',n=g%depth) + g%depth=save_depth g%last_ve=save_last_ve end subroutine gen_comm_block @@ -2040,7 +3236,7 @@ subroutine gen_mpi_recv_call(g,l,lnew,assn) type(gen_state):: g integer,intent(in):: l,lnew logical,intent(in):: assn - integer:: a,save_lthis,ll,save_last_ve + integer:: a,save_depth,ll,save_last_ve a=l+comp_op_arg0 !call out_line(g,'write(*,*) "RECV CALL"') call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') @@ -2052,11 +3248,11 @@ subroutine gen_mpi_recv_call(g,l,lnew,assn) save_last_ve=g%last_ve g%last_ve=0 g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_contig - call out_simple(g,'CALL MPI_RECV(N$N,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,MPI_STATUS_IGNORE,JERRNO)',n=g%lthis) + save_depth=g%depth + g%depth=g%ltop + g%lstack(g%depth)%nloops=0 + g%lstack(g%depth)%loop_mode=loop_is_contig + call out_simple(g,'CALL MPI_RECV(N$N,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,MPI_STATUS_IGNORE,JERRNO)',n=g%depth) call gen_vect_alloc(g) call gen_mpi_recv(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','RECV',mode_vect,.false.) if(assn) then @@ -2076,7 +3272,7 @@ subroutine gen_mpi_recv_call(g,l,lnew,assn) enddo call gen_loop(g,l,.true.) call gen_vect_dealloc(g) - g%lthis=save_lthis + g%depth=save_depth g%last_ve=save_last_ve end subroutine gen_mpi_recv_call @@ -2087,23 +3283,23 @@ end subroutine gen_mpi_recv_call subroutine gen_shared_block(g,l,lnew) type(gen_state):: g integer,intent(in):: l,lnew - integer:: save_lthis,ll,save_last_ve + integer:: save_depth,ll,save_last_ve call gen_loop(g,l,.true.) save_last_ve=g%last_ve g%last_ve=0 g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_none - if(pm_opts%ftn_annotate) call out_simple(g,'! SHARED BLOCK -> $N',n=g%lthis) + save_depth=g%depth + g%depth=g%ltop + g%lstack(g%depth)%nloops=0 + g%lstack(g%depth)%loop_mode=loop_is_none + if(pm_opts%ftn_annotate) call out_simple(g,'! SHARED BLOCK -> $N',n=g%depth) ll=lnew do while(ll>0) call gen_op(g,ll) ll=g%codes(ll) enddo - if(pm_opts%ftn_annotate) call out_simple(g,'!END SHARED BLOCK -> $N',n=g%lthis) - g%lthis=save_lthis + if(pm_opts%ftn_annotate) call out_simple(g,'!END SHARED BLOCK -> $N',n=g%depth) + g%depth=save_depth g%last_ve=save_last_ve end subroutine gen_shared_block @@ -2114,23 +3310,23 @@ end subroutine gen_shared_block !================================================================ subroutine g_new_frame(g) type(gen_state),intent(inout):: g - integer:: old_lthis - old_lthis=g%lthis + integer:: old_depth + old_depth=g%depth g%ltop=g%ltop+1 - g%lthis=g%ltop - g%lstack(g%lthis)%varlist=0 - g%lstack(g%lthis)%evarlist=0 - g%lstack(g%lthis)%defer_free=0 - g%lstack(g%lthis)%idx=0 - g%lstack(g%lthis)%free=0 - g%lstack(g%lthis)%loop_mode=loop_is_contig - g%lstack(g%lthis)%loop_active=.false. - if(g%lthis==0) then - g%lstack(g%lthis)%parent=0 - g%lstack(g%lthis)%depth=0 + g%depth=g%ltop + g%lstack(g%depth)%varlist=0 + g%lstack(g%depth)%evarlist=0 + g%lstack(g%depth)%defer_free=0 + g%lstack(g%depth)%idx=0 + g%lstack(g%depth)%free=0 + g%lstack(g%depth)%loop_mode=loop_is_contig + g%lstack(g%depth)%loop_active=.false. + if(g%depth==0) then + g%lstack(g%depth)%parent=0 + g%lstack(g%depth)%depth=0 else - g%lstack(g%lthis)%parent=old_lthis - g%lstack(g%lthis)%depth=g%lstack(old_lthis)%depth+1 + g%lstack(g%depth)%parent=old_depth + g%lstack(g%depth)%depth=g%lstack(old_depth)%depth+1 endif end subroutine g_new_frame @@ -2138,33 +3334,33 @@ end subroutine g_new_frame ! Given the indices of two loop stack frames, determine the ! index of a third frame that is common parent to both !================================================================ - function g_common_frame(g,lthis_1,lthis_2) result(lthis) + function g_common_frame(g,depth_1,depth_2) result(depth) type(gen_state):: g - integer,intent(in):: lthis_1,lthis_2 - integer:: lthis1,lthis2,lthis - lthis1=lthis_1 - lthis2=lthis_2 - if(lthis1==lthis2) then - lthis=lthis1 + integer,intent(in):: depth_1,depth_2 + integer:: depth1,depth2,depth + depth1=depth_1 + depth2=depth_2 + if(depth1==depth2) then + depth=depth1 return endif - do while(g%lstack(lthis1)%depth>g%lstack(lthis2)%depth) - !write(73,*) '1>',lthis1,g%lstack(lthis1)%depth - lthis1=g%lstack(lthis1)%parent + do while(g%lstack(depth1)%depth>g%lstack(depth2)%depth) + !write(73,*) '1>',depth1,g%lstack(depth1)%depth + depth1=g%lstack(depth1)%parent enddo - do while(g%lstack(lthis2)%depth>g%lstack(lthis1)%depth) - !write(73,*) '2>',lthis2,g%lstack(lthis2)%depth - lthis2=g%lstack(lthis2)%parent + do while(g%lstack(depth2)%depth>g%lstack(depth1)%depth) + !write(73,*) '2>',depth2,g%lstack(depth2)%depth + depth2=g%lstack(depth2)%parent enddo - do while(lthis1/=lthis2.and.lthis1/=0.and.lthis2/=0) - !write(73,*) '12>',lthis1,lthis2,g%lstack(lthis1)%depth - lthis1=g%lstack(lthis1)%parent - lthis2=g%lstack(lthis2)%parent + do while(depth1/=depth2.and.depth1/=0.and.depth2/=0) + !write(73,*) '12>',depth1,depth2,g%lstack(depth1)%depth + depth1=g%lstack(depth1)%parent + depth2=g%lstack(depth2)%parent enddo - !write(73,*) 'F>',lthis1,lthis2 - lthis=lthis1 - !write(73,*) lthis,min(lthis_1,lthis_2) - !if(lthis/=min(lthis_1,lthis_2)) write(73,*)'********' + !write(73,*) 'F>',depth1,depth2 + depth=depth1 + !write(73,*) depth,min(depth_1,depth_2) + !if(depth/=min(depth_1,depth_2)) write(73,*)'********' return end function g_common_frame @@ -2186,7 +3382,7 @@ subroutine gen_loop(g,l,isshared) ! Start up loops if((.not.shared).and.(.not.g_loop_active(g))) then call gen_loop_nest(g) - g%lstack(g%lthis)%loop_active=.true. + g%lstack(g%depth)%loop_active=.true. g%last_ve=0 endif @@ -2210,7 +3406,7 @@ end subroutine gen_loop function g_loop_active(g) result(ok) type(gen_state):: g logical:: ok - ok=g%lstack(g%lthis)%loop_active + ok=g%lstack(g%depth)%loop_active end function g_loop_active !============================================================ @@ -2224,23 +3420,23 @@ subroutine gen_loop_nest(g) if(g_loop_active(g)) return - select case(g%lstack(g%lthis)%loop_mode) + select case(g%lstack(g%depth)%loop_mode) case(loop_is_none) return case(loop_is_contig) call out_str(g,'DO I') - call out_idx(g,g%lthis) + call out_idx(g,g%depth) call out_str(g,'=1,N') - call out_idx(g,g%lthis) + call out_idx(g,g%depth) call out_new_line(g) nloops=1 case(loop_is_nested) - call gen_nested_loop(g,g%lstack(g%lthis)%loop_par,nloops) + call gen_nested_loop(g,g%lstack(g%depth)%loop_par,nloops) case default call pm_panic('gen_loop_nest') end select - g%lstack(g%lthis)%loop_active=.true. - g%lstack(g%lthis)%nloops=nloops + g%lstack(g%depth)%loop_active=.true. + g%lstack(g%depth)%nloops=nloops g%last_ve=0 end subroutine gen_loop_nest @@ -2273,19 +3469,19 @@ subroutine gen_nested_loop(g,v,nloops) case(1) ! single point call out_simple(g,'I$N_$M=$I+1 !!! moo',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) !nloops=nloops+1 case(2) ! range call out_simple_part(g,'DO I$N_$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_arg(g,g_ptr(g,vdim,2),0) call out_new_line(g) nloops=nloops+1 case(3) ! strided range call out_simple_part(g,'DO I$N_$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_arg(g,g_ptr(g,vdim,2),0) call out_char(g,',') call out_arg(g,g_ptr(g,vdim,3),0) @@ -2294,20 +3490,20 @@ subroutine gen_nested_loop(g,v,nloops) case(4) ! map seq call out_simple(g,'DO I$N__$M=1,$I',& - n=i,m=g%lthis,x=g_ptr(g,vdim,2)) + n=i,m=g%depth,x=g_ptr(g,vdim,2)) array=g_ptr(g,vdim,1) if(g_kind(g,array)==v_is_group) then call out_simple(g,'I$N_$M=$I(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,array,1)) + n=i,m=g%depth,x=g_ptr(g,array,1)) else call out_simple(g,'I$N_$M=$I%E1%P(I$N__$M)',& - n=i,m=g%lthis,x=array) + n=i,m=g%depth,x=array) endif nloops=nloops+1 case(5) ! blocked seq call out_simple_part(g,'DO I$N__$M=($I)-',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_arg(g,g_ptr(g,vdim,5),0) call out_str(g,',(') call out_arg(g,g_ptr(g,vdim,2),0) @@ -2315,9 +3511,9 @@ subroutine gen_nested_loop(g,v,nloops) call out_arg(g,g_ptr(g,vdim,3),0) call out_new_line(g) call out_simple_part(g,'DO I$N_$M=MAX($I,I$N__$M),',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_simple_part(g,'MIN(I$N__$M+($I)-1,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,4)) + n=i,m=g%depth,x=g_ptr(g,vdim,4)) call out_arg(g,g_ptr(g,vdim,2),0) call out_char(g,')') call out_new_line(g) @@ -2326,16 +3522,16 @@ subroutine gen_nested_loop(g,v,nloops) else ! Array call out_simple(g,'DO I$N__$M=1,SIZE($I%P)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_simple(g,'I$N_$M=$I(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) nloops=nloops+1 endif else call out_simple(g,'DO I$N__$M=1,SIZE($I%E1%P)',& - n=i,m=g%lthis,x=vdim) + n=i,m=g%depth,x=vdim) call out_simple(g,'I$N_$M=$I%E1%P(I$N__$M)',& - n=i,m=g%lthis,x=vdim) + n=i,m=g%depth,x=vdim) nloops=nloops+1 endif enddo @@ -2352,11 +3548,11 @@ subroutine gen_nested_loop(g,v,nloops) case(1) ! single point call out_simple(g,'I$N_$M=$I+1',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) case(2) ! range call out_simple_part(g,'DO I$N__$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_arg(g,g_ptr(g,vdim,2),0) call out_simple_part(g,',$I%E$N',x=vblock,n=i) call out_new_line(g) @@ -2364,7 +3560,7 @@ subroutine gen_nested_loop(g,v,nloops) case(3) ! strided range call out_simple_part(g,'DO I$N__$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_arg(g,g_ptr(g,vdim,2),0) call out_char(g,',') call out_arg(g,g_ptr(g,vdim,3),0) @@ -2374,7 +3570,7 @@ subroutine gen_nested_loop(g,v,nloops) case(5) ! blocked seq call out_simple_part(g,'DO I$N__$M=$I-',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_arg(g,g_ptr(g,vdim,5),0) call out_char(g,',') call out_arg(g,g_ptr(g,vdim,2),0) @@ -2382,25 +3578,25 @@ subroutine gen_nested_loop(g,v,nloops) call out_arg(g,g_ptr(g,vdim,3),0) call out_new_line(g) call out_simple_part(g,'IMAX$N__$M=MIN(I$N__$M+$I-1,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,4)) + n=i,m=g%depth,x=g_ptr(g,vdim,4)) call out_arg(g,g_ptr(g,vdim,2),0) call out_line(g,')') call out_simple_part(g,'DO I$N_$M=MAX($I,I$N__$M),IMAX$N__$M',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_simple(g,',$I%E$N',x=vblock,n=i) nloops=nloops+2 end select else ! Arrays (split) call out_simple_part(g,'DO I$N___$M=1,SIZE($I%P),',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) call out_simple(g,',$I%E$N',x=vblock,n=i) nloops=nloops+1 endif else ! Array call out_simple_part(g,'DO I$N___$M=1,SIZE($I%E1%P),',& - n=i,m=g%lthis,x=vdim) + n=i,m=g%depth,x=vdim) call out_simple(g,',$I%E$N',x=vblock,n=i) nloops=nloops+1 endif @@ -2418,7 +3614,7 @@ subroutine gen_nested_loop(g,v,nloops) case(2) ! range call out_simple_part(g,'DO I$N_$M=I$N__$M,MIN(I$N__$M-1+$I%E$N,',& - n=i,m=g%lthis,x=vblock) + n=i,m=g%depth,x=vblock) call out_arg(g,g_ptr(g,vdim,2),0) call out_char(g,')') call out_new_line(g) @@ -2426,7 +3622,7 @@ subroutine gen_nested_loop(g,v,nloops) case(3) ! strided range call out_simple_part(g,'DO I$N_$M=I$N__$M,MIN(I$N__$M-1+$I%E$N*',& - n=i,m=g%lthis,x=vblock) + n=i,m=g%depth,x=vblock) call out_arg(g,g_ptr(g,vdim,3),0) call out_char(g,',') call out_arg(g,g_ptr(g,vdim,2),0) @@ -2437,26 +3633,26 @@ subroutine gen_nested_loop(g,v,nloops) case(5) ! blocked seq call out_simple(g,'DO I$N_$M=I$N__$M,MIN(IMAX$N__$M,I$N__$M+$I%E$N)',& - n=i,m=g%lthis,x=vblock) + n=i,m=g%depth,x=vblock) nloops=nloops+1 end select else ! Array (split) call out_simple_part(g,'DO I$N__$M=I$N__$M,MIN(I$N__$M-1+$I%E$N,SIZE(',& - n=i,m=g%lthis,x=vblock) + n=i,m=g%depth,x=vblock) call out_arg(g,g_ptr(g,vdim,1),0) call out_line(g,'))') call out_simple(g,'I$N_$M=$I(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) endif else ! Array call out_simple_part(g,'DO I$N__$M=I$N__$M,MIN(I$N__$M-1+$I%E$N,SIZE(',& - n=i,m=g%lthis,x=vblock) + n=i,m=g%depth,x=vblock) call out_arg(g,g_ptr(g,vdim,1),0) call out_line(g,'%E1))') call out_simple(g,'I$N_$M=$I%E1(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) + n=i,m=g%depth,x=g_ptr(g,vdim,1)) endif enddo else @@ -2469,16 +3665,16 @@ subroutine gen_nested_loop(g,v,nloops) ! Calculate combined index vsize=g_ptr(g,v,2) - call out_char_idx(g,'I',g%lthis) + call out_char_idx(g,'I',g%depth) call out_str(g,'=1+') call out_char_idx(g,'I',1) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) do i=2,ndim call out_char(g,'+') call out_arg(g,g_ptr(g,vsize,i-1),0) call out_str(g,'*(I') call out_idx(g,i) - call out_char_idx(g,'_',g%lthis) + call out_char_idx(g,'_',g%depth) enddo do i=2,ndim call out_char(g,')') @@ -2495,11 +3691,11 @@ subroutine gen_close_loops(g) type(gen_state):: g integer:: i if(g_loop_active(g)) then - do i=1,g%lstack(g%lthis)%nloops + do i=1,g%lstack(g%depth)%nloops call out_line(g,'ENDDO') enddo - g%lstack(g%lthis)%loop_active=.false. - g%lstack(g%lthis)%nloops=0 + g%lstack(g%depth)%loop_active=.false. + g%lstack(g%depth)%nloops=0 endif end subroutine gen_close_loops @@ -2716,11 +3912,11 @@ end subroutine gen_stacked_ve subroutine gen_vect_alloc(g) type(gen_state):: g integer:: v - v=g%lstack(g%lthis)%varlist + v=g%lstack(g%depth)%varlist do while(v>0) if(g_var_at_index_is_a_vect(g,v).and.& iand(g%vardata(v)%flags,v_is_result)==0.and.& - iand(g%vardata(v)%gflags,var_is_recycled)==0) then + iand(g%vardata(v)%flags,var_is_recycled)==0) then call out_str(g,'IF(ALLOCATED(') call out_var_at_index(g,v) if(iand(g%vardata(v)%flags,v_is_chan)/=0) then @@ -2738,7 +3934,7 @@ subroutine gen_vect_alloc(g) call out_str(g,'%P') endif call out_str(g,'(N') - call out_idx(g,g%lthis) + call out_idx(g,g%depth) if(iand(g%vardata(v)%flags,v_is_ve+v_is_cove)/=0) then call out_str(g,'),SOURCE=.FALSE.)') else @@ -2755,12 +3951,12 @@ end subroutine gen_vect_alloc subroutine gen_vect_dealloc(g) type(gen_state):: g integer:: v,outer - v=g%lstack(g%lthis)%varlist + v=g%lstack(g%depth)%varlist do while(v>0) if(g_var_at_index_is_a_vect(g,v).and.& - iand(g%vardata(v)%gflags,var_is_recycled)==0) then - outer=g%vardata(v)%outer_lthis - if(outer/=g%vardata(v)%lthis) then + iand(g%vardata(v)%flags,var_is_recycled)==0) then + outer=g%vardata(v)%outer_depth + if(outer/=g%vardata(v)%depth) then g%vardata(v)%elink=g%lstack(outer)%defer_free g%lstack(outer)%defer_free=v else @@ -2774,7 +3970,7 @@ subroutine gen_vect_dealloc(g) endif v=g%vardata(v)%link enddo - v=g%lstack(g%lthis)%defer_free + v=g%lstack(g%depth)%defer_free do while(v>0) call out_str(g,'DEALLOCATE(') call out_var_at_index(g,v) @@ -2800,11 +3996,11 @@ subroutine gen_mpi_remote_call(g,l,issend) type(gen_state):: g integer,intent(in):: l logical,intent(in):: issend - integer:: a,ve,v,lthis + integer:: a,ve,v,depth a=l+comp_op_arg0 ve=g%codes(a) call out_line(g,'PM__REQUEST=3-PM__REQUEST') - call out_simple(g,'I$N=1',n=g%lthis) + call out_simple(g,'I$N=1',n=g%depth) if(.not.issend) then v=g%codes(a+6) endif @@ -2861,8 +4057,8 @@ subroutine gen_mpi_remote_call(g,l,issend) call out_line(g,'DO WHILE(JCOMPLETE.LT.PM__MESSAGE_TOP-1)') call out_line(g,'CALL MPI_WAITANY(PM__MESSAGE_TOP,PM__MESSAGE_STACK,JRQ,PM__STAT,JERRNO)') call out_line(g,'IF(JRQ.EQ.1)THEN') - lthis=-1 - call gen_server_block(g,l,issend,1,lthis) + depth=-1 + call gen_server_block(g,l,issend,1,depth) call out_line(g,'ELSE') call out_line(g,'JCOMPLETE=JCOMPLETE+1') call out_line(g,'IF(JCOMPLETE.LT.PM__MESSAGE_TOP)THEN') @@ -2898,7 +4094,7 @@ subroutine gen_mpi_remote_call(g,l,issend) call out_line(g,'DO') call out_line(g,'CALL MPI_WAITANY(PM__MESSAGE_TOP,PM__MESSAGE_STACK,JRQ,PM__STAT,JERRNO)') call out_line(g,'IF(JRQ==1)THEN') - call gen_server_block(g,l,issend,1,lthis) + call gen_server_block(g,l,issend,1,depth) call out_line(g,'ELSE') call out_line(g,'IF(JRQ.EQ.2)THEN') call out_line(g,'CALL MPI_CANCEL(PM__MESSAGE_STACK(1),JERRNO)') @@ -2922,14 +4118,14 @@ subroutine gen_mpi_collect_call(g,l,issend) type(gen_state):: g integer,intent(in):: l logical,intent(in):: issend - integer:: a,ve,v,lthis + integer:: a,ve,v,depth a=l+comp_op_arg0 ve=g%codes(a) if(.not.issend) then v=g%codes(a+6) endif if(ve==0) then - call out_simple(g,'NTOT=N$N',l,n=g%lthis) + call out_simple(g,'NTOT=N$N',l,n=g%depth) else call out_simple(g,'NTOT=COUNT($#0)',l) endif @@ -3004,8 +4200,8 @@ subroutine gen_mpi_collect_call(g,l,issend) call out_line(g,'NSIZE=-NSIZE') call out_line(g,'JCOMPLETE=JCOMPLETE+1') call out_line(g,'ENDIF') - lthis=-1 - call gen_server_block(g,l,issend,1,lthis) + depth=-1 + call gen_server_block(g,l,issend,1,depth) call out_line(g,'IF(JCOMPLETE.EQ.NNODE-1)EXIT') call out_line(g,& @@ -3025,31 +4221,31 @@ end subroutine gen_mpi_collect_call ! Arg list: ve block [ internal-block ] new-v new-w v w p i ! [ internal-block ] present if extra_arg=1 (instead of 0) !============================================================ - subroutine gen_server_block(g,l,issend,extra_arg,lthis) + subroutine gen_server_block(g,l,issend,extra_arg,depth) type(gen_state):: g integer,intent(in):: l,extra_arg logical,intent(in):: issend - integer,intent(inout):: lthis - integer:: a,save_lthis,save_last_ve,ll + integer,intent(inout):: depth + integer:: a,save_depth,save_last_ve,ll a=l+comp_op_arg0+extra_arg - save_lthis=g%lthis - if(lthis<0) then + save_depth=g%depth + if(depth<0) then g%ltop=g%ltop+1 - g%lthis=g%ltop - lthis=g%lthis + g%depth=g%ltop + depth=g%depth else - g%lthis=lthis + g%depth=depth endif - g%lstack(g%lthis)%nloops=1 + g%lstack(g%depth)%nloops=1 save_last_ve=g%last_ve g%last_ve=0 if(pm_opts%ftn_annotate) then - call out_simple(g,'! BLOCK $N (server)',n=g%lthis) + call out_simple(g,'! BLOCK $N (server)',n=g%depth) endif - call out_simple(g,'N$N=ABS(QRBUFFER%P(1))',n=g%lthis) + call out_simple(g,'N$N=ABS(QRBUFFER%P(1))',n=g%depth) call out_line(g,'NA0=1') call gen_vect_alloc(g) @@ -3071,8 +4267,8 @@ subroutine gen_server_block(g,l,issend,extra_arg,lthis) call out_line(g,'ENDIF') endif - call out_simple(g,'DO I$N=1,N$N ! Start of server block',n=g%lthis) - g%lstack(g%lthis)%loop_active=.true. + call out_simple(g,'DO I$N=1,N$N ! Start of server block',n=g%depth) + g%lstack(g%depth)%loop_active=.true. ll=g%codes(a+1-extra_arg) do while(ll>0) call gen_op(g,ll) @@ -3081,7 +4277,7 @@ subroutine gen_server_block(g,l,issend,extra_arg,lthis) call gen_if_nest(g,g%last_ve,0) call out_line(g,'ENDDO !End of server block') - g%lstack(g%lthis)%loop_active=.false. + g%lstack(g%depth)%loop_active=.false. g%last_ve=0 if(.not.issend) then @@ -3091,14 +4287,14 @@ subroutine gen_server_block(g,l,issend,extra_arg,lthis) call gen_vect_dealloc(g) g%last_ve=save_last_ve - g%lthis=save_lthis + g%depth=save_depth call out_line(g,'CALL MPI_IRECV(QRBUFFER%P,1,MPI_AINT,MPI_ANY_SOURCE,PM__REQUEST,'//& 'JCOMM,JMESS,JERRNO)') call out_line(g,'PM__MESSAGE_STACK(1)=JMESS') if(pm_opts%ftn_annotate) then - call out_simple(g,'! END BLOCK $N (server)',n=g%lthis) + call out_simple(g,'! END BLOCK $N (server)',n=g%depth) endif end subroutine gen_server_block @@ -3116,19 +4312,19 @@ subroutine gen_internal_server_block(g,l,vd,vs,ve) integer:: ll,a a=l+comp_op_arg0 call out_line(g,'DO IX='//vs//','//ve) - call out_char_idx(g,'I',g%lthis) + call out_char_idx(g,'I',g%depth) call out_char(g,'=') call out_line(g,vd) - g%lstack(g%lthis)%nloops=1 - g%lstack(g%lthis)%loop_active=.true. + g%lstack(g%depth)%nloops=1 + g%lstack(g%depth)%loop_active=.true. ll=g%codes(a+2) do while(ll>0) call gen_op(g,ll) ll=g%codes(ll) enddo call out_line(g,'ENDDO') - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_active=.false. + g%lstack(g%depth)%nloops=0 + g%lstack(g%depth)%loop_active=.false. g%last_ve=0 end subroutine gen_internal_server_block @@ -3139,21 +4335,21 @@ end subroutine gen_internal_server_block subroutine gen_mpi_bcast_call(g,l) type(gen_state),intent(inout):: g integer,intent(in):: l - integer:: a,ll,save_lthis,save_last_ve + integer:: a,ll,save_depth,save_last_ve a=l+comp_op_arg0 - call out_simple(g,'I$N=1',n=g%lthis) + call out_simple(g,'I$N=1',n=g%depth) call out_simple(g,'JNODE=$6',l) - call out_simple(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) NA=N$N',n=g%lthis) + call out_simple(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) NA=N$N',n=g%depth) call out_line(g,'CALL MPI_BCAST(NA,1,MPI_AINT,JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 + save_depth=g%depth + g%depth=g%ltop + g%lstack(g%depth)%nloops=0 save_last_ve=g%last_ve g%last_ve=0 - call out_simple(g,'N$N=NA',n=g%lthis) + call out_simple(g,'N$N=NA',n=g%depth) call out_line(g,'NA0=1') call gen_vect_alloc(g) @@ -3176,7 +4372,7 @@ subroutine gen_mpi_bcast_call(g,l) call gen_vect_dealloc(g) g%last_ve=save_last_ve - g%lthis=save_lthis + g%depth=save_depth end subroutine gen_mpi_bcast_call @@ -3187,21 +4383,21 @@ end subroutine gen_mpi_bcast_call subroutine gen_mpi_masked_bcast_call(g,l) type(gen_state),intent(inout):: g integer,intent(in):: l - integer:: a,ll,save_lthis,save_last_ve + integer:: a,ll,save_depth,save_last_ve a=l+comp_op_arg0 - call out_simple(g,'I$N=1',n=g%lthis) + call out_simple(g,'I$N=1',n=g%depth) call out_simple(g,'JNODE=$6',l) call out_simple(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) NA=COUNT($#0)',l) call out_line(g,'CALL MPI_BCAST(NA,1,MPI_AINT,JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 + save_depth=g%depth + g%depth=g%ltop + g%lstack(g%depth)%nloops=0 save_last_ve=g%last_ve g%last_ve=0 - call out_simple(g,'N$N=NA',n=g%lthis) + call out_simple(g,'N$N=NA',n=g%depth) call gen_vect_alloc(g) @@ -3228,7 +4424,7 @@ subroutine gen_mpi_masked_bcast_call(g,l) call gen_vect_dealloc(g) g%last_ve=save_last_ve - g%lthis=save_lthis + g%depth=save_depth end subroutine gen_mpi_masked_bcast_call @@ -3287,7 +4483,7 @@ recursive subroutine gen_mpi_send(g,v,tag,s,mode,comm) call out_comm_var(g,v,mode) call out_line(g,')') tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) + if(mode==mode_array) tno=pm_type_arg(g%context,tno,1) if(g_is_complex_type(g,tno)) then call g_add_packable(g,pack_vect,tno) call out_simple_part(g,'CALL PM__PACKVEC$N(NA,',n=tno) @@ -3353,7 +4549,7 @@ subroutine out_comm_var(g,v,mode) integer,intent(in):: v integer,intent(in):: mode !write(*,*) 'v is ',v,g_kind(g,v) - !write(*,*) 'SENDING OUT COMM',mode,g%lthis,g_lthis(g,v) + !write(*,*) 'SENDING OUT COMM',mode,g%depth,g_depth(g,v) call out_arg(g,v,merge(0,arg_no_index,mode==mode_array)) if(mode==mode_array) then call out_str(g,'%E1%P') @@ -3416,7 +4612,7 @@ recursive subroutine gen_mpi_recv(g,v,tag,s,mode,rest,comm) endif case(v_is_basic) tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) + if(mode==mode_array) tno=pm_type_arg(g%context,tno,1) if(g_is_complex_type(g,tno)) then call out_str(g,'NA=SIZE(') call out_comm_var(g,v,mode) @@ -3560,7 +4756,7 @@ recursive subroutine gen_mpi_bcast(g,v,isshared,array_vect) endif call out_get_mpi_base_type(g,tno) call out_simple(g,& - 'CALL PM__GET_MPI_TYPE(JBASE,NA,JTYPE,JN,LNEW)',n=g%lthis) + 'CALL PM__GET_MPI_TYPE(JBASE,NA,JTYPE,JN,LNEW)',n=g%depth) endif call out_str(g,'CALL MPI_BCAST(') call out_arg(g,v,merge(arg_no_index,0,isvec)) @@ -3675,7 +4871,7 @@ recursive subroutine gen_mpi_send_part(g,v,tag,s,dv,dv1,dv2,mode,dvv) case(v_is_basic,v_is_sub,v_is_vsub,v_is_elem,& v_is_unit_elem,v_is_const,v_is_ctime_const) tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) + if(mode==mode_array) tno=pm_type_arg(g%context,tno,1) if(g_is_complex_type(g,tno)) then call out_simple(g,'NA='//dv2//'-'//dv1//'+1',x=dvv) if(nonblocking) then @@ -3757,8 +4953,8 @@ recursive subroutine gen_mpi_recv_part(g,v,tag,s,rest,dv,dv1,dv2,mode,dvv) case(v_is_basic,v_is_sub,v_is_vsub,v_is_elem,v_is_unit_elem) tno=g_type(g,v) if(mode==mode_array) then - !write(*,*) 'tno=',pm_typ_as_string(g%context,tno) - tno=pm_typ_arg(g%context,tno,1) + !write(*,*) 'tno=',pm_type_as_string(g%context,tno) + tno=pm_type_arg(g%context,tno,1) endif if(g_is_complex_type(g,tno)) then if(nonblocking) then @@ -3841,7 +5037,7 @@ recursive subroutine gen_mpi_bcast_part(g,v,isshared,dv,dv1,dv2,mode,dvv) endif case(v_is_basic) tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) + if(mode==mode_array) tno=pm_type_arg(g%context,tno,1) if(g_is_complex_type(g,tno)) then call out_simple(g,'NA='//dv2//'-'//dv1//'+1',x=dvv) call g_add_packable(g,pack_vect_disp,tno) @@ -3952,7 +5148,7 @@ subroutine make_disp_mpi_type(g,tno,mode,dv,dv1,dv2,dvv) endif call out_simple(g,'CALL PM__GET_MPI_DISP_TYPE(JTYPE,$A,1_PM__LN,JTYPE_N)',& x=g_ptr(g,offsets,1)) - elseif(pm_typ_kind(g%context,g_type(g,offsets))==pm_typ_is_array) then + elseif(pm_type_kind(g%context,g_type(g,offsets))==pm_type_is_array) then call out_simple(g,'CALL PM__GET_MPI_DISP_TYPE(JTYPE,$A%E1%P,1_PM__LN,JTYPE_N)',& x=offsets) else @@ -3964,13 +5160,13 @@ subroutine make_disp_mpi_type(g,tno,mode,dv,dv1,dv2,dvv) call pm_panic('grid_dim incorrect number of entries') endif call out_str(g,'CALL PM__GET_MPI_SUBRANGE_TYPE(JTYPE,') - tv=pm_typ_vect(g%context,g_type(g,grid_dim)) + tv=pm_type_vect(g%context,g_type(g,grid_dim)) do j=2,6 - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,j)),pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,j)),pm_type_has_storage)/=0) then call out_arg(g,g_ptr(g,grid_dim,j),0) call out_char(g,',') else - call out_const(g,pm_typ_val(g%context,pm_tv_arg(tv,j))) + call out_const(g,pm_type_val(g%context,pm_tv_arg(tv,j))) call out_char(g,',') endif enddo @@ -4028,7 +5224,7 @@ recursive subroutine gen_pack(g,v1,v2,m) endif elseif(iand(k2,v_is_poly)/=0) then call out_line(g,'IX=0') - call out_simple(g,'DO I$N=1,N$N',n=g%lthis) + call out_simple(g,'DO I$N=1,N$N',n=g%depth) if(m/=0) call out_simple(g,'IF($I) THEN',x=m) call out_line(g,'IX=IX+1') call out_arg(g,v1,arg_ix_index) @@ -4204,7 +5400,7 @@ subroutine gen_array_vect_pack_to_buffer(g,tno,isdisp) logical:: has_depth type(pm_ptr):: tv integer:: tno1,tno2 - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) tno1=pm_tv_arg(tv,1) tno2=pm_tv_arg(tv,2) call out_new_line(g) @@ -4278,7 +5474,7 @@ subroutine gen_pack_routine(g,tno) integer,dimension(pm_int:pm_string):: counts logical:: hasdepth logical:: recur - recur=iand(pm_typ_flags(g%context,tno),pm_typ_has_poly)/=0 + recur=iand(pm_type_flags(g%context,tno),pm_type_has_poly)/=0 counts=0 call out_new_line(g) if(recur) call out_str(g,'RECURSIVE ') @@ -4302,9 +5498,9 @@ recursive subroutine outpack(tno,varname,depth) type(pm_ptr):: tv,tlist,telem character(len=5):: ibuffer integer:: i,n,tno2 - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) + case(pm_type_is_basic) if(tno>=pm_int.and.tno<=pm_string) then call out_str(g,'PM__BUFFER%SIZEOF(') call out_kind(g,tno) @@ -4319,7 +5515,7 @@ recursive subroutine outpack(tno,varname,depth) call out_char(g,'=') call out_line(g,varname) endif - case(pm_typ_is_array) + case(pm_type_is_array) write(ibuffer,'(i5)') depth+1 ibuffer=adjustl(ibuffer) call out_line(g,'NP'//trim(ibuffer)//'=SIZE('//varname//'%E1%P)') @@ -4328,12 +5524,12 @@ recursive subroutine outpack(tno,varname,depth) call outpack(pm_tv_arg(tv,1),varname//'%E1%P(IP'//trim(ibuffer)//')',depth+1) call out_line(g,'ENDDO') call outpack(pm_tv_arg(tv,2),varname//'%E2',depth) - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) + case(pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) write(ibuffer,'(i5)') i call outpack(pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) enddo - case(pm_typ_is_poly) + case(pm_type_is_poly) call out_line(g,'PM__BUFFER%SIZEOF(PM__INT)=PM__BUFFER%SIZEOF(PM__INT)+1') call out_line(g,'PM__BUFFER%I(PM__BUFFER%SIZEOF(PM__INT))=0') call out_str(g,'SELECT TYPE(POLYVAR=>') @@ -4360,10 +5556,10 @@ recursive subroutine outpack(tno,varname,depth) enddo endif call out_line(g,'END SELECT') - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) continue - case(pm_typ_is_all,pm_typ_is_par_kind,pm_typ_is_enveloped,& - pm_typ_is_vect) + case(pm_type_is_all,pm_type_is_par_kind,& + pm_type_is_vect) call outpack(pm_tv_arg(tv,1),varname,depth) end select end subroutine outpack @@ -4376,7 +5572,7 @@ subroutine gen_unpack_routine(g,tno) type(gen_state):: g integer,intent(in):: tno logical:: recur - recur=iand(pm_typ_flags(g%context,tno),pm_typ_has_poly)/=0 + recur=iand(pm_type_flags(g%context,tno),pm_type_has_poly)/=0 if(recur) call out_str(g,'RECURSIVE ') call out_str(g,'SUBROUTINE PM__UNPACK') call out_idx(g,tno) @@ -4395,9 +5591,9 @@ recursive subroutine declare_poly_vars(tno) integer,intent(in):: tno type(pm_ptr):: tv,tlist,telem integer:: tno2,i,n - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_typ_is_poly) + case(pm_type_is_poly) tlist=g_check_poly(g,tno) if(.not.pm_fast_isnull(tlist)) then n=pm_set_size(g%context,tlist) @@ -4414,8 +5610,8 @@ recursive subroutine declare_poly_vars(tno) call out_new_line(g) enddo endif - case(pm_typ_is_array,& - pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) + case(pm_type_is_array,& + pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) call declare_poly_vars(pm_tv_arg(tv,i)) enddo @@ -4429,9 +5625,9 @@ recursive subroutine outunpack(tno,varname,depth) type(pm_ptr):: tv,tlist,telem character(len=5):: ibuffer integer:: i,n,tno2 - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) + case(pm_type_is_basic) if(tno>=pm_int.and.tno<=pm_string) then call out_str(g,'PM__BUFFER%SIZEOF(') call out_kind(g,tno) @@ -4445,7 +5641,7 @@ recursive subroutine outunpack(tno,varname,depth) call out_kind(g,tno) call out_line(g,'))') endif - case(pm_typ_is_array) + case(pm_type_is_array) write(ibuffer,'(i5)') depth+1 ibuffer=adjustl(ibuffer) call outunpack(int(pm_long),'NP'//trim(ibuffer),depth) @@ -4455,12 +5651,12 @@ recursive subroutine outunpack(tno,varname,depth) call outunpack(pm_tv_arg(tv,1),varname//'%E1%P(IP'//trim(ibuffer)//')',depth+1) call out_line(g,'ENDDO') call outunpack(pm_tv_arg(tv,2),varname//'%E2',depth) - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) + case(pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) write(ibuffer,'(i5)') i call outunpack(pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) enddo - case(pm_typ_is_poly) + case(pm_type_is_poly) call out_line(g,'PM__BUFFER%SIZEOF(PM__INT)=PM__BUFFER%SIZEOF(PM__INT)+1') call out_line(g,'SELECT CASE(PM__BUFFER%I(PM__BUFFER%SIZEOF(PM__INT)))') tlist=g_check_poly(g,tno) @@ -4484,10 +5680,10 @@ recursive subroutine outunpack(tno,varname,depth) enddo endif call out_line(g,'END SELECT') - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) continue - case(pm_typ_is_all,pm_typ_is_par_kind,pm_typ_is_enveloped,& - pm_typ_is_vect) + case(pm_type_is_all,pm_type_is_par_kind,& + pm_type_is_vect) call outunpack(pm_tv_arg(tv,1),varname,depth) end select end subroutine outunpack @@ -4505,7 +5701,7 @@ subroutine gen_count_routine(g,tno) integer(pm_ln),dimension(pm_int:pm_string):: counts logical:: has_depth logical:: recur - recur=iand(pm_typ_flags(g%context,tno),pm_typ_has_poly)/=0 + recur=iand(pm_type_flags(g%context,tno),pm_type_has_poly)/=0 if(recur) call out_str(g,'RECURSIVE ') call out_str(g,'SUBROUTINE PM__COUNT') call out_idx(g,tno) @@ -4539,33 +5735,33 @@ recursive subroutine precount(g,tno,counts,has_depth) type(pm_ptr):: tv,val integer:: i integer(pm_ln):: n - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) + case(pm_type_is_basic) if(tno>=pm_int.and.tno<=pm_string) then counts(tno)=counts(tno)+1 endif - case(pm_typ_is_array) + case(pm_type_is_array) has_depth2=.false. call precount(g,pm_tv_arg(tv,2),counts,has_depth2) if(pm_tv_arg(tv,3)/=pm_long.and..not.has_depth2) then call precount(g,pm_tv_arg(tv,1),counts2,has_depth) if(.not.has_depth) then - val=pm_typ_val(g%context,pm_tv_arg(tv,3)) + val=pm_type_val(g%context,pm_tv_arg(tv,3)) counts=counts+counts2*val%data%ln(val%offset) endif else has_depth=.true. endif counts(pm_long)=counts(pm_long)+1 - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) + case(pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) call precount(g,pm_tv_arg(tv,i),counts,has_depth) enddo - case(pm_typ_is_poly) + case(pm_type_is_poly) counts(pm_int)=counts(pm_int)+1 has_depth=.true. - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) continue case default call pm_panic("precount") @@ -4611,11 +5807,11 @@ recursive subroutine outcount(g,tno,varname,depth) character(len=5):: ibuffer integer(pm_ln),dimension(pm_int:pm_string):: counts logical:: has_depth - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) + case(pm_type_is_basic) continue - case(pm_typ_is_array) + case(pm_type_is_array) call outcount(g,pm_tv_arg(tv,2),varname//'%E2',depth) has_depth=.false. counts=0 @@ -4631,7 +5827,7 @@ recursive subroutine outcount(g,tno,varname,depth) call get_vect_size(varname) endif call outaddcount(g,counts,depth+1) - case(pm_typ_is_poly) + case(pm_type_is_poly) call out_line(g,'SELECT TYPE(POLYVAR=>'//varname//'%P)') tlist=g_check_poly(g,tno) if(.not.pm_fast_isnull(tlist)) then @@ -4654,15 +5850,15 @@ recursive subroutine outcount(g,tno,varname,depth) enddo endif call out_line(g,'END SELECT') - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) + case(pm_type_is_struct,pm_type_is_rec,pm_type_is_dref) do i=1,pm_tv_numargs(tv) write(ibuffer,'(i5)') i call outcount(g,pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) enddo - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_value) continue - case(pm_typ_is_all,pm_typ_is_par_kind,pm_typ_is_enveloped,& - pm_typ_is_vect) + case(pm_type_is_all,pm_type_is_par_kind,& + pm_type_is_vect) call outcount(g,pm_tv_arg(tv,1),varname,depth) end select contains @@ -4698,12 +5894,12 @@ subroutine gen_mpi_types(g) do i=0,size-1 key=keys%data%ptr(keys%offset+i) typ=abs(key%data%i(key%offset)) - !write(*,*) 'TYPE #',i,' ',trim(pm_typ_as_string(g%context,typ)) + !write(*,*) 'TYPE #',i,' ',trim(pm_type_as_string(g%context,typ)) call out_type(g,typ) call out_str(g,'::T') call out_idx(g,typ) call out_line(g,'(2)') - tv=pm_typ_vect(g%context,typ) + tv=pm_type_vect(g%context,typ) maxargs=max(maxargs,pm_tv_numargs(tv)) enddo call out_simple(g,'INTEGER,DIMENSION($N):: DATATYPES,BLOCKLENGTHS',n=maxargs) @@ -4715,16 +5911,16 @@ subroutine gen_mpi_types(g) do i=0,size-1 key=keys%data%ptr(keys%offset+i) typ=abs(key%data%i(key%offset)) - call out_comment_line(g,pm_typ_as_string(g%context,typ)) + call out_comment_line(g,pm_type_as_string(g%context,typ)) if(debug_g) then - write(*,*) 'MPI TYP>',pm_typ_as_string(g%context,typ) + write(*,*) 'MPI TYP>',pm_type_as_string(g%context,typ) endif - tv=pm_typ_vect(g%context,typ) + tv=pm_type_vect(g%context,typ) n=pm_tv_numargs(tv) nn=0 do j=1,n - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,j)),& - pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,j)),& + pm_type_has_storage)/=0) then call out_simple(g,'CALL MPI_GET_ADDRESS(T$N(1)%E$M,OFFSETS($M),JERROR)',& n=typ,m=j) nn=nn+1 @@ -4737,7 +5933,7 @@ subroutine gen_mpi_types(g) call out_line(g,'EXTENT=EXTENT-OFFSETS(1)') call out_line(g,'OFFSETS(1)=0') do j=1,nn - call out_comment_line(g,pm_typ_as_string(g%context,pm_tv_arg(tv,j))) + call out_comment_line(g,pm_type_as_string(g%context,pm_tv_arg(tv,j))) call out_get_mpi_base_type(g,pm_tv_arg(tv,j)) call out_simple(g,'DATATYPES($N)=JBASE',n=j) enddo @@ -4781,21 +5977,21 @@ subroutine out_var_def(g,i,iscomm) flags=g%vardata(i)%flags ix=abs(g%vardata(i)%index) - if(iand(g%vardata(i)%gflags,var_is_recycled)/=0) then + if(iand(g%vardata(i)%flags,var_is_recycled)/=0) then return endif oindex=g%vardata(i)%oindex if(debug_g) then - write(*,*) 'VAR>>',i,oindex,' ',trim(pm_typ_as_string(g%context,g%vardata(i)%tno)) + write(*,*) 'VAR>>',i,oindex,' ',trim(pm_type_as_string(g%context,g%vardata(i)%tno)) endif !!$ if(g_kind(g,oindex)==v_is_basic) call out_simple(g,'!'//& !!$ trim(pm_name_as_string(g%context,g_v1(g,oindex)))) -!!$ call out_simple_part(g,'! idx=$N / lthis=$M '//& -!!$ trim(pm_typ_as_string(g%context,g%vardata(i)%tno)),& -!!$ n=g%vardata(i)%oindex,m=g%vardata(i)%lthis) +!!$ call out_simple_part(g,'! idx=$N / depth=$M '//& +!!$ trim(pm_type_as_string(g%context,g%vardata(i)%tno)),& +!!$ n=g%vardata(i)%oindex,m=g%vardata(i)%depth) !!$ call out_simple_part(g,'/ flags=$N state=$M',n=g%vardata(i)%flags,m=g%vardata(i)%state) !!$ call out_simple_part(g,'/ start=$N finish=$M',n=g%vardata(i)%start,m=g%vardata(i)%finish) !!$ call out_simple(g,'/ end_assign=$N',n=merge(1,0,g%vardata(i)%finish_on_assign)) @@ -4846,7 +6042,7 @@ subroutine out_var_def(g,i,iscomm) call out_str(g,'::') call out_var_name_at_index(g,i) - call out_str(g,' ! '//trim(pm_typ_as_string(g%context,g%vardata(i)%tno))) + call out_str(g,' ! '//trim(pm_type_as_string(g%context,g%vardata(i)%tno))) if(pm_opts%ftn_annotate) then call out_simple_part(g,' idx=$N', n=oindex) @@ -4886,10 +6082,10 @@ subroutine out_type_def(g,tno,dim) type(pm_ptr):: tv,val integer:: i,n,k if(tno==0) return - if(iand(pm_typ_flags(g%context,tno),& - pm_typ_has_storage)==0) return + if(iand(pm_type_flags(g%context,tno),& + pm_type_has_storage)==0) return if(dim>0) then - call out_comment_line(g,trim(pm_typ_as_string(g%context,tno))) + call out_comment_line(g,trim(pm_type_as_string(g%context,tno))) call out_str(g,'TYPE PM__TV') call out_idx(g,tno) call out_char_idx(g,'_',dim) @@ -4898,7 +6094,7 @@ subroutine out_type_def(g,tno,dim) if(dim==pm_long) then call out_line(g,',DIMENSION(:),ALLOCATABLE::P') else - val=pm_typ_val(g%context,dim) + val=pm_type_val(g%context,dim) call out_str(g,',DIMENSION(') call out_const(g,val) call out_line(g,')::P') @@ -4910,34 +6106,34 @@ subroutine out_type_def(g,tno,dim) return endif call out_char(g,'!') - call out_comment_line(g,trim(pm_typ_as_string(g%context,tno))) + call out_comment_line(g,trim(pm_type_as_string(g%context,tno))) call out_str(g,'TYPE PM__T') call out_idx(g,tno) call out_new_line(g) !call out_line(g,',SEQUENTIAL') - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) n=pm_tv_numargs(tv) k=pm_tv_kind(tv) - if(k==pm_typ_is_array) then + if(k==pm_type_is_array) then call out_str(g,'TYPE(PM__TV') - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,1)),& - pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,1)),& + pm_type_has_storage)/=0) then call out_type_idx(g,pm_tv_arg(tv,1)) call out_char(g,'_') call out_type_idx(g,pm_tv_arg(tv,3)) call out_line(g,')::E1') endif - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,2)),& - pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,2)),& + pm_type_has_storage)/=0) then call out_type(g,pm_tv_arg(tv,2)) call out_line(g,'::E2') endif - elseif(k==pm_typ_is_vect) then + elseif(k==pm_type_is_vect) then continue else do i=1,n - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,i)),& - pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,i)),& + pm_type_has_storage)/=0) then call out_type(g,pm_tv_arg(tv,i)) call out_str(g,'::E') call out_idx(g,i) @@ -4957,7 +6153,7 @@ end subroutine out_type_def subroutine out_type_idx(g,tno) type(gen_state):: g integer,intent(in):: tno - if(pm_typ_kind(g%context,tno)==pm_typ_is_poly) then + if(pm_type_kind(g%context,tno)==pm_type_is_poly) then call out_idx(g,int(pm_pointer)) else call out_idx(g,tno) @@ -5135,7 +6331,7 @@ recursive subroutine out_call_arg(g,avar,opts) case(v_is_dref,v_is_shared_dref) n=g_v1(g,var) if(iand(opts,arg_wrapped)/=0) then - tv=pm_typ_vect(g%context,g_type(g,var)) + tv=pm_type_vect(g%context,g_type(g,var)) call out_dref_vect_arg(g,g_ptr(g,var,1),pm_tv_arg(tv,1),opts) call out_comma(g) call out_call_arg(g,g_ptr(g,var,2),opts) @@ -5171,13 +6367,13 @@ recursive subroutine out_call_arg(g,avar,opts) call out_call_arg(g,g_v1(g,var),opts) case default tno=g_type(g,var) - if(pm_typ_kind(g%context,tno)==pm_typ_is_array) then - tv=pm_typ_vect(g%context,tno) - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,1)),pm_typ_has_storage)/=0) then + if(pm_type_kind(g%context,tno)==pm_type_is_array) then + tv=pm_type_vect(g%context,tno) + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,1)),pm_type_has_storage)/=0) then call out_arg(g,var,opts) call out_str(g,'%E1,') endif - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,2)),pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(g%context,pm_tv_arg(tv,2)),pm_type_has_storage)/=0) then call out_arg(g,var,opts) call out_str(g,'%E2') endif @@ -5195,7 +6391,7 @@ end subroutine out_call_arg recursive subroutine out_dref_vect_arg(g,var,tno,opts) type(gen_state):: g integer,intent(in):: var,tno,opts - if(pm_typ_get_mode(g%context,tno)>=sym_mirrored) then + if(pm_type_get_mode(g%context,tno)>=sym_mirrored) then call out_call_arg(g,var,opts) else call out_call_arg(g,var,ior(opts,arg_wrapped)) @@ -5308,20 +6504,20 @@ end subroutine out_arg_name subroutine out_loop_index(g,v,opt) type(gen_state):: g integer,intent(in):: v,opt - integer:: i,lthis + integer:: i,depth if(g_is_a_vect(g,v)) then - lthis=g_lthis(g,v) + depth=g_depth(g,v) if(iand(opt,arg_ix_index)/=0.and.g_is_vect(g,v)) then call out_str(g,'(IX)') - elseif(iand(opt,arg_no_index+arg_wrapped)==0.or.lthis/=g%lthis.and.iand(opt,arg_wrapped)==0) then - if(lthis==g%lalt) then + elseif(iand(opt,arg_no_index+arg_wrapped)==0.or.depth/=g%depth.and.iand(opt,arg_wrapped)==0) then + if(depth==g%lalt) then call out_str(g,'(IDO)') - elseif(.not.g%lstack(lthis)%loop_active.or.lthis==0) then + elseif(.not.g%lstack(depth)%loop_active.or.depth==0) then call out_str(g,'(1)') else call out_char(g,'(') - call out_char_idx(g,'I',lthis) + call out_char_idx(g,'I',depth) call out_char(g,')') endif endif @@ -5446,7 +6642,7 @@ subroutine out_type(g,typ) integer,intent(in):: typ type(pm_ptr):: tv integer:: tno - tno=pm_typ_strip_to_basic(g%context,typ) + tno=pm_type_strip_to_basic(g%context,typ) select case(tno) case(pm_int) call out_str(g,'INTEGER') @@ -5479,8 +6675,8 @@ subroutine out_type(g,typ) case(pm_pointer,pm_poly_type) call out_str(g,'TYPE(PM__POLY)') case default - tv=pm_typ_vect(g%context,tno) - if(pm_tv_kind(tv)==pm_typ_is_poly) then + tv=pm_type_vect(g%context,tno) + if(pm_tv_kind(tv)==pm_type_is_poly) then call out_str(g,'TYPE(PM__POLY)') else call out_str(g,'TYPE(PM__T') @@ -5609,23 +6805,23 @@ recursive function add_mpi_type(g,typ) result(j) type(pm_ptr):: tv integer:: i,tno if(debug_g) then - write(*,*) 'ADD MPI TYPE',trim(pm_typ_as_string(g%context,typ)) + write(*,*) 'ADD MPI TYPE',trim(pm_type_as_string(g%context,typ)) endif - tno=pm_typ_strip_to_basic(g%context,typ) + tno=pm_type_strip_to_basic(g%context,typ) if(tno<=pm_string) return j=check_set(tno) if(j>0) return j=add_to_root_set(tno) - tv=pm_typ_vect(g%context,tno) + tv=pm_type_vect(g%context,tno) select case(pm_tv_kind(tv)) - case(pm_typ_is_struct,pm_typ_is_rec) + case(pm_type_is_struct,pm_type_is_rec) do i=1,pm_tv_numargs(tv) j=add_mpi_type(g,pm_tv_arg(tv,i)) enddo j=add_to_set(tno) - case(pm_typ_is_poly) + case(pm_type_is_poly) call pm_panic('add_mpi_type: poly type') - case(pm_typ_is_array) + case(pm_type_is_array) if(pm_tv_arg(tv,3)==pm_long) then call pm_panic('add_mpi_type: var length array') else @@ -5634,7 +6830,7 @@ recursive function add_mpi_type(g,typ) result(j) j=add_to_set(tno) endif case default - write(*,*) 'Type',pm_typ_as_string(g%context,tno),' kind ',pm_tv_kind(tv) + write(*,*) 'Type',pm_type_as_string(g%context,tno),' kind ',pm_tv_kind(tv) call pm_panic('add_mpi_type') j=0 end select @@ -6011,7 +7207,7 @@ function g_var_at_index_is_a_vect(g,i) result(ok) logical:: ok integer:: flags,gflags flags=g%vardata(i)%flags - gflags=g%vardata(i)%gflags + gflags=g%vardata(i)%flags ok=(g%vardata(i)%state==var_state_crossing.and.& iand(flags,v_is_par)==0.or.& iand(gflags,var_is_comm_op_par)/=0).and.& @@ -6050,7 +7246,7 @@ function g_is_vect(g,n) result(ok) ok=g_kind(g,n)==v_is_chan_vect else ok=g_is_a_vect(g,n).and.& - (g%vardata(i)%lthis==g%lthis.or.& + (g%vardata(i)%depth==g%depth.or.& iand(g%vardata(i)%flags,v_is_vect)/=0.or.& iand(g%vardata(i)%flags,v_is_in_dref+v_is_shared)==v_is_in_dref) endif @@ -6072,44 +7268,44 @@ end function g_index !============================================= ! Parallel nesting depth of a variable !============================================= - function g_lthis(g,n) result(lthis) + function g_depth(g,n) result(depth) type(gen_state),intent(inout):: g integer,intent(in):: n - integer:: lthis + integer:: depth integer:: i i=g%varindex(abs(n)) if(i==0) then - lthis=get_lthis(abs(n)) - if(lthis<0) then - call pm_panic('g_lthis') + depth=get_depth(abs(n)) + if(depth<0) then + call pm_panic('g_depth') endif else - lthis=g%vardata(i)%lthis + depth=g%vardata(i)%depth endif contains - recursive function get_lthis(n) result(lthis) + recursive function get_depth(n) result(depth) integer,intent(in)::n - integer:: lthis + integer:: depth integer:: i select case(g_kind(g,n)) case(v_is_alias,v_is_elem,v_is_chan_vect,& v_is_unit_elem,v_is_vect_wrapped) - lthis=get_lthis(g_v1(g,n)) + depth=get_depth(g_v1(g,n)) case(v_is_sub,v_is_vsub) - lthis=max(get_lthis(g_v1(g,n)),get_lthis(g_v2(g,n))) + depth=max(get_depth(g_v1(g,n)),get_depth(g_v2(g,n))) case(v_is_group) - lthis=-1 + depth=-1 do i=1,g_v1(g,n) - lthis=max(lthis,get_lthis(g_ptr(g,n,i))) + depth=max(depth,get_depth(g_ptr(g,n,i))) enddo case(v_is_basic) i=g%varindex(abs(n)) - lthis=g%vardata(i)%lthis + depth=g%vardata(i)%depth case default - lthis=-1 + depth=-1 end select - end function get_lthis - end function g_lthis + end function get_depth + end function g_depth !============================================= ! Does variable v have all shared elements @@ -6154,7 +7350,7 @@ function g_var_is_dead(g,n) result(ok) else ok=g%vardata(i)%start==g%vardata(i)%finish.and.& iand(g%vardata(i)%flags,v_is_result)==0.and.& - g%vardata(i)%outer_lthis==g%vardata(i)%lthis + g%vardata(i)%outer_depth==g%vardata(i)%depth if(ok) write(*,*) '>>>>',i,g%vardata(i)%start,g%vardata(i)%finish endif end function g_var_is_dead @@ -6202,7 +7398,7 @@ function g_this_n_str(g) result(str) type(gen_state):: g character(len=6):: str str(1:1)='N' - write(str(2:),'(I5)') g%lthis + write(str(2:),'(I5)') g%depth str(2:)=adjustl(str(2:)) end function g_this_n_str @@ -6252,7 +7448,7 @@ function g_gflags_set(g,v,flags) result(ok) integer:: i if(v/=0) then i=g%varindex(abs(v)) - ok=iand(g%vardata(i)%gflags,flags)==flags + ok=iand(g%vardata(i)%flags,flags)==flags else ok=.false. endif @@ -6268,7 +7464,7 @@ function g_gflags_clear(g,v,flags) result(ok) integer:: i if(v/=0) then i=g%varindex(abs(v)) - ok=iand(g%vardata(i)%gflags,flags)==0 + ok=iand(g%vardata(i)%flags,flags)==0 else ok=.false. endif @@ -6283,7 +7479,7 @@ subroutine g_set_gflags(g,v,flags) integer:: i if(v/=0) then i=g%varindex(abs(v)) - g%vardata(i)%gflags=ior(g%vardata(i)%gflags,flags) + g%vardata(i)%flags=ior(g%vardata(i)%flags,flags) endif end subroutine g_set_gflags @@ -6296,7 +7492,7 @@ subroutine g_clear_gflags(g,v,flags) integer:: i if(v/=0) then i=g%varindex(abs(v)) - g%vardata(i)%gflags=iand(g%vardata(i)%gflags,not(flags)) + g%vardata(i)%flags=iand(g%vardata(i)%flags,not(flags)) endif end subroutine g_clear_gflags @@ -6328,9 +7524,11 @@ function g_is_complex_type(g,tno) result(ok) integer,intent(in):: tno logical:: ok ok=tno==pm_pointer.or.& - iand(pm_typ_flags(g%context,tno),pm_typ_has_array+pm_typ_has_poly)/=0 + iand(pm_type_flags(g%context,tno),pm_type_has_array+pm_type_has_poly)/=0 end function g_is_complex_type + + ! ========================================= ! Placefiller - not needed for compiler ! ========================================= diff --git a/src/cfortran.save.f90 b/src/cfortran.save.f90 deleted file mode 100644 index 5584e58..0000000 --- a/src/cfortran.save.f90 +++ /dev/null @@ -1,6159 +0,0 @@ -! -! PM (Parallel Models) Programming Language -! -! Released under the MIT License (MIT) -! -! Copyright (c) Tim Bellerby, 2023 -! -! Permission is hereby granted, free of charge, to any person obtaining a copy -! of this software and associated documentation files (the "Software"), to deal -! in the Software without restriction, including without limitation the rights -! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -! copies of the Software, and to permit persons to whom the Software is -! furnished to do so, subject to the following conditions: -! -! The above copyright notice and this permission notice shall be included in -! all copies or substantial portions of the Software. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -! THE SOFTWARE. - -! Generate FORTRAN code from wordcodes - -module pm_backend - - use pm_kinds - use pm_memory - use pm_types - use pm_vmdefs - use pm_hash - use pm_lib - use pm_wcode - - implicit none - - logical,parameter:: debug_g=.false. - - ! Various limits - integer,parameter:: ftn_max_line=130 - integer,parameter:: ftn_max_name=31 - integer,parameter:: max_vars=2**15-1 - integer,parameter:: max_levels=256 - integer,parameter:: max_loop_stack=10*1024 - - ! Variable descriptor - type gvar - integer:: tno ! Type - integer:: flags ! Flags from previous stage - integer:: gflags ! Flags applied in this stage - integer:: state ! State engine (determines if needs to be stored as vector) - integer:: start ! First instruction point var is used - integer:: finish ! Last instruction point var is used - integer:: lthis ! Parallel context - integer:: link ! Linked list of variables in creation order - integer:: elink ! Linked list of variables in destruction order - integer:: index ! Vector to store this variable (may be shared) - integer:: free ! List of variables free for reuse (*not unused records*) - integer:: oindex ! Index of variable in output from wordcode generator - integer:: outer_lthis ! Outermost parallel context in which variable is referenced - logical:: finish_on_assign - ! Last statement using this variable is assignment to another variable - integer:: name ! PM name of variable - end type gvar - - ! Variable states for identifying those - ! that need storing in local arrays - ! in concurrent code (employed by small - ! state machine) - integer,parameter:: var_state_unused=0 - integer,parameter:: var_state_open=1 - integer,parameter:: var_state_used=2 - integer,parameter:: var_state_used_before=3 - integer,parameter:: var_state_crossing=4 - integer,parameter:: var_state_closed=5 - - ! Local flags for variables - integer,parameter:: var_is_recycled=1 - integer,parameter:: var_is_async=2 - integer,parameter:: var_is_else_disabled=4 - integer,parameter:: var_is_comm_op_par=8 - integer,parameter:: var_is_used=16 - integer,parameter:: var_is_reused=32 - integer,parameter:: var_is_stacked_ve=64 - - ! Loop modes - integer,parameter:: loop_is_none=0 - integer,parameter:: loop_is_contig=1 - integer,parameter:: loop_is_nested=2 - - ! Loop parameters - integer,parameter:: loop_start=1 - integer,parameter:: loop_end=2 - integer,parameter:: loop_step=3 - integer,parameter:: loop_size=4 - integer,parameter:: loop_block=5 - - ! Parallel context - type gloop - integer:: varlist - integer:: evarlist - integer:: defer_free - integer:: idx - integer:: free(2,pm_int:pm_string) - integer:: nloops - integer:: loop_mode - integer:: loop_par - logical:: loop_active - end type gloop - - ! Kinds of name (used in Fortran name mangler) - integer,parameter:: name_of_var=1 - integer,parameter:: name_of_elem=2 - integer,parameter:: name_of_proc=3 - integer,parameter:: name_of_type=4 - - ! Current state of FORTRAN code generator - type gen_state - - type(pm_context),pointer:: context - - ! Alloc procedures - type(pm_ptr):: procs - - ! Current proc - type(pm_ptr):: fn - integer:: taints - - ! Wordcodes for current proc - integer,dimension(:),pointer:: codes - integer,dimension(:),pointer:: vars - - ! Variables - integer:: nvars,index - integer,dimension(:),allocatable:: varindex - type(gvar),dimension(:),allocatable:: vardata - - ! Parallel loop frames - type(gloop),dimension(0:max_loop_stack):: lstack - integer:: lthis,ltop,last_ve - integer:: lalt - - ! Typesets - type(pm_ptr):: poly_cache,packables,mpi_types,mpi_root_types - type(pm_reg),pointer:: reg - - ! Mangled names - type(pm_ptr):: name_cache(name_of_var:name_of_type) - - ! Does current loop contain shared operations? - logical:: loop_contains_shared - - ! Fortran code output - character(len=ftn_max_line):: linebuffer - integer:: n,outunit - integer:: line_breaks - - end type gen_state - - ! Control how an argument is converted - integer,parameter:: arg_no_index=1 - integer,parameter:: arg_ix_index=2 - integer,parameter:: arg_comm_arg=4 - integer,parameter:: arg_wrapped=8 - integer,parameter:: arg_chan=16 - - ! Type of pack routine (for g_add_packable) - integer,parameter:: pack_scalar=0 - integer,parameter:: pack_vect=1 - integer,parameter:: pack_array_vect=2 - integer,parameter:: pack_vect_disp=3 - integer,parameter:: pack_array_vect_disp=4 - integer,parameter:: unpack_vect=5 - integer,parameter:: unpack_vect_disp=6 - - ! Modes of parameter passed to MPI comm operation - integer,parameter:: mode_array=0 - integer,parameter:: mode_vect=1 - integer,parameter:: mode_array_vect=2 - -contains - - !=========================================== - ! Generate Fortran code for program - !=========================================== - subroutine gen_prog(context,p,poly_cache,typeset,iunit) - type(pm_context),pointer:: context - type(pm_ptr),intent(in):: p,poly_cache,typeset - integer,intent(in):: iunit - type(gen_state),target:: g - type(pm_ptr):: key - integer:: i - integer:: tno - - ! Set up code generator state - g%context=>context - g%reg=>pm_register(context,'gen_prog',& - g%procs,g%poly_cache,g%packables,g%mpi_types,g%mpi_root_types) - g%procs=p - g%poly_cache=poly_cache - g%packables=pm_set_new(context,32_pm_ln) - g%mpi_types=pm_set_new(context,32_pm_ln) - g%mpi_root_types=pm_set_new(context,32_pm_ln) - g%outunit=iunit - g%line_breaks=0 - g%n=0 - - ! Output preamble (including runtime library) - call out_line_noindent(g,'PROGRAM PM') - i=iunit - include 'rtime.inc' - - ! Tidy up - call out_line_noindent(g,'END PROGRAM PM') - call pm_delete_register(context,g%reg) - - contains - - include 'fesize.inc' - - ! Generate procedures - subroutine gen_procs - integer(pm_ln):: i - - ! Generate code for each procedure - do i=1,pm_dict_size(context,p) - if(debug_g) write(*,*) 'OUTING PROC>',i-1 - call gen_proc(g,pm_dict_val(context,p,i),int(i-1)) - enddo - - ! Generate procedures to pack and unpack types - ! to a communications buffer - call gen_packables(g) - - ! Generate procedure to create required MPI types - call gen_mpi_types(g) - end subroutine gen_procs - - ! Output type definitions (called from rtime.inc) - subroutine out_types - integer:: i - type(pm_ptr):: keys,key - call out_new_line(g) - call out_type_defs(g,typeset) - call out_new_line(g) - end subroutine out_types - - end subroutine gen_prog - - - !=========================================== - ! Generate code for a single procedure - !=========================================== - subroutine gen_proc(g,p,no) - type(gen_state):: g - type(pm_ptr),intent(in)::p - integer,intent(in):: no - integer:: i,n,rvar,pvar,vevar,name - type(pm_ptr)::q,taint,keys - logical:: iscomm - - ! Get wordcodes & meta-info for this function - g%fn=p - q=p%data%ptr(p%offset) - rvar=q%data%i(q%offset) - pvar=q%data%i(q%offset+1) - name=q%data%i(q%offset+2) - vevar=q%data%i(q%offset+3) - g%codes=>q%data%i(q%offset+4:q%offset+pm_fast_esize(q)) - taint=p%data%ptr(p%offset+2) - keys=p%data%ptr(p%offset+3) - g%taints=taint%offset - iscomm=iand(int(taint%offset),proc_is_comm)/=0 - - ! Output spacing / comment - call out_new_line(g) - call out_line_noindent(g,' !'//& - trim(pm_name_as_string(g%context,name))) - if(debug_g) then - write(*,*) 'OUT START> ',& - trim(pm_name_as_string(g%context,q%data%i(q%offset+2))) - endif - - ! Set up variable data tables - q=p%data%ptr(p%offset+1) - g%vars=>q%data%i(q%offset:q%offset+pm_fast_esize(q)) - n=1+pm_fast_esize(q) - allocate(g%varindex(n)) - allocate(g%vardata(n/2)) - g%nvars=0 - g%varindex(1:n)=0 - - ! Output procedure header - if(iand(int(taint%offset),proc_is_recursive)/=0) & - call out_str(g,'RECURSIVE ') - if(iand(int(taint%offset),proc_is_impure)==0) & - call out_str(g,'PURE ') - call out_str(g,'SUBROUTINE PM__P') - call out_idx(g,no) - if(pm_opts%ftn_name_procs.and.no>0) then - call out_ftn_name(g,name) - endif - - ! Phase I - analyse variable use to determine variable lifetimes - ! and which variables need to be - ! stored as vectors - ! Also output necessary variable definition lines here - call init_g - g%ltop=-1 - call g_new_frame(g) - g%lstack(g%lthis)%loop_mode=loop_is_none - if(vevar/=-1) then - call use_var(g,vevar) - call cross_var(g,vevar) - endif - if(.not.pm_fast_isnull(keys)) then - do i=0,pm_fast_esize(keys) - call use_var(g,keys%data%i(keys%offset+i)) - enddo - endif - if(pvar/=-1) call use_var(g,pvar) - if(size(g%codes)>0) call gen_var_block(g,comp_op_start) - if(rvar/=-1) call use_var(g,rvar) - - ! Phase II - analyse variable lifetimes to merge variables - do i=0,g%ltop - g%lthis=i - call sort_var_list(g) - call alloc_var_list(g) - enddo - - ! Phase III - output necessary definition lines - call out_char(g,'(') - if(iscomm) then - call out_str(g,'N1,') - if(vevar>0) then - call out_param(g,vevar) - call out_char(g,',') - endif - endif - if(rvar/=-1) then - call out_param(g,rvar) - endif - if(.not.pm_fast_isnull(keys)) then - do i=0,pm_fast_esize(keys) - call out_param(g,keys%data%i(keys%offset+i)) - enddo - endif - if(pvar/=-1) then - call out_param(g,pvar) - endif - call out_close(g) - call out_new_line(g) - if(iscomm) then - call out_line(g,'INTEGER(PM__LN),INTENT(IN):: N1') - endif - do i=1,g%nvars - call out_var_def(g,i,iscomm) - enddo - - ! Phase IV - output code for the body of the procedure - call init_g - if(size(g%codes)>0) then - call gen_block(g,comp_op_start) - call gen_if_nest(g,g%last_ve,0) - call gen_close_loops(g) - endif - call out_str_noindent(g,' END SUBROUTINE PM__P') - call out_idx(g,no) - if(pm_opts%ftn_name_procs.and.no>0) then - call out_ftn_name(g,name) - endif - call out_new_line(g) - - ! Tidy up - deallocate(g%varindex) - deallocate(g%vardata) - if(debug_g) then - write(*,*) 'OUT DONE> ',& - trim(pm_name_as_string(g%context,& - q%data%i(q%offset+2))) - endif - - contains - include 'fesize.inc' - include 'fisnull.inc' - subroutine init_g - g%lthis=0 - g%ltop=0 - g%lalt=-1 - g%loop_contains_shared=.false. - end subroutine init_g - end subroutine gen_proc - - function g_procname(g,n) result(name) - type(gen_state):: g - integer,intent(in):: n - integer:: name - type(pm_ptr):: p,q - p=pm_dict_val(g%context,g%procs,int(n+1,pm_ln)) - q=p%data%ptr(p%offset) - name=q%data%i(q%offset+2) - end function g_procname - - !************************************************ - ! PHASE I - VARIABLE ASSIGNMENT - !************************************************ - - !=========================================== - ! Variable assignment phase for a code block - !=========================================== - recursive subroutine gen_var_block(g,loc) - type(gen_state):: g - integer,intent(in):: loc - integer:: l - if(debug_g) write(*,*) 'VAR BLOCK>' - l=loc - do while(l>0) - if(debug_g) write(*,*) 'DO VAR>',l - g%lstack(g%lthis)%idx=g%lstack(g%lthis)%idx+1 - call gen_var_op(g,l) - l=g%codes(l) - if(debug_g) write(*,*) 'NEXT VAR',l - enddo - if(debug_g) write(*,*) 'END VAR BLOCK>' - end subroutine gen_var_block - - !================================================== - ! Variable assignment phase for a single operation - !================================================== - recursive subroutine gen_var_op(g,l) - type(gen_state):: g - integer,intent(in):: l - integer:: opcode,opcode2,n,arg - integer:: i,j,a,save_lthis,ll,var1,idx1 - logical:: save_loop_contains_shared - if(pm_debug_level>0) then - if(l>size(g%codes)) then - write(*,*) 'l=',l,size(g%codes) - call pm_panic('gen_var_op bad l') - endif - endif - opcode=g%codes(l+comp_op_opcode) - opcode2=g%codes(l+comp_op_opcode2) - n=g%codes(l+comp_op_nargs) - a=l+comp_op_arg0 - - if(debug_g) then - write(*,*) 'l=',l,n,op_names(opcode) - write(*,*) 'VAR OP> ',g%lstack(g%lthis)%idx,l,op_names(opcode),n,& - '>>',g%codes(l:l+comp_op_arg0+n-1) - endif - - select case(opcode) - case(op_if,op_if_shared,op_if_restart) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call gen_var_block(g,g%codes(a+2)) - call use_var(g,g%codes(a+3)) - case(op_if_shared_node) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call gen_var_block(g,g%codes(a+2)) - case(op_over,op_skip_empty) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call cross_all_vars(g) - case(op_head_node) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - case(op_loop) - save_loop_contains_shared=g%loop_contains_shared - g%loop_contains_shared=.false. - var1=g%lstack(g%lthis)%varlist - idx1=g%lstack(g%lthis)%idx - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call extend_finish_to_loop(g,idx1,g%lstack(g%lthis)%idx,var1) - call use_var(g,g%codes(a+2)) - if(g%loop_contains_shared) then - g%codes(l+comp_op_opcode2)=ior(g%codes(l+comp_op_opcode2),2) - endif - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_loop,op_comm_loop_par) - save_loop_contains_shared=g%loop_contains_shared - var1=g%lstack(g%lthis)%varlist - idx1=g%lstack(g%lthis)%idx - call cross_all_vars(g) - call use_var(g,g%codes(a)) - call gen_var_block(g,g%codes(a+1)) - call extend_finish_to_loop(g,idx1,g%lstack(g%lthis)%idx,var1) - call use_var(g,g%codes(a+2)) - call cross_all_vars(g) - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_proc) - save_loop_contains_shared=g%loop_contains_shared - call use_var(g,g%codes(a)) - call gen_var_comm_block(g,g%codes(a+1)) - g%loop_contains_shared=save_loop_contains_shared - case(op_inline_shared) - save_loop_contains_shared=g%loop_contains_shared - call use_var(g,g%codes(a)) - call gen_var_shared_block(g,g%codes(a+1)) - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_block) - save_loop_contains_shared=g%loop_contains_shared - call use_var(g,g%codes(a)) - call use_var(g,g%codes(a+2)) - call gen_var_comm_block(g,g%codes(a+1)) - g%loop_contains_shared=save_loop_contains_shared - case(op_comm_call,op_dref,op_wrap) - call cross_all_vars(g) - do i=0,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - call use_var(g,g%codes(a+i)) - enddo - case(op_comm_inline) !!! Obsolete? - call cross_all_vars(g) - case(op_sync) - call cross_all_vars(g) - case(op_broadcast_val,& - op_sync_mess,op_break_loop,& - op_read_file_tile,op_write_file_tile,op_broadcast,& - op_broadcast_shared,op_nested_loop,& - op_blocked_loop,op_isend_offset,op_irecv_offset,& - op_recv_offset,op_recv_offset_resend,op_isend_reply,& - op_recv_reply,op_isend_req,op_isend_assn,op_active,op_get_size) - call cross_all_vars(g) - do i=0,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - case(op_remote_send_call,op_collect_call) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=6,n-1 !!! Dont use or cross outputs - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - save_lthis=g%lthis - call g_new_frame(g) - call use_var(g,g%codes(a+4)) - call cross_var(g,g%codes(a+4)) - call use_var(g,g%codes(a+5)) - call cross_var(g,g%codes(a+5)) - call gen_var_block(g,g%codes(a+1)) - g%lthis=save_lthis - call gen_var_block(g,g%codes(a+2)) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=6,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - case(op_remote_call,op_server_call) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=5,7 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - save_lthis=g%lthis - call g_new_frame(g) - call use_var(g,g%codes(a+4)) - call cross_var(g,g%codes(a+4)) - call use_var(g,g%codes(a+8)) - call cross_var(g,g%codes(a+8)) - call gen_var_block(g,g%codes(a+1)) - g%lthis=save_lthis - call gen_var_block(g,g%codes(a+2)) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=5,7 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - case(op_bcast_call) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=5,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - save_lthis=g%lthis - call g_new_frame(g) - call use_var(g,g%codes(a+2)) - call cross_var(g,g%codes(a+2)) - call use_var(g,g%codes(a+3)) - call cross_var(g,g%codes(a+3)) - call gen_var_block(g,g%codes(a+1)) - g%lthis=save_lthis - call cross_all_vars(g) - call use_var(g,g%codes(a)) - do i=5,n-1 - call use_var(g,g%codes(a+i)) - call cross_var(g,g%codes(a+i)) - enddo - case(op_recv_req_call,op_recv_assn_call) - call cross_all_vars(g) - call use_var(g,g%codes(a)) - call use_var(g,g%codes(a+4)) - call cross_var(g,g%codes(a+4)) - call cross_all_vars(g) - save_lthis=g%lthis - call g_new_frame(g) - call cross_all_vars(g) - call use_var(g,g%codes(a+2)) - !call cross_var(g,g%codes(a+2)) - call use_var(g,g%codes(a+3)) - call cross_var(g,g%codes(a+3)) - if(opcode==op_recv_assn_call) then - call use_var(g,g%codes(a+5)) - call cross_var(g,g%codes(a+5)) - endif - call gen_var_block(g,g%codes(a+1)) - call cross_all_vars(g) - g%lthis=save_lthis - case(op_do_at) - call use_var(g,g%codes(a)) - if(opcode2==0) then - call use_var(g,g%codes(a+2)) - call use_var(g,g%codes(a+3)) - endif - call gen_var_block(g,g%codes(a+1)) - case(op_assign) - call use_var(g,g%codes(a)) - call use_var(g,g%codes(a+1)) - call use_var(g,g%codes(a+2),.true.) - case default - if(debug_g) write(*,*) 'VAR OP GENERIC>',op_names(opcode),g%codes(a:a+n-1) - do i=0,n-1 - call use_var(g,g%codes(a+i)) - enddo - end select - - if(debug_g) write(*,*) 'END VAR OP> ',l,op_names(opcode) - - end subroutine gen_var_op - - !============================================================= - ! Variable assignment phase for a block with comm operations - !============================================================= - subroutine gen_var_comm_block(g,blk) - type(gen_state):: g - integer,intent(in):: blk - integer:: save_lthis,ll - save_lthis=g%lthis - if(debug_g) write(*,*) 'VAR COMM BLK>',blk - call g_new_frame(g) - ll=blk - do while(ll>0) - g%lstack(g%lthis)%idx=g%lstack(g%lthis)%idx+1 - call gen_var_op(g,ll) - ll=g%codes(ll) - enddo - g%lthis=save_lthis - if(debug_g) write(*,*) 'VAR COMM BLK>',blk - end subroutine gen_var_comm_block - - !============================================================= - ! Variable assignment phase for inline shared proc body - !============================================================= - subroutine gen_var_shared_block(g,blk) - type(gen_state):: g - integer,intent(in):: blk - integer:: save_lthis,ll - if(debug_g) write(*,*) 'VAR SHARED BLK>',blk - save_lthis=g%lthis - call g_new_frame(g) - g%lstack(g%lthis)%loop_mode=loop_is_none - ll=blk - do while(ll>0) - g%lstack(g%lthis)%idx=g%lstack(g%lthis)%idx+1 - call gen_var_op(g,ll) - ll=g%codes(ll) - enddo - call sort_var_list(g) - g%lthis=save_lthis - if(debug_g) write(*,*) 'END VAR SHARED BLK>',blk - end subroutine gen_var_shared_block - - !======================================================================= - ! Reverse list of vars (varlist/link) for current loop context - ! to yield list in ascending order of start index (varlist/link) - ! and also create sorted list by finish index yielding (evarlist/elink) - !======================================================================== - subroutine sort_var_list(g) - type(gen_state):: g - integer:: v,v2 - integer:: finish,next,nextv - v=g%lstack(g%lthis)%varlist - g%lstack(g%lthis)%varlist=0 - g%lstack(g%lthis)%evarlist=0 - do while(v>0) - nextv=g%vardata(v)%link - g%vardata(v)%link=g%lstack(g%lthis)%varlist - g%lstack(g%lthis)%varlist=v - v2=g%lstack(g%lthis)%evarlist - finish=g%vardata(v)%finish - if(v2==0) then - g%lstack(g%lthis)%evarlist=v - g%vardata(v)%elink=0 - elseif(g%vardata(v2)%finish>=finish) then - g%vardata(v)%elink=v2 - g%lstack(g%lthis)%evarlist=v - else - do while(g%vardata(v2)%elink>0) - next=g%vardata(v2)%elink - if(g%vardata(next)%finish>=finish) exit - v2=next - enddo - g%vardata(v)%elink=g%vardata(v2)%elink - g%vardata(v2)%elink=v - endif - v=nextv - enddo - - if(debug_g) then - write(*,*) 'REVERSE OUT VARLIST>' - v=g%lstack(g%lthis)%varlist - do while(v>0) - write(*,*) v,g%vardata(v)%start - v=g%vardata(v)%link - enddo - write(*,*) 'SORT OUT EVARLIST>' - v=g%lstack(g%lthis)%evarlist - do while(v>0) - write(*,*) v,g%vardata(v)%finish - v=g%vardata(v)%elink - enddo - write(*,*) 'END SORT>' - endif - end subroutine sort_var_list - - !================================================== - ! Allocate variables on current list - ! This merges variables that are of the same type - ! but used at different times - !================================================== - subroutine alloc_var_list(g) - type(gen_state):: g - integer:: v,e,i - if(debug_g) write(*,*) 'ALLOCATING>',g%lthis - v=g%lstack(g%lthis)%varlist - e=g%lstack(g%lthis)%evarlist - do while(v/=0.and.e/=0) - i=min(g%vardata(v)%start,g%vardata(e)%finish+1) - do while(g%vardata(e)%finish+1==i) - call deallocate_var(g,e) - e=g%vardata(e)%elink - if(e==0) exit - enddo - if(debug_g) then - write(*,*) 'CONSIDER>',i,'#',v,g%vardata(v)%start,g%vardata(v)%finish,& - e,g%vardata(e)%start,g%vardata(e)%finish,g%vardata(e)%finish_on_assign - endif - if(g%vardata(e)%finish==i.and.& - g%vardata(v)%start==i.and.& - g%vardata(e)%finish_on_assign.and.& - iand(g%vardata(v)%flags,v_is_param+v_is_chan+v_is_result+v_is_shared)==0.and.& - iand(g%vardata(e)%flags,v_is_param+v_is_chan+v_is_result+v_is_shared)==0.and.& - g%vardata(v)%tno==g%vardata(e)%tno) then - call merge_vars(g,v,e) - v=g%vardata(v)%link - e=g%vardata(e)%elink - cycle - endif - do while(g%vardata(v)%start==i) - call allocate_var(g,v) - v=g%vardata(v)%link - if(v==0) exit - enddo - enddo - do while(e/=0) - call deallocate_var(g,e) - e=g%vardata(e)%elink - enddo -!!$ v=g%lstack(g%lthis)%varlist -!!$ do while(v/=0) -!!$ write(34,*) g%vardata(v)%index,g_var_at_index_is_a_vect(g,v) -!!$ v=g%vardata(v)%link -!!$ enddo - end subroutine alloc_var_list - - !=========================================== - ! Allocate a single variable - !=========================================== - subroutine allocate_var(g,v) - type(gen_state),intent(inout):: g - integer,intent(in):: v - integer:: tno,idx,isvect - if(debug_g) write(*,*) 'Allocate ',v - if(iand(g%vardata(v)%flags,v_is_param+v_is_chan+v_is_result)==0) then - isvect=merge(2,1,g_var_at_index_is_a_vect(g,v)) - tno=g%vardata(v)%tno - if(tnopm_string) then - idx=0 - if(debug_g) write(*,*) 'no storage',tno - else - if(debug_g) write(*,*) 'Freelist',tno,g%lstack(g%lthis)%free(isvect,tno) - if(g%lstack(g%lthis)%free(isvect,tno)/=0) then - idx=g%lstack(g%lthis)%free(isvect,tno) - g%lstack(g%lthis)%free(isvect,tno)=g%vardata(idx)%free - g%vardata(idx)%gflags=ior(g%vardata(idx)%gflags,var_is_recycled) - idx=abs(g%vardata(idx)%index) - if(debug_g) write(*,*) 'get free',idx - else - g%index=g%index+1 - idx=-g%index - endif - endif - else - if(debug_g) write(*,*) 'not crossing',g%vardata(v)%state==var_state_crossing - idx=0 - endif - if(debug_g) write(*,*) 'ALLOCATED>',v,idx,g%lthis - g%vardata(v)%index=idx - end subroutine allocate_var - - !=========================================== - ! Deallocate a single variable - !=========================================== - subroutine deallocate_var(g,v) - type(gen_state),intent(inout):: g - integer,intent(in):: v - integer:: tno,isvect - if(g%vardata(v)%index/=0) then - if(iand(g%vardata(v)%flags,v_is_chan+v_is_param+v_is_result+v_is_shared)==0) then - tno=g%vardata(v)%tno - isvect=merge(2,1,g_var_at_index_is_a_vect(g,v)) - if(debug_g) write(*,*) 'Deallocate',v,tno,isvect - g%vardata(v)%free=g%lstack(g%lthis)%free(isvect,tno) - g%lstack(g%lthis)%free(isvect,tno)=v - endif - endif - end subroutine deallocate_var - - !=========================================== - ! Merge v and e into a single variable - !=========================================== - subroutine merge_vars(g,v,e) - type(gen_state),intent(inout):: g - integer,intent(in):: v,e - if(g%vardata(e)%index==0.or.& - (g_var_at_index_is_a_vect(g,v).neqv.g_var_at_index_is_a_vect(g,e))) then - call allocate_var(g,v) - else - g%vardata(v)%index=abs(g%vardata(e)%index) - g%vardata(e)%gflags=ior(g%vardata(e)%gflags,var_is_recycled) - if(debug_g) then - write(*,*) 'MERGED>',g%vardata(v)%index - endif - endif - end subroutine merge_vars - - !================================================================= - ! Use a variable - called in variable allocation phase - ! Employs simple state engine to determine how a variable needs - ! to be stored - !================================================================= - recursive subroutine use_var(g,avar,isassign) - type(gen_state),intent(inout):: g - integer,intent(in):: avar - logical,intent(in),optional:: isassign - integer:: kind,state,i,j,var,flags,tno - integer,parameter,dimension(var_state_unused:var_state_closed):: new_state=(/& - var_state_used, & ! var_state_unused - var_state_used, & ! var_state_open - var_state_used, & ! var_state_used - var_state_crossing, & ! var_state_used_before - var_state_crossing, & ! var_state_crossing - var_state_used & ! var_state_closed - /) - if(avar==0.or.avar==shared_op_flag) return - var=abs(avar) - if(debug_g) write(*,*) 'USE VAR> ',var !,g_kind(g,var),g_v1(g,var) - kind=g_kind(g,var) - select case(kind) - case(v_is_group) - do i=1,g_v1(g,var) - call use_var(g,g_ptr(g,var,i),isassign) - enddo - case(v_is_sub,v_is_vsub) - call use_var(g,g_v1(g,var),isassign) - call use_var(g,g_v2(g,var),isassign) - case(v_is_elem,v_is_unit_elem,v_is_vect_wrapped) - call use_var(g,g_v1(g,var),isassign) - !g%varindex(var)=g%varindex(g_v1(g,var)) - case(v_is_const,v_is_ctime_const,v_is_parstmt_ve) - continue - case(v_is_cove) - call use_var(g,g_v2(g,var),isassign) - g%varindex(var)=g%varindex(g_v2(g,var)) - case(v_is_alias) - call use_var(g,g_v1(g,var),isassign) - g%varindex(var)=g%varindex(g_v1(g,var)) - case(v_is_chan_vect) - call use_var(g,g_v1(g,var),isassign) - g%varindex(var)=g%varindex(g_v1(g,var)) - case default - i=g%varindex(var) - if(i==0) then - g%nvars=g%nvars+1 - if(debug_g) write(*,*) 'CREATE>',var,g%nvars - i=g%nvars - if(kind==v_is_parve) then - g%vardata(i)%tno=pm_logical - flags=v_is_param - g%vardata(i)%name=0 - elseif(kind==v_is_ve) then - call use_var(g,g_v1(g,var)) - g%vardata(i)%tno=pm_logical - flags=0 - g%vardata(i)%name=0 - else - flags=g_v2(g,var) - tno=g_type(g,var) - g%vardata(i)%tno=tno - g%vardata(i)%name=g_v1(g,var) - endif - g%vardata(i)%flags=flags - if(iand(g%taints,proc_is_comm)/=0.and.& - iand(flags,v_is_param+v_is_result)/=0) then - if(iand(flags,v_is_shared)/=0) then - g%vardata(i)%state=var_state_used - g%vardata(i)%lthis=g%lthis - else - g%vardata(i)%state=var_state_crossing - if(iand(flags,v_is_result)/=0) then - g%vardata(i)%lthis=g%lthis - else - g%vardata(i)%lthis=g%lthis+1 - endif - endif - else - g%vardata(i)%lthis=g%lthis - g%vardata(i)%state=var_state_used - endif - g%vardata(i)%outer_lthis=g%vardata(i)%lthis - g%vardata(i)%start=g%lstack(g%lthis)%idx - g%vardata(i)%finish=g%vardata(i)%start - g%vardata(i)%index=0 - g%vardata(i)%link=g%lstack(g%lthis)%varlist - g%vardata(i)%gflags=0 - g%lstack(g%lthis)%varlist=i - g%vardata(i)%oindex=var - g%vardata(i)%finish_on_assign=.false. - g%varindex(var)=i - if(debug_g) write(*,*) 'NEW VAR>',var,i, g%vardata(i)%link - else - g%vardata(i)%state=new_state(g%vardata(i)%state) - g%vardata(i)%finish=g%lstack(g%vardata(i)%lthis)%idx - g%vardata(i)%outer_lthis=min(g%vardata(i)%outer_lthis,g%lthis) - g%vardata(i)%gflags=ior(g%vardata(i)%gflags,& - merge(var_is_reused,var_is_used,iand(g%vardata(i)%gflags,var_is_used)/=0)) - if(debug_g) then - write(*,*) 'CONSIDER>',i,present(isassign) - endif - g%vardata(i)%finish_on_assign=present(isassign) - endif - end select - end subroutine use_var - - !=========================================================== - ! In variable allocation phase - flag all active variables - ! when a comm op is encountered - !============================================================ - subroutine cross_all_vars(g) - type(gen_state),intent(inout):: g - integer:: var - if(g%lstack(g%lthis)%loop_mode==loop_is_none) return - g%loop_contains_shared=.true. - if(debug_g) write(*,*) 'CROSS ALL' - var=g%lstack(g%lthis)%varlist - do while(var>0) - if(debug_g) write(*,*) 'CROSS',var,'IN CROSS ALL' - call cross_var_at_index(g,var) - var=g%vardata(var)%link - end do - if(debug_g) write(*,*) 'CROSSED ALL' - end subroutine cross_all_vars - - !============================================================ - ! Flag a single variable crossed by comm op - !============================================================ - subroutine cross_var_at_index(g,i) - type(gen_state),intent(inout):: g - integer,intent(in):: i - integer:: state - integer,parameter,dimension(var_state_unused:var_state_closed):: new_state=(/& - var_state_unused, & ! var_state_unused - var_state_open, & ! var_state_open - var_state_used_before, & ! var_state_used - var_state_used_before, & ! var_state_used_before - var_state_crossing, & ! var_state_crossing - var_state_closed & ! var_state_closed - /) - if(g%lstack(g%lthis)%loop_mode==loop_is_none) return - if(i==0) return - if(g%vardata(i)%lthis/=g%lthis) return - if(iand(g%vardata(i)%flags,v_is_shared)/=0) return - state=g%vardata(i)%state - if(debug_g) write(*,*) 'Crossing',i,state,new_state(state) - g%vardata(i)%state=new_state(state) - end subroutine cross_var_at_index - - !================================================================== - ! Mark a variable as crossed (forced -not dependent on prior state) - !================================================================== - recursive subroutine cross_var(g,avar) - type(gen_state),intent(inout):: g - integer,intent(in):: avar - integer:: i,var - if(g%lstack(g%lthis)%loop_mode==loop_is_none) return - if(avar==0.or.avar==shared_op_flag) return - var=abs(avar) - select case(g_kind(g,var)) - case(v_is_group) - do i=1,g_v1(g,var) - call cross_var(g,g_ptr(g,var,i)) - enddo - case(v_is_sub,v_is_vsub) - call cross_var(g,g_v1(g,var)) - call cross_var(g,g_v2(g,var)) - case(v_is_elem,v_is_unit_elem) - call cross_var(g,g_v1(g,var)) - case(v_is_alias) - call cross_var(g,g_v1(g,var)) - case(v_is_const,v_is_ctime_const,v_is_ve,v_is_cove) - continue - case default - i=g%varindex(var) - if(i/=0) then - if(g%vardata(i)%lthis==g%lthis.and.& - iand(g%vardata(i)%flags,v_is_shared)==0) then - !g%vardata(i)%state=var_state_crossing# - g%vardata(i)%gflags=ior(g%vardata(i)%gflags,var_is_comm_op_par) - endif - endif - end select - end subroutine cross_var - - !============================================================ - ! If a variable was created outside of an iterative loop - ! then its lifetime must extend at least to the end of that - ! loop - !============================================================ - subroutine extend_finish_to_loop(g,loop_start_idx,loop_finish_idx,last_var_before_loop) - type(gen_state):: g - integer,intent(in):: loop_start_idx,loop_finish_idx,last_var_before_loop - integer:: var - ! Loop over vars created before loop - var=last_var_before_loop - do while(var>0) - if(g%vardata(var)%lthis==g%lthis) then - if(g%vardata(var)%finish>=loop_start_idx) then - g%vardata(var)%finish=loop_finish_idx - endif - endif - var=g%vardata(var)%link - end do - end subroutine extend_finish_to_loop - - - !**************************************************** - ! PHASE II - Generating FORTRAN code - !**************************************************** - - !============================================================ - ! Generate code for a block of wordcode operations - !============================================================ - recursive subroutine gen_block(g,loc) - type(gen_state):: g - integer,intent(in):: loc - integer:: l,save_last_ve - save_last_ve=g%last_ve - g%last_ve=0 - l=loc - do while(l>0) - call gen_op(g,l) - l=g%codes(l) - enddo - call gen_close_ifs(g,save_last_ve) - g%last_ve=save_last_ve - end subroutine gen_block - - !============================================================ - ! Generate code for single wordcode - ! operation - !============================================================ - recursive subroutine gen_op(g,loc) - type(gen_state):: g - integer,intent(in):: loc - integer:: opcode,opcode2,n,a,arg,save_lthis,l,ll,i,j,k,m,tno - logical:: ok,need_endif - - if(pm_debug_level>0) then - if(loc+comp_op_arg0>size(g%codes)) then - write(*,*) 'loc=',l,size(g%codes) - call pm_panic('gen_op bad loc') - endif - endif - - l=loc - - opcode=g%codes(l+comp_op_opcode) - opcode2=g%codes(l+comp_op_opcode2) - n=g%codes(l+comp_op_nargs) - a=l+comp_op_arg0 - - if(debug_g) write(*,*) 'GEN OP>',op_names(opcode),opcode2,n,'>',g%codes(a:a+n-1) - - if(pm_opts%ftn_comment_ops) then - call out_str(g,'! '//trim(op_names(opcode))) - do i=1,min(n,15) - call out_char(g,' ') - call out_idx(g,abs(g%codes(a+i-1))) - enddo - if(n>15) call out_str(g,' ...') - call out_new_line(g) - endif - - if(pm_opts%ftn_comment_lines) then - call out_char_idx(g,'!',g%codes(l+comp_op_line)/modl_mult) - call out_line(g,trim(pm_name_as_string(g%context,iand(g%codes(l+comp_op_line),modl_mult-1)))) - endif - - if(pm_opts%ftn_annotate) then - call out_char_idx(g,'!',merge(1000,0,g%lstack(g%lthis)%loop_active)+g%lthis) - call out_new_line(g) - endif - - select case(opcode) - case(op_if,op_if_shared) - if(opcode==op_if_shared) call gen_loop(g,l,.true.) - if(g%codes(a+1)/=0.or.g%codes(a+2)/=0) then - call out_simple(g,'IF($3) THEN',l) - call gen_block(g,g%codes(a+1)) - call gen_loop(g,l,.true.) - call out_simple(g,'ELSE',l) - call gen_block(g,g%codes(a+2)) - call gen_loop(g,l,.true.) - call out_line(g,'ENDIF') - endif - case(op_if_shared_node) - if(g%codes(a+1)/=0.or.g%codes(a+2)/=0) then - call out_line(g,'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE>1) THEN') - call gen_block(g,g%codes(a+1)) - call out_line(g,'ELSE') - call gen_block(g,g%codes(a+2)) - call out_line(g,'ENDIF') - endif - case(op_loop) - if(opcode2/=0) then - ! Loop contains shared operations so must - ! be places outside parallel loops - call gen_loop(g,l,.true.) - if(g_is_vect(g,g%codes(a+2))) then - call out_simple(g,'DO WHILE(ANY($#2))',l) - else - call out_simple(g,'DO WHILE($2)',l) - endif - call gen_block(g,g%codes(a+1)) - call gen_loop(g,l,.true.) - call out_line(g,'ENDDO ! LOOP') - else - call gen_loop(g,l,.false.) - call out_simple(g,'DO WHILE($2)',l) - call gen_block(g,g%codes(a+1)) - call out_line(g,'ENDDO ! LOOP') - endif - case(op_comm_block) - call gen_comm_block(g,l,g%codes(a+1),'$2') - case(op_comm_proc) - call gen_comm_block(g,l,g%codes(a+1),' ') - case(op_inline_shared) - if(pm_opts%ftn_annotate) call out_line(g,'! START SHARED BLOCK') - call gen_shared_block(g,l,g%codes(a+1)) - if(pm_opts%ftn_annotate) call out_line(g,'! END SHARED BLOCK') - case(op_comm_inline) - call out_line(g,'op_comm_inline') - call gen_loop(g,l,.true.) - case(op_do_loop) - call gen_loop(g,l,.true.) - do i=n/2,1,-1 - call out_str(g,'DO I') - call out_idx(g,i-1) - call out_char_idx(g,'_',g%lthis) - call out_str(g,'=0,-1+') - call out_arg(g,g%codes(a+i+n/2),arg_no_index) - call out_new_line(g) - enddo - do i=n/2,1,-1 - call out_arg(g,g%codes(a+i),0) - call out_str(g,'=I') - call out_idx(g,i-1) - call out_char_idx(g,'_',g%lthis) - call out_new_line(g) - enddo - call out_char_idx(g,'I',g%lthis) - call out_str(g,'=1+') - call out_char_idx(g,'I',0) - call out_char_idx(g,'_',g%lthis) - do i=2,n/2 - call out_char(g,'+') - call out_arg(g,g%codes(a+i+n/2-1),0) - call out_str(g,'*(I') - call out_idx(g,i-1) - call out_char_idx(g,'_',g%lthis) - enddo - do i=2,n/2 - call out_char(g,')') - enddo - call out_new_line(g) - g%lstack(g%lthis)%nloops=n/2 - g%lstack(g%lthis)%loop_mode=loop_is_contig - g%lstack(g%lthis)%loop_active=.true. - case(op_nested_loop) - call gen_loop(g,l,.true.) - g%lstack(g%lthis)%loop_par=g%codes(a+1) - g%lstack(g%lthis)%loop_mode=loop_is_nested - case(op_blocked_loop) - call gen_loop(g,l,.true.) - g%lstack(g%lthis)%loop_par=g%codes(a+n-1) - g%lstack(g%lthis)%loop_mode=loop_is_nested - call gen_loop(g,l,.false.) - do i=1,n-2 - call out_arg(g,g%codes(a+i),0) - call out_str(g,'=I') - call out_idx(g,i) - call out_char_idx(g,'_',g%lthis) - call out_new_line(g) - enddo - case(op_skip_empty) - call gen_active_check_start(g,l) - call gen_block(g,g%codes(a+1)) - call gen_active_check_end(g,l) - case(op_head_node) - call gen_loop(g,l,.true.) - call out_line(g,'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE==0) THEN') - call gen_block(g,g%codes(a+1)) - call out_line(g,'ENDIF') - case(op_over) - call gen_loop(g,l,.true.) - call gen_over_block(g,l,g%codes(a+1)) - call gen_loop(g,l,.true.) - case(op_call) - call gen_loop(g,l,.false.) - if(pm_opts%ftn_annotate.and..not.pm_opts%ftn_name_procs) then - call out_comment_line(g,trim(pm_name_as_string(g%context,g_procname(g,opcode2)))) - endif - call out_str(g,'CALL PM__P') - call out_idx(g,opcode2) - if(pm_opts%ftn_name_procs) then - call out_ftn_name(g,g_procname(g,opcode2)) - endif - call out_char(g,'(') - do i=1,n-1 - call out_call_arg(g,g%codes(a+i),0) - call out_comma(g) - enddo - call out_close(g) - call out_new_line(g) - case(op_comm_call) - if(g%codes(a)>0) then - call gen_stacked_ve(g,l,g%codes(a)) - endif - call gen_loop(g,l,.true.) - if(pm_opts%ftn_annotate.and..not.pm_opts%ftn_name_procs) then - call out_comment_line(g,trim(pm_name_as_string(g%context,g_procname(g,opcode2)))) - endif - call out_str(g,'CALL PM__P') - call out_idx(g,opcode2) - if(pm_opts%ftn_name_procs) then - call out_ftn_name(g,g_procname(g,opcode2)) - endif - call out_str(g,'(N') - call out_idx(g,g%lthis) - call out_char(g,',') - if(g%codes(a)>0) then - call out_call_arg(g,g%codes(a),arg_no_index+arg_comm_arg) - call out_char(g,',') - endif - do i=1,n-1 - call out_call_arg(g,g%codes(a+i),arg_no_index+arg_comm_arg) - call out_comma(g) - enddo - call out_close(g) - call out_new_line(g) - case(op_comm_loop,op_comm_loop_par) - call gen_loop(g,l,.true.) - need_endif=.false. - if(g_is_vect(g,g%codes(a+2))) then - if(opcode==op_comm_loop_par) then - call out_simple(g,'LOK=PM__TEST_LOOP(ANY($#2))',l) - else - call out_simple(g,'LOK=ANY($#2)',l) - endif - call out_line(g,'DO WHILE(LOK)') - call out_simple(g,'IF($2) THEN',l) - need_endif=.true. - else - call out_simple(g,'DO WHILE($2)',l) - endif - call gen_block(g,g%codes(a+1)) - call gen_loop(g,l,.true.) - if(g_is_vect(g,g%codes(a+2))) then - if(opcode==op_comm_loop_par) then - call out_simple(g,'LOK=PM__TEST_LOOP(ANY($#2))',l) - else - call out_simple(g,'LOK=ANY($#2)') - endif - endif - if(need_endif) call out_line(g,'ENDIF') - call out_line(g,'ENDDO ! COMM LOOP') - case(op_remote_call,op_remote_send_call) - call gen_loop(g,l,.true.) - if(pm_opts%ftn_annotate) call out_line(g,'!START REMOTE CALL') - call gen_mpi_remote_call(g,l,opcode==op_remote_send_call) - if(pm_opts%ftn_annotate) call out_line(g,'!END REMOTE CALL') - case(op_server_call,op_collect_call) - call gen_loop(g,l,.true.) - call gen_mpi_collect_call(g,l,opcode==op_collect_call) - case(op_bcast_call) - call gen_loop(g,l,.true.) - if(g%codes(a)==0) then - call gen_mpi_bcast_call(g,l) - else - call gen_mpi_masked_bcast_call(g,l) - endif - - case(op_do_at) - call gen_loop(g,l,.false.) - if(opcode2==1) then - call out_simple(g,'IDO=I$N',n=g%lthis) - else - call out_simple(g,'IDO=$2+1',l) - endif - i=g_lthis(g,g%codes(a+merge(2,3,opcode2==1))) - if(i/=0.and.g%lstack(i)%loop_active) then - write(*,*) 'lthis=',g%lthis,'from',g%codes(a+3) - call pm_panic('Loop active in op_do_at') - endif - g%lalt=i - call gen_block(g,g%codes(a+1)) - g%lalt=-1 - case(op_get_size) - call gen_loop(g,l,.true.) - if(g_kind(g,g%codes(a+2))==v_is_group) then - call out_simple_part(g,'$1=SIZE(',l) - call out_arg(g,g_ptr(g,g%codes(a+2),1),0) - call out_line(g,'%P)') - else - call out_simple(g,'$1=SIZE($2%E1%P)',l) - endif - case(op_dref) - ! This does not generate code - ! - just present for Phase I - continue - case(op_wrap) - ! Save the current loop context for variable - !write(*,*) 'WRAP',g%lthis,'to',g%codes(a+1) - call g_set_v2(g,g%codes(a+1),g%lthis) - - case(op_sync) - call gen_loop(g,l,.true.) - - case(op_isend) - call gen_loop(g,l,.false.) - call out_simple(g,'JNODE=$1',l) - call gen_mpi_send(g,g%codes(a+2),'PM__DATA_TAG','ISEND',mode_array) - case(op_irecv) - call gen_loop(g,l,.false.) - call out_simple(g,'JNODE=$1',l) - call gen_mpi_recv(g,g%codes(a+2),'PM__DATA_TAG','IRECV',mode_array,.false.) - case(op_recv) - call gen_loop(g,l,.false.) - call out_simple(g,'JNODE=$1',l) - call gen_mpi_recv(g,g%codes(a+2),'PM__DATA_TAG','RECV',mode_array,.false.) - - case(op_isend_grid) - call gen_loop(g,l,.false.) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_send_disp_or_grid(g,g%codes(a+3),'PM__DATA_TAG','ISEND',g%codes(a+1),mode_array) - case(op_irecv_grid) - call gen_loop(g,l,.false.) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_recv_disp_or_grid(g,g%codes(a+3),'PM__DATA_TAG','IRECV',g%codes(a+1),mode_array,.false.) - case(op_recv_grid,op_recv_grid_resend) - call gen_loop(g,l,.false.) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_recv_disp_or_grid(g,g%codes(a+3),'PM__DATA_TAG','RECV',g%codes(a+1),mode_array,.false.) - - case(op_isend_offset) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_send_disp_or_grid(g,g%codes(a+3),'PM__DATA_TAG','ISEND',g%codes(a+1),mode_array) - call gen_active_check_end(g,l) - case(op_irecv_offset) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_recv_disp_or_grid(g,g%codes(a+3),'PM__DATA_TAG','IRECV',g%codes(a+1),mode_array,.false.) - call gen_active_check_end(g,l) - case(op_recv_offset,op_recv_offset_resend) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_recv_disp_or_grid(g,g%codes(a+3),'PM__DATA_TAG','RECV',g%codes(a+1),mode_array,.false.) - call gen_active_check_end(g,l) - case(op_isend_reply) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$1',l) - call gen_mpi_send(g,g%codes(a+2),'PM__DATA_TAG','RSEND',mode_vect) - call gen_active_check_end(g,l) - - case(op_sync_mess) - call gen_loop(g,l,.true.) - call gen_sync_mess(g,l,a,n) - - case(op_broadcast) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$2',l) - call gen_mpi_bcast(g,g%codes(a+1)) - call gen_active_check_end(g,l) - case(op_broadcast_shared) - call gen_active_check_start(g,l) - call gen_mpi_bcast(g,g%codes(a+1),isshared=.true.) - call gen_active_check_end(g,l) - case(op_broadcast_val) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$3',l) - call out_simple(g,& - 'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) $1=$2') - call gen_mpi_bcast(g,g%codes(a+1)) - call gen_active_check_end(g,l) - - case(op_broadcast_disp) - !!! Needs rewriting a part of broader fix for this operation - call out_simple(g,'JNODE=$2',l) - if(n>4) then - call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%lthis) - call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$5,NREQ)',l,n=g%lthis) - call gen_mpi_bcast_part(g,g%codes(a+3),.false.,'RBUFFER%P','1','NREQ',mode_vect) - else - !!! Do we need to check if grid or not? - call gen_mpi_bcast_part(g,g%codes(a+3),.false.,'$A','1','SIZE($A)',& - mode_vect,dvv=g%codes(a+1)) - endif - - case(op_isend_req,op_isend_assn) - call gen_active_check_start(g,l) - !call out_line(g,'write(*,*) "ISEND_ASSN"') - call out_simple(g,'JNODE=$2',l) - if(n>6) then - call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%lthis) - call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$6,NREQ)',l,n=g%lthis) - call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - call out_line(g,'CALL MPI_ISEND(NREQ,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)') - call out_line(g,'PM__PUSH_MESSAGE(JMESS)') - call gen_mpi_send_part(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','ISEND','RBUFFER%P','1','NREQ',mode_vect) - if(opcode==op_isend_req) then - call gen_mpi_recv_part(g,g%codes(a+3),'PM__DATA_TAG','IRECV',.false.,'RBUFFER%P','1','NREQ',mode_vect) - else - call gen_mpi_send_part(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','ISEND','RBUFFER%P','1','NREQ',mode_vect) - endif - else - if(g_kind(g,g%codes(a+1))==v_is_group) then - call out_simple(g,'NREQ=$X',x=g_ptr(g,g%codes(a+1),2)) - else - call out_simple(g,'NREQ=SIZE($#1)',l) - endif - call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - call out_line(g,'CALL MPI_ISEND(NREQ,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)') - call gen_mpi_send_disp_or_grid(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','ISEND',g%codes(a+1),mode_vect) - if(opcode==op_isend_req) then - call gen_mpi_recv_disp_or_grid(g,g%codes(a+4),'PM__DATA_TAG','IRECV',g%codes(a+1),mode_vect,.false.) - else - call gen_mpi_send_disp_or_grid(g,g%codes(a+4),'PM__EXTRA_REQ_TAG','ISEND',g%codes(a+1),mode_vect) - endif - endif - call gen_active_check_end(g,l) - - case(op_recv_reply) - call gen_active_check_start(g,l) - call out_simple(g,'JNODE=$2',l) - if(n>4) then - call out_simple(g,'ALLOCATE RBUFFER%P(N$N)',n=g%lthis) - call out_simple(g,'CALL PM__MASK_OFFSETS(N$N,$1,RBUFFER%P,$5,NREQ)',l,n=g%lthis) - call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - call gen_mpi_recv_part(g,g%codes(a+3),'PM__DATA_TAG','RECV',.true.,'RBUFFER%P','1','NREQ',mode_vect) - else - call gen_mpi_recv_disp_or_grid(g,g%codes(a+4),'PM__DATA_TAG','RECV',g%codes(a+1),mode_vect,.true.) - endif - call gen_active_check_end(g,l) - case(op_recv_req_calL,op_recv_assn_call) - call gen_active_check_start(g,l) - call gen_mpi_recv_call(g,l,g%codes(a+1),opcode==op_recv_assn_call) - call gen_active_check_end(g,l) - case(op_active) - call gen_stacked_ve(g,l,g%codes(a),g%codes(a+1)) - call gen_loop(g,l,.true.) - case(op_wshare) - call out_simple_scalar(g,'$1=PM__WSHARE($2%E1%P,$3,$4,$5)',l) - case(op_sys_node) - call out_simple_scalar(g,'$1=PM__SYS_NODE',l) - case(op_sys_nnode) - call out_simple_scalar(g,'$1=PM__SYS_NNODE',l) - case(op_this_node) - call out_simple_scalar(g,'$1=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE',l) - case(op_this_nnode) - call out_simple_scalar(g,'$1=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NNODE',l) - case(op_shared_node) - call out_simple_scalar(g,'$1=PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE',l) - case(op_shared_nnode) - call out_simple_scalar(g,'$1=PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NNODE',l) - case(op_is_shared) - call out_simple_scalar(g,'$1=PM__NODE_FRAME(PM__NODE_DEPTH)%IS_SHARED',l) - case(op_is_par) - call out_simple_scalar(g,'$1=PM__CONC_DEPTH.EQ.0',l) - case(op_get_dims) - call gen_loop(g,l,.false.) - m=(n-2)/2 - if(m==1) then - call out_simple(g,'$1=MERGE($3,$2,$3.GT.0.AND.$2.NE.1)',l) - else - call out_simple(g,'IF($X.GT.1)THEN',l,x=m+1) - do i=m+2,m+m+1 - call out_simple(g,'Z%P($N)=$X',l,n=i-m-1,x=i) - enddo - call out_simple(g,'CALL MPI_DIMS_CREATE(INT($X),$N,Z%P,JERRNO)',l,n=m,x=m+1) - do i=1,m - call out_simple(g,'$X=Z%P($N)',l,n=i,x=i) - enddo - call out_line(g,'ELSE') - do i=1,m - call out_simple(g,'$X=1',l,x=i) - enddo - call out_line(g,'ENDIF') - endif - case(op_push_node_split) - call out_simple_scalar(g,'CALL PM__PUSH_NODE_SPLIT($1)',l) - case(op_push_node_distr) - call gen_loop(g,l,.false.) - call out_line(g,'CALL PM__PUSH_NODE_DISTR()') - case(op_push_node_conc) - call gen_loop(g,l,.false.) - call out_line(g,'CONC_DEPTH=CONC_DEPTH+1') - case(op_pop_node_conc) - call gen_loop(g,l,.false.) - call out_line(g,'CONC_DEPTH=CONC_DEPTH-1') - case(op_pop_node) - call gen_loop(g,l,.true.) - call out_line(g,'CALL PM__POP_NODE()') - case(op_make_poly) - call out_simple_scalar(g,'IF(ALLOCATED($1%P)) DEALLOCATE($1%P)',l) - if(g_type(g,g%codes(a+2))<=pm_string) then - call out_simple(g,'ALLOCATE($1%P,SOURCE=PM__BOX$S($2))',l,& - x=g_type(g,g%codes(a+2))) - else - call out_simple(g,'ALLOCATE($1%P,SOURCE=$2)',l) - endif - case(op_any) - call out_simple_scalar(g,'$1=.FALSE.',l) - call out_simple(g,'SELECT TYPE(POLYVAR=>$3%P)',l) - if(opcode2<=pm_string) then - call out_simple(g,'TYPE IS(PM__T$S)',x=opcode2) - call out_simple(g,'$2=POLYVAR%P',l) - else - call out_simple(g,'TYPE IS(PM__T$N)',n=opcode2) - call out_simple(g,'$2=POLYVAR',l) - endif - call out_simple(g,'$1=.TRUE.',l) - call out_line(g,'END SELECT') - - case(op_intersect_seq) - call out_simple_scalar(g,& - 'CALL PM__INTERSECT_SEQ($5,$6,$7,$8,$9,$(10),$(11),$(12),$1,$2,$3,$4)',l) - case(op_intersect_aseq) - if(opcode2==0) then - call out_simple_scalar(g,'CALL PM__INTERSECT_ASEQ($2,$3,$4,$5,$6,$1)',l) - elseif(opcode2==1) then - call out_simple_scalar(g,'CALL PM__OVERLAP_ASEQ($2,$3,$4,$5,$6,$1)',l) - else - call out_simple_scalar(g,'CALL PM__OVERLAP_ASEQ($2,$3,$4,$5,$6,$7,$1)',l) - endif - case(op_assign) - if(.not.(g_vars_are_merged(g,g%codes(a+1),g%codes(a+2)).or.& - g_var_is_dead(g,g%codes(a+1)))) then - if(pm_opts%ftn_annotate) then - call out_simple(g,'!ASSIGN (opcode2=$N)',n=abs(opcode2)) - endif - call out_simple_scalar(g,'$1=$2',l) - else - if(pm_opts%ftn_annotate) then - call out_comment_line(g,'Eliminated merge assign:'//& - merge('Y','N',g_var_is_dead(g,g%codes(a+1)))//& - merge('Y','N',g_vars_are_merged(g,g%codes(a+1),g%codes(a+2)))) - endif - endif - case(op_assign_farray) - if(pm_opts%ftn_annotate) then - call out_comment_line(g,'! ASSIGN FARRAY') - endif - call out_simple_scalar(g,'$1=$2',l) - case(op_and_ve) - if(pm_opts%ftn_annotate) then - call out_comment_line(g,'! AND_VE') - endif - call out_simple_scalar(g,'$1=$2',l) - case(op_andnot_ve) - if(pm_opts%ftn_annotate) then - call out_comment_line(g,'! AND_NOT_VE') - endif - call out_simple_scalar(g,'$1=.NOT.($2)',l) - case(op_print) - call out_simple_scalar(g,'CALL PM__PRINT($1)',l) - case(op_concat) - call out_simple_scalar(g,'$1=PM__CONCAT_STR($2,$3)',l) - case(op_check) - call out_simple_scalar(g,'IF(.NOT.$2) CALL PM__ABORT($1)',l) - - case(op_array,op_var_array) - ! V n x - call out_simple_scalar(g,'IF(ALLOCATED($1%E1%P)) DEALLOCATE($1%E1%P)',l) - call out_simple(g,'ALLOCATE($1%E1%P(MAX($4,1)),SOURCE=$2)',l) - call out_simple(g,'$1%E2=$3',l) - if(g_type(g,g%codes(a+3))==pm_long) then - call out_simple(g,'$1%E3=$4',l) - endif - case(op_fill) - call gen_loop(g,l,.false.) - call out_simple(g,'DO IJ=$N+1,$3',l,n=opcode2) - call out_arg(g,g%codes(a+1),arg_no_index) - call out_char(g,'(') - if(g_is_vect(g,g%codes(a+1))) then - call out_str(g,'IJ,I') - call out_idx(g,g%lthis) - call out_str(g,')=') - else - call out_str(g,'IJ)=') - endif - call out_arg(g,g%codes(a+2),0) - call out_new_line(g) - call out_line(g,'ENDDO') - case(op_break_loop) - call gen_loop(g,l,.true.) - case(op_get_rf) - call out_simple_scalar(g,'$1=$2',l) - case(op_open_file) - call out_simple_scalar(g,'$1=PM__FILE_OPEN($3%P,$4,$5,$6,$7,$8,$9,$(10),$2)',l) - case(op_close_file) - call out_simple_scalar(g,'CALL MPI_FILE_CLOSE($2,$1)',l) - case(op_seek_file) - call out_simple_scalar(g,'CALL MPI_FILE_SEEK($2,$3,MPI_SEEK_SET,$1)',l) - case(op_read_file) - call out_get_mpi_base_type(g,g_type(g,g%codes(a+3))) - call out_simple_scalar(g,'CALL MPI_FILE_READ_ALL($2,$3,1,JBASE,MPI_STATUS_IGNORE,$1)',l) - case(op_write_file) - call gen_loop(g,l,.false.) - call out_line(g,'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE==0) THEN') - call out_get_mpi_base_type(g,g_type(g,g%codes(a+3))) - call out_simple(g,'CALL MPI_FILE_WRITE($2,$3,1,JBASE,MPI_STATUS_IGNORE,$1)',l,& - x=g_type(g,g%codes(a+3))) - call out_line(g,'ENDIF') - call out_simple(g,'CALL PM__SYNC_FILE_WRITE($2,$1)',l) - case(op_read_file_array) - call gen_loop(g,l,.false.) - call out_get_mpi_base_type(g,g_type(g,g%codes(a+3))) - call out_simple(g,'CALL PM__GET_MPI_TYPE(JBASE,$4,JTYPE,JN,LNEW)',l) - call out_simple(g,'CALL MPI_FILE_READ_ALL($2,$3,JN,JTYPE,MPI_STATUS_IGNORE,$1)',l) - call out_line(g,'IF(LNEW) CALL MPI_TYPE_FREE(JTYPE,JERRNO)') - case(op_write_file_array) - call gen_loop(g,l,.false.) - call out_line(g,'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE==0) THEN') - call out_get_mpi_base_type(g,g_type(g,g%codes(a+3))) - call out_simple(g,'CALL PM__GET_MPI_TYPE(JBASE,$4,JTYPE,JN,LNEW)',l) - call out_simple(g,'CALL MPI_FILE_WRITE($2,$3,JN,JTYPE,MPI_STATUS_IGNORE,$1)',l) - call out_line(g,'IF(LNEW) CALL MPI_TYPE_FREE(JTYPE,JERRNO)') - call out_line(g,'ENDIF') - call out_simple(g,'CALL PM__SYNC_FILE_WRITE($2,$1)',l) - case(op_read_file_tile,op_write_file_tile) - call gen_loop(g,l,.true.) - call out_get_mpi_base_type(g,g_type(g,g%codes(a+3))) - call out_simple(g,'CALL PM__FILE_SET_VIEW($2,JBASE,$#4,N$N,$5,$1,OFFSET)',l,& - n=g%lthis) - call out_simple(g,'IF($1==0) THEN',l) - call out_get_mpi_base_type(g,g_type(g,g%codes(a+5))) - call out_simple(g,'CALL PM__GET_MPI_TYPE(JBASE,N$N,JTYPE,JN,LNEW)',l,n=g%lthis) - if(opcode==op_read_file_tile) then - call out_simple(g,'CALL MPI_FILE_READ_ALL($2,$#3,JN,JTYPE,MPI_STATUS_IGNORE,$1)',l) - else - call out_simple(g,'CALL MPI_FILE_WRITE_ALL($2,$#3,JN,JTYPE,MPI_STATUS_IGNORE,$1)',l) - endif - call out_line(g,'IF(LNEW) CALL MPI_TYPE_FREE(JTYPE,JERRNO)') - call out_line(g,'ENDIF') - call out_simple(g,'CALL PM__FILE_RESET_VIEW($2,OFFSET,$1)',l) - case(op_io_error_string) - call out_simple_scalar(g,'$1=PM__IO_ERROR_STRING($2)',l) - - case(op_and) - call out_simple_scalar(g,'$1=$2.AND.$3',l) - case(op_or) - call out_simple_scalar(g,'$1=$2.OR.$3',l) - case(op_eq_l) - call out_simple_scalar(g,'$1=$2.EQV.$3',l) - case(op_ne_l) - call out_simple_scalar(g,'$1=$2.NEQV.$3',l) - case(op_not) - call out_simple_scalar(g,'$1=.NOT.$2',l) - case(op_assign_l) - call out_simple_scalar(g,'$1=$2',l) - - case(op_string_i) - call out_simple_scalar(g,'$1=PM__INT_TO_STR($2)',l) - case(op_string_ln) - call out_simple_scalar(g,'$1=PM__LONG_TO_STR($2)',l) - case(op_string_offset) - call out_simple_scalar(g,'$1=PM__OFFSET_TO_STR($2)',l) - case(op_string_i64) - call out_simple_scalar(g,'$1=PM__INT64_TO_STR($2)',l) - case(op_string_r) - call out_simple_scalar(g,'$1=PM__REAL_TO_STR($2)',l) - case(op_string_l) - call out_simple_scalar(g,'$1=PM__BOOL_TO_STR($2)',l) - case(op_string_d) - call out_simple_scalar(g,'$1=PM__DOUBLE_TO_STR($2)',l) - case(op_add_i,op_add_ln,op_add_offset,op_add_i8,op_add_i16,op_add_i32,& - op_add_i64,op_add_r,op_add_d,op_add_c,op_add_dc) - call out_simple_scalar(g,'$1=$2+$3',l) - case(op_sub_i,op_sub_ln,op_sub_offset,op_sub_i8,op_sub_i16,op_sub_i32,& - op_sub_i64,op_sub_r,op_sub_d,op_sub_c,op_sub_dc) - call out_simple_scalar(g,'$1=$2-$3',l) - case(op_mult_i,op_mult_ln,op_mult_offset,op_mult_i8,op_mult_i16,op_mult_i32,& - op_mult_i64,op_mult_r,op_mult_d,op_mult_c,op_mult_dc) - call out_simple_scalar(g,'$1=$2*$3',l) - case(op_divide_i,op_divide_ln,op_divide_offset,op_divide_i8,op_divide_i16,op_divide_i32,& - op_divide_i64,op_divide_r,op_divide_d,op_divide_c,op_divide_dc) - call out_simple_scalar(g,'$1=$2/$3',l) - case(op_mod_i,op_mod_ln,op_mod_offset,op_mod_i8,op_mod_i16,op_mod_i32,& - op_mod_i64,op_mod_r,op_mod_d) - call out_simple_scalar(g,'$1=MODULO($2,$3)',l) - case(op_pow_i,op_pow_ln,op_pow_offset,op_pow_i8,op_pow_i16,op_pow_i32,& - op_pow_i64,op_pow_r,op_pow_d,op_pow_c,op_rpow_c,op_pow_dc,op_dpow_dc) - call out_simple_scalar(g,'$1=$2**$3',l) - case(op_uminus_i,op_uminus_ln,op_uminus_offset,op_uminus_i8,op_uminus_i16,op_uminus_i32,& - op_uminus_i64,op_uminus_r,op_uminus_d,op_uminus_c,op_uminus_dc) - call out_simple_scalar(g,'$1=-$2',l) - case(op_eq_i,op_eq_ln,op_eq_offset,op_eq_i8,op_eq_i16,op_eq_i32,& - op_eq_i64,op_eq_r,op_eq_d,op_eq_c,op_eq_dc) - call out_simple_scalar(g,'$1=$2.EQ.$3',l) - case(op_ne_i,op_ne_ln,op_ne_offset,op_ne_i8,op_ne_i16,op_ne_i32,& - op_ne_i64,op_ne_r,op_ne_d,op_ne_c,op_ne_dc) - call out_simple_scalar(g,'$1=$2.NE.$3',l) - case(op_gt_i,op_gt_ln,op_gt_offset,op_gt_i8,op_gt_i16,op_gt_i32,& - op_gt_i64,op_gt_r,op_gt_d) - call out_simple_scalar(g,'$1=$2.GT.$3',l) - case(op_ge_i,op_ge_ln,op_ge_offset,op_ge_i8,op_ge_i16,op_ge_i32,& - op_ge_i64,op_ge_r,op_ge_d) - call out_simple_scalar(g,'$1=$2.GE.$3',l) - case(op_max_i,op_max_ln,op_max_offset,op_max_i8,op_max_i16,op_max_i32,& - op_max_i64,op_max_r,op_max_d) - call out_simple_scalar(g,'$1=MAX($2,$3)',l) - case(op_min_i,op_min_ln,op_min_offset,op_min_i8,op_min_i16,op_min_i32,& - op_min_i64,op_min_r,op_min_d) - call out_simple_scalar(g,'$1=MIN($2,$3)',l) - case(op_assign_i,op_assign_ln,op_assign_offset,op_assign_i8,op_assign_i16,op_assign_i32,& - op_assign_i64,op_assign_r,op_assign_d,op_assign_c,op_assign_dc) - call out_simple_scalar(g,'$1=$2',l) - case(op_abs_i,op_abs_ln,op_abs_offset,op_abs_i8,op_abs_i16,op_abs_i32,& - op_abs_i64,op_abs_r,op_abs_d,op_abs_c,op_abs_dc) - call out_simple_scalar(g,'$1=ABS($2)',l) - case(op_pdiff_i,op_pdiff_ln,op_pdiff_offset,op_pdiff_i8,op_pdiff_i16,op_pdiff_i32,& - op_pdiff_i64,op_pdiff_r,op_pdiff_d) - call out_simple_scalar(g,'$1=DIM($2,$3)',l) - case(op_sign_i,op_sign_ln,op_sign_offset,op_sign_i8,op_sign_i16,op_sign_i32,& - op_sign_i64,op_sign_r,op_sign_d) - call out_simple_scalar(g,'$1=SIGN($2,$3) ! SIGN',l) - case(op_modulo_i,op_modulo_ln,op_modulo_offset,op_modulo_i8,op_modulo_i16,op_modulo_i32,& - op_modulo_i64,op_modulo_r,op_modulo_d) - call out_simple_scalar(g,'$1=MOD($2,$3)',l) - - case(op_bnot_i,op_bnot_ln,op_bnot_offset,& - op_bnot_i8,op_bnot_i16,op_bnot_i32,op_bnot_i64) - call out_simple_scalar(g,'$1=NOT($2)',l) - case(op_band_i,op_band_ln,op_band_offset,& - op_band_i8,op_band_i16,op_band_i32,op_band_i64) - call out_simple_scalar(g,'$1=IAND($2,$3)',l) - case(op_bor_i,op_bor_ln,op_bor_offset,& - op_bor_i8,op_bor_i16,op_bor_i32,op_bor_i64) - call out_simple_scalar(g,'$1=IOR($2,$3)',l) - case(op_bxor_i,op_bxor_ln,op_bxor_offset,& - op_bxor_i8,op_bxor_i16,op_bxor_i32,op_bxor_i64) - call out_simple_scalar(g,'$1=IEOR($2,$3)',l) - case(op_bshift_i,op_bshift_ln,op_bshift_offset,& - op_bshift_i8,op_bshift_i16,op_bshift_i32,op_bshift_i64) - call out_simple_scalar(g,'$1=ISHFT($2,$3)',l) - - case(op_acos_r,op_acos_d,op_acos_c,op_acos_dc) - call out_simple_scalar(g,'$1=ACOS($2)',l) - case(op_asin_r,op_asin_d,op_asin_c,op_asin_dc) - call out_simple_scalar(g,'$1=ASIN($2)',l) - case(op_atan_r,op_atan_d,op_atan_c,op_atan_dc) - call out_simple_scalar(g,'$1=ATAN($2)',l) - case(op_atan2_r,op_atan2_d) - call out_simple_scalar(g,'$1=ATAN2($2,$3)',l) - case(op_cos_r,op_cos_d,op_cos_c,op_cos_dc) - call out_simple_scalar(g,'$1=COS($2)',l) - case(op_cosh_r,op_cosh_d,op_cosh_c,op_cosh_dc) - call out_simple_scalar(g,'$1=COSH($2)',l) - case(op_exp_r,op_exp_d,op_exp_c,op_exp_dc) - call out_simple_scalar(g,'$1=EXP($2)',l) - case(op_log_r,op_log_d,op_log_c,op_log_dc) - call out_simple_scalar(g,'$1=LOG($2)',l) - case(op_log10_r,op_log10_d) - call out_simple_scalar(g,'$1=LOG10($2)',l) - case(op_sin_r,op_sin_d,op_sin_c,op_sin_dc) - call out_simple_scalar(g,'$1=SIN($2)',l) - case(op_sinh_r,op_sinh_d,op_sinh_c,op_sinh_dc) - call out_simple_scalar(g,'$1=SINH($2)',l) - case(op_sqrt_r,op_sqrt_d,op_sqrt_c,op_sqrt_dc) - call out_simple_scalar(g,'$1=SQRT($2)',l) - case(op_tan_r,op_tan_d,op_tan_c,op_tan_dc) - call out_simple_scalar(g,'$1=TAN($2)',l) - case(op_tanh_r,op_tanh_d,op_tanh_c,op_tanh_dc) - call out_simple_scalar(g,'$1=TANH($2)',l) - case(op_floor_r,op_floor_d) - call out_simple_scalar(g,'$1=FLOOR($2)',l) - case(op_ceil_r,op_ceil_d) - call out_simple_scalar(g,'$1=CEILING($2)',l) - - case(op_imag_c,op_imag_dc) - call out_simple_scalar(g,'$1=IMAG($2)',l) - case(op_conj_c,op_conj_dc) - call out_simple_scalar(g,'$1=CONJG($2)',l) - - case(op_int_ln,op_int_offset,op_int_r,op_int_d,& - op_int_i8,op_int_i16,op_int_i32,op_int_i64) - call out_simple_scalar(g,'$1=INT($2)',l) - case(op_long_i,op_long_offset,op_long_r,op_long_d,& - op_long_i8,op_long_i16,op_long_i32,op_long_i64) - call out_simple_scalar(g,'$1=INT($2,KIND=PM__LN)',l) - case(op_offset_i,op_offset_ln,op_offset_r,op_offset_d,& - op_offset_i8,op_offset_i16,op_offset_i32,op_offset_i64) - call out_simple_scalar(g,'$1=INT($2,KIND=PM__LN)',l) - case(op_real_i,op_real_ln,op_real_offset,op_real_d,& - op_real_i8,op_real_i16,op_real_i32,op_real_i64,op_real_c) - call out_simple_scalar(g,'$1=REAL($2)',l) - case(op_double_i,op_double_ln,op_double_offset,op_double_r,& - op_double_i8,op_double_i16,op_double_i32,op_double_i64,& - op_real_dc) - call out_simple_scalar(g,'$1=REAL($2,KIND=PM__D)',l) - case(op_i8_i,op_i8_ln,op_i8_offset,& - op_i8_i16,op_i8_i32,op_i8_i64) - call out_simple_scalar(g,'$1=INT($2,KIND=PM__i8)',l) - case(op_i16_i,op_i16_ln,op_i16_offset,& - op_i16_i8,op_i16_i32,op_i16_i64) - call out_simple_scalar(g,'$1=INT($2,KIND=PM__i16)',l) - case(op_i32_i,op_i32_ln,op_i32_offset,& - op_i32_i8,op_i32_i16,op_i32_i64) - call out_simple_scalar(g,'$1=INT($2,KIND=PM__i32)',l) - case(op_i64_i,op_i64_ln,op_i64_offset,& - op_i64_i8,op_i64_i16,op_i64_i32) - call out_simple_scalar(g,'$1=INT($2,KIND=PM__i64)',l) - case(op_complex_r) - call out_simple_scalar(g,'$1=CMPLX($2,0.0)',l) - case(op_complex_d) - call out_simple_scalar(g,'$1=CMPLX($2,0.0d0,kind=PM__D)',l) - case(op_complex2_r) - call out_simple_scalar(g,'$1=CMPLX($2,$3)',l) - case(op_complex2_d) - call out_simple_scalar(g,'$1=CMPLX($2,$3,kind=PM__D)',l) - case(op_logical_return,op_miss_arg,op_default) - continue - - case default - write(*,*) opcode - write(*,*) op_names(opcode),op_names(opcode-1),op_names(opcode+1) - call pm_panic('cannot compile operation') - end select - -88 continue - - if(debug_g) write(*,*) 'GEN OP DONE> ',op_names(opcode),opcode2,n - - end subroutine gen_op - - !============================================================ - ! Implement an over command - ! - basically save/resore current loop state - ! to allow this to be overridden within the - ! block - !============================================================ - subroutine gen_over_block(g,l,blk) - type(gen_state):: g - integer,intent(in):: l,blk - type(gloop):: save_loop - save_loop=g%lstack(g%lthis) - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_none - call gen_block(g,blk) - call gen_loop(g,l,.true.) - g%lstack(g%lthis)=save_loop - end subroutine gen_over_block - - !============================================================ - ! Generate code for block containing comm ops - !============================================================ - subroutine gen_comm_block(g,l,lnew,nc) - type(gen_state):: g - integer,intent(in):: l,lnew - character(len=*),intent(in):: nc - integer:: save_lthis,ll,save_last_ve - call gen_loop(g,l,.false.) - save_last_ve=g%last_ve - g%last_ve=0 - g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_contig - - if(pm_opts%ftn_annotate) call out_simple(g,'! BLOCK -> $N',n=g%lthis) - if(nc/=' ') call out_simple(g,'N$N='//nc,l,n=g%lthis) - call gen_vect_alloc(g) - g%lstack(g%lthis)%loop_active=.false. - ll=lnew - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - call gen_loop(g,l,.true.) - call gen_vect_dealloc(g) - if(pm_opts%ftn_annotate) call out_simple(g,'!ENDBLOCK -> $N',n=g%lthis) - g%lthis=save_lthis - g%last_ve=save_last_ve - end subroutine gen_comm_block - - subroutine gen_mpi_recv_call(g,l,lnew,assn) - type(gen_state):: g - integer,intent(in):: l,lnew - logical,intent(in):: assn - integer:: a,save_lthis,ll,save_last_ve - a=l+comp_op_arg0 - !call out_line(g,'write(*,*) "RECV CALL"') - call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - call out_line(g,& - 'CALL MPI_PROBE(MPI_ANY_SOURCE,PM__REQ_TAG,JCOMM,PM__STAT,JERRNO)') - !call out_line(g,'write(*,*) "PROBED"') - call out_line(g,'JNODE=PM__STAT(MPI_SOURCE)') - call out_simple(g,'$2=JNODE',l) - save_last_ve=g%last_ve - g%last_ve=0 - g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_contig - call out_simple(g,'CALL MPI_RECV(N$N,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,MPI_STATUS_IGNORE,JERRNO)',n=g%lthis) - call gen_vect_alloc(g) - call gen_mpi_recv(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','RECV',mode_vect,.false.) - if(assn) then - call gen_mpi_recv(g,g%codes(a+5),'PM__EXTRA_REQ_TAG','RECV',mode_vect,.false.) - call out_line(g,'CALL PM__GET_SHARED_RANKS(WBUFFER%P,JNUMRANKS)') - call out_line(g,'DO JI=1,JNUMRANKS') - call out_line(g,'JNODE=WBUFFER%P(I)') - call gen_mpi_send(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','ISEND',mode_vect) - call gen_mpi_send(g,g%codes(a+5),'PM__EXTRA_REQ_TAG','ISEND',mode_vect) - call out_line(g,'ENDDO') - endif - !call out_line(g,'write(*,*) "RECVD CALL"') - ll=lnew - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - call gen_loop(g,l,.true.) - call gen_vect_dealloc(g) - g%lthis=save_lthis - g%last_ve=save_last_ve - end subroutine gen_mpi_recv_call - - !============================================================ - ! Generate for block of code that is shared/invariant - ! with respect to the current context - !============================================================ - subroutine gen_shared_block(g,l,lnew) - type(gen_state):: g - integer,intent(in):: l,lnew - integer:: save_lthis,ll,save_last_ve - call gen_loop(g,l,.true.) - save_last_ve=g%last_ve - g%last_ve=0 - g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_mode=loop_is_none - if(pm_opts%ftn_annotate) call out_simple(g,'! SHARED BLOCK -> $N',n=g%lthis) - ll=lnew - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - if(pm_opts%ftn_annotate) call out_simple(g,'!END SHARED BLOCK -> $N',n=g%lthis) - g%lthis=save_lthis - g%last_ve=save_last_ve - end subroutine gen_shared_block - - subroutine g_new_frame(g) - type(gen_state),intent(inout):: g - g%ltop=g%ltop+1 - g%lthis=g%ltop - g%lstack(g%lthis)%varlist=0 - g%lstack(g%lthis)%evarlist=0 - g%lstack(g%lthis)%defer_free=0 - g%lstack(g%lthis)%idx=0 - g%lstack(g%lthis)%free=0 - g%lstack(g%lthis)%loop_mode=loop_is_contig - g%lstack(g%lthis)%loop_active=.false. - end subroutine g_new_frame - - !============================================================ - ! If not in an active loop, generate required do loops - ! and masking statements - !============================================================ - subroutine gen_loop(g,l,isshared) - type(gen_state):: g - integer,intent(in):: l - logical,intent(in):: isshared - integer:: ve - logical:: shared - - ve=g%codes(l+comp_op_arg0) - shared=ve==shared_op_flag.or.isshared - if(shared) ve=0 - - ! Start up loops - if((.not.shared).and.(.not.g_loop_active(g))) then - call gen_loop_nest(g) - g%lstack(g%lthis)%loop_active=.true. - g%last_ve=0 - endif - - ! Close and re-open if statements - if(g%last_ve/=ve) then - call gen_if_nest(g,g%last_ve,ve) - g%last_ve=ve - endif - - ! Close down loops - if(shared.and.g_loop_active(g)) then - call gen_close_loops(g) - endif - - end subroutine gen_loop - - !========================================= - ! Are the loops for the current parallel - ! context running - !========================================= - function g_loop_active(g) result(ok) - type(gen_state):: g - logical:: ok - ok=g%lstack(g%lthis)%loop_active - end function g_loop_active - - !============================================================ - ! Generate loops spanning the current domain - !============================================================ - subroutine gen_loop_nest(g) - type(gen_state):: g - integer:: nloops - logical:: blocked - integer:: i,n - - if(g_loop_active(g)) return - - select case(g%lstack(g%lthis)%loop_mode) - case(loop_is_none) - return - case(loop_is_contig) - call out_str(g,'DO I') - call out_idx(g,g%lthis) - call out_str(g,'=1,N') - call out_idx(g,g%lthis) - call out_new_line(g) - nloops=1 - case(loop_is_nested) - call gen_nested_loop(g,g%lstack(g%lthis)%loop_par,nloops) - case default - call pm_panic('gen_loop_nest') - end select - g%lstack(g%lthis)%loop_active=.true. - g%lstack(g%lthis)%nloops=nloops - g%last_ve=0 - end subroutine gen_loop_nest - - - !============================================================ - ! Generate loops described by variable v - ! -- v is a grouped tuple ( vdesc , dimension_sizes , blocking ) - ! -- vdesc is a grouped tuple of vdim - ! -- each vdim is either a grouped tuple of sequence parameters - ! or an array - ! Returns number of loops opened in nloops - !============================================================ - subroutine gen_nested_loop(g,v,nloops) - type(gen_state):: g - integer,intent(in):: v - integer,intent(out):: nloops - integer:: i,ndim,vdesc,vdim,vblock,vsize - if(g_kind(g,v)/=v_is_group) call pm_panic('nested loop var not a group') - vdesc=g_ptr(g,v,1) - if(g_kind(g,v)/=v_is_group) call pm_panic('nested loop desc var not a group') - ndim=g_v1(g,vdesc) - nloops=0 - if(g_type(g,g_ptr(g,v,3))==pm_null) then - ! Non-blocked - do i=ndim,1,-1 - vdim=g_ptr(g,vdesc,i) - if(g_kind(g,vdim)==v_is_group) then - if(g_v2(g,vdim)==v_is_struct) then - select case(g_v1(g,vdim)) - case(1) - ! single point - call out_simple(g,'I$N_$M=$I+1',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - nloops=nloops+1 - case(2) - ! range - call out_simple_part(g,'DO I$N_$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_new_line(g) - nloops=nloops+1 - case(3) - ! strided range - call out_simple_part(g,'DO I$N_$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_char(g,',') - call out_arg(g,g_ptr(g,vdim,3),0) - call out_new_line(g) - nloops=nloops+1 - case(5) - ! blocked seq - call out_simple_part(g,'DO I$N__$M=($I)-',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_arg(g,g_ptr(g,vdim,5),0) - call out_str(g,',(') - call out_arg(g,g_ptr(g,vdim,2),0) - call out_str(g,'),') - call out_arg(g,g_ptr(g,vdim,3),0) - call out_new_line(g) - call out_simple_part(g,'DO I$N_$M=MAX($I,I$N__$M),',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_simple_part(g,'MIN(I$N__$M+($I)-1,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,4)) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_char(g,')') - call out_new_line(g) - nloops=nloops+2 - end select - else - call out_simple(g,'DO I$N__$M=1,SIZE($I)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_simple(g,'I$N_$M=$I(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - endif - else - call out_simple(g,'DO I$N__$M=1,SIZE($I%E1)',& - n=i,m=g%lthis,x=vdim) - call out_simple(g,'I$N_$M=$I%E1(I$N__$M)',& - n=i,m=g%lthis,x=vdim) - endif - enddo - elseif(g_v1(g,v)==3) then - ! Post blocking - vblock=g_ptr(g,v,3) - - ! Outer loop - do i=ndim,1,-1 - vdim=g_ptr(g,vdesc,i) - if(g_kind(g,vdim)==v_is_group) then - if(g_v2(g,vdim)==v_is_struct) then - select case(g_v1(g,vdim)) - case(1) - ! single point - call out_simple(g,'I$N_$M=$I+1',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - nloops=nloops+1 - case(2) - ! range - call out_simple_part(g,'DO I$N__$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_simple_part(g,',$I%E$N',x=vblock,n=i) - call out_new_line(g) - nloops=nloops+1 - case(3) - ! strided range - call out_simple_part(g,'DO I$N__$M=$I,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_char(g,',') - call out_arg(g,g_ptr(g,vdim,3),0) - call out_simple_part(g,'*$I%E$N',x=vblock,n=i) - call out_new_line(g) - nloops=nloops+1 - case(5) - ! blocked seq - call out_simple_part(g,'DO I$N__$M=$I-',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_arg(g,g_ptr(g,vdim,5),0) - call out_char(g,',') - call out_arg(g,g_ptr(g,vdim,2),0) - call out_char(g,',') - call out_arg(g,g_ptr(g,vdim,3),0) - call out_new_line(g) - call out_simple_part(g,'IMAX$N__$M=MIN(I$N__$M+$I-1,',& - n=i,m=g%lthis,x=g_ptr(g,vdim,4)) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_line(g,')') - call out_simple_part(g,'DO I$N_$M=MAX($I,I$N__$M),IMAX$N__$M',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_simple(g,',$I%E$N',x=vblock,n=i) - nloops=nloops+2 - end select - else - ! Arrays (split) - call out_simple_part(g,'DO I$N___$M=1,SIZE($I),',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - call out_simple(g,',$I%E$N',x=vblock,n=i) - endif - else - ! Array - call out_simple_part(g,'DO I$N___$M=1,SIZE($I%E1),',& - n=i,m=g%lthis,x=vdim) - call out_simple(g,',$I%E$N',x=vblock,n=i) - endif - enddo - - ! Loop over block - do i=ndim,1,-1 - vdim=g_ptr(g,vdesc,i) - if(g_kind(g,vdim)==v_is_group) then - if(g_v2(g,vdim)==v_is_struct) then - select case(g_v1(g,vdim)) - case(1) - ! single point - continue - case(2) - ! range - call out_simple_part(g,'DO I$N_$M=I$N__$M,MIN(I$N__$M-1+$I%E$N,',& - n=i,m=g%lthis,x=vblock) - call out_arg(g,g_ptr(g,vdim,2),0) - call out_char(g,')') - call out_new_line(g) - nloops=nloops+1 - case(3) - ! strided range - call out_simple_part(g,'DO I$N_$M=I$N__$M,MIN(I$N__$M-1+$I%E$N*',& - n=i,m=g%lthis,x=vblock) - call out_arg(g,g_ptr(g,vdim,3),0) - call out_char(g,',') - call out_arg(g,g_ptr(g,vdim,2),0) - call out_str(g,'),') - call out_arg(g,g_ptr(g,vdim,3),0) - call out_new_line(g) - nloops=nloops+1 - case(5) - ! blocked seq - call out_simple(g,'DO I$N_$M=I$N__$M,MIN(IMAX$N__$M,I$N__$M+$I%E$N)',& - n=i,m=g%lthis,x=vblock) - nloops=nloops+1 - end select - else - ! Array (split) - call out_simple_part(g,'DO I$N__$M=I$N__$M,MIN(I$N__$M-1+$I%E$N,SIZE(',& - n=i,m=g%lthis,x=vblock) - call out_arg(g,g_ptr(g,vdim,1),0) - call out_line(g,'))') - call out_simple(g,'I$N_$M=$I(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - endif - else - ! Array - call out_simple_part(g,'DO I$N__$M=I$N__$M,MIN(I$N__$M-1+$I%E$N,SIZE(',& - n=i,m=g%lthis,x=vblock) - call out_arg(g,g_ptr(g,vdim,1),0) - call out_line(g,'%E1))') - call out_simple(g,'I$N_$M=$I%E1(I$N__$M)',& - n=i,m=g%lthis,x=g_ptr(g,vdim,1)) - endif - enddo - else - if(g_kind(g,v)==v_is_storageless) then - return - else - call pm_panic('Bad nested loop descriptor') - endif - endif - - ! Calculate combined index - vsize=g_ptr(g,v,2) - call out_char_idx(g,'I',g%lthis) - call out_str(g,'=1+') - call out_char_idx(g,'I',1) - call out_char_idx(g,'_',g%lthis) - do i=2,ndim - call out_char(g,'+') - call out_arg(g,g_ptr(g,vsize,i-1),0) - call out_str(g,'*(I') - call out_idx(g,i) - call out_char_idx(g,'_',g%lthis) - enddo - do i=2,ndim - call out_char(g,')') - enddo - call out_new_line(g) - - end subroutine gen_nested_loop - - - !============================================================ - ! Close all active loops - !============================================================ - subroutine gen_close_loops(g) - type(gen_state):: g - integer:: i - if(g_loop_active(g)) then - do i=1,g%lstack(g%lthis)%nloops - call out_line(g,'ENDDO') - enddo - g%lstack(g%lthis)%loop_active=.false. - g%lstack(g%lthis)%nloops=0 - endif - end subroutine gen_close_loops - - !============================================================ - ! Generate nested if statements to - ! apply masking - !============================================================ - subroutine gen_if_nest(g,ve1,ve2) - type(gen_state):: g - integer,intent(in):: ve1,ve2 - integer,dimension(max_par_depth*2)::stack - integer:: start1,end1 - integer:: start2,end2 - integer:: top,i,vevar - logical:: have_else,cove - top=0 - have_else=.false. - if(ve1>0.and.ve2>0) then - call stack_all(ve1,top,start1,end1) - call stack_all(ve2,top,start2,end2) - do while(stack(end1)==stack(end2)) - end1=end1-1 - end2=end2-1 - if(end1<1.or.end2<1) exit - enddo - if(end1>0.and.end2>0) then - if(g_v2(g,stack(end1))==stack(end2)) then - cove=g_kind(g,stack(end1))==v_is_cove - vevar=stack(merge(end2,end1,cove)) - have_else=g_gflags_clear(g,vevar,var_is_else_disabled) - if(have_else) then - call g_set_gflags(g,vevar,var_is_else_disabled) - else - call g_clear_gflags(g,vevar,var_is_else_disabled) - endif - endif - if(have_else) then - end1=end1-1 - end2=end2-1 - endif - endif - else - if(ve1>0) then - call stack_all(ve1,top,start1,end1) - else - start1=2 - end1=1 - endif - if(ve2>0) then - call stack_all(ve2,top,start2,end2) - else - start2=2 - end2=1 - endif - endif - do i=start1,end1 - call out_line(g,'ENDIF') - enddo - if(have_else) then - call out_line(g,'ELSE') - endif - do i=end2,start2,-1 - call out_str(g,'IF(') - if(g_kind(g,stack(i))==v_is_cove) then - call out_str(g,'.NOT.(') - call out_arg(g,stack(i),0) - call out_char(g,')') - call g_clear_gflags(g,g_v2(g,stack(i)),var_is_else_disabled) - else - call out_arg(g,stack(i),0) - call g_clear_gflags(g,stack(i),var_is_else_disabled) - endif - call out_line(g,') THEN') - enddo - contains - - subroutine stack_all(ve,top,istart,iend) - integer,intent(in):: ve - integer,intent(inout):: top - integer,intent(out):: istart,iend - integer:: parent - call push(top,ve) - istart=top - parent=g_v1(g,ve) - do while(parent/=0) - call push(top,parent) - parent=g_v1(g,parent) - enddo - iend=top - end subroutine stack_all - - subroutine push(top,ve) - integer,intent(inout):: top - integer,intent(in):: ve - top=top+1 - if(top>max_par_depth*2) & - call pm_panic('Program too complex (nested if)') - stack(top)=ve - end subroutine push - - end subroutine gen_if_nest - - !============================================================ - ! Close currently open ifs in this par scope - !============================================================ - subroutine gen_close_ifs(g,last) - type(gen_state):: g - integer,intent(in):: last - integer:: i - - i=g%last_ve - !write(*,*) 'LAST>>',i,last,g%last_ve - do while(i/=last.and.i/=0) - if(debug_g) write(*,*) 'FINISH>',i,g_kind(g,i),g_v1(g,i),g_v2(g,i) - i=g_v1(g,i) - call out_line(g,'ENDIF') - enddo - g%last_ve=0 - end subroutine gen_close_ifs - - !============================================================ - ! Generate code for IF( any active strand ) THEN - !============================================================ - subroutine gen_active_check_start(g,l) - type(gen_state):: g - integer,intent(in):: l - integer:: ve - ve=g%codes(l+comp_op_arg0) - call gen_stacked_ve(g,l,ve) - call gen_loop(g,l,.true.) - if(ve/=0.and.ve/=shared_op_flag) then - if(g_is_a_vect(g,ve)) then - call out_simple(g,'IF(ANY($A))THEN',x=ve) - else - call out_simple(g,'IF($A)THEN',x=ve) - endif - endif - end subroutine gen_active_check_start - - !============================================================ - ! Generate code to close IF( any active strand ) THEN - !============================================================ - subroutine gen_active_check_end(g,l) - type(gen_state):: g - integer,intent(in):: l - integer:: ve - ve=g%codes(l+comp_op_arg0) - if(ve/=0.and.ve/=shared_op_flag) then - call out_line(g,'ENDIF !active check') - endif - end subroutine gen_active_check_end - - !============================================================ - ! Generate code to combine stacked masks (ve) - ! into single logical vector with all elements - ! fully defined (nested ve only have valid - ! values only for strands that were active - ! when they were created) - ! - ! - Assigned to vout if present - ! - Otherwise change in place if necessary - !============================================================ - subroutine gen_stacked_ve(g,l,v,vout) - type(gen_state):: g - integer,intent(in):: l,v - integer,intent(in),optional:: vout - integer:: parent,arg_flags - logical:: stacked_already - if(v==shared_op_flag) return - if(v==0) then - if(present(vout)) then - if(g_loop_active(g)) then - call out_arg(g,vout,0) - else - call out_arg(g,vout,arg_no_index) - endif - call out_line(g,'=.TRUE.') - endif - return - else - parent=g_v1(g,v) - if(parent==0.and..not.present(vout)) return - endif - stacked_already=g_gflags_set(g,v,var_is_stacked_ve) - if(stacked_already.and..not.present(vout)) return - if(g_loop_active(g)) then - call gen_close_ifs(g,0) - arg_flags=0 - else - arg_flags=arg_no_index - endif - if(present(vout)) then - call out_arg(g,vout,arg_flags) - else - call out_arg(g,v,arg_flags) - endif - call out_char(g,'=') - call out_arg(g,v,arg_flags) - if(.not.stacked_already) then - do while(parent/=0) - call out_str(g,'.AND.') - call out_arg(g,parent,arg_flags) - parent=g_v1(g,parent) - end do - endif - call out_str(g,' ! Stacked ve') - call out_new_line(g) - call g_set_gflags(g,v,var_is_stacked_ve) - end subroutine gen_stacked_ve - - !============================================================ - ! Generate code to allocate a vector variable - !============================================================ - subroutine gen_vect_alloc(g) - type(gen_state):: g - integer:: v - v=g%lstack(g%lthis)%varlist - do while(v>0) - if(g_var_at_index_is_a_vect(g,v).and.& - iand(g%vardata(v)%flags,v_is_result)==0.and.& - iand(g%vardata(v)%gflags,var_is_recycled)==0) then - call out_str(g,'IF(ALLOCATED(') - call out_var_at_index(g,v) - if(iand(g%vardata(v)%flags,v_is_chan)/=0) then - call out_str(g,'%P') - endif - call out_str(g,')) DEALLOCATE(') - call out_var_at_index(g,v) - if(iand(g%vardata(v)%flags,v_is_chan)/=0) then - call out_str(g,'%P') - endif - call out_line(g,')') - call out_str(g,'ALLOCATE(') - call out_var_at_index(g,v) - if(iand(g%vardata(v)%flags,v_is_chan)/=0) then - call out_str(g,'%P') - endif - call out_str(g,'(N') - call out_idx(g,g%lthis) - if(iand(g%vardata(v)%flags,v_is_ve+v_is_cove)/=0) then - call out_str(g,'),SOURCE=.FALSE.)') - else - call out_line(g,'))') - endif - endif - v=g%vardata(v)%link - enddo - end subroutine gen_vect_alloc - - !============================================================ - ! Generate code to deallocate a vector variable - !============================================================ - subroutine gen_vect_dealloc(g) - type(gen_state):: g - integer:: v,outer - v=g%lstack(g%lthis)%varlist - do while(v>0) - if(g_var_at_index_is_a_vect(g,v).and.& - iand(g%vardata(v)%gflags,var_is_recycled)==0) then - outer=g%vardata(v)%outer_lthis - if(outer/=g%vardata(v)%lthis) then - g%vardata(v)%elink=g%lstack(outer)%defer_free - g%lstack(outer)%defer_free=v - else - call out_str(g,'DEALLOCATE(') - call out_var_at_index(g,v) - if(iand(g%vardata(v)%flags,v_is_chan)/=0) then - call out_str(g,'%P') - endif - call out_line(g,')') - endif - endif - v=g%vardata(v)%link - enddo - v=g%lstack(g%lthis)%defer_free - do while(v>0) - call out_str(g,'DEALLOCATE(') - call out_var_at_index(g,v) - if(iand(g%vardata(v)%flags,v_is_chan)/=0) then - call out_str(g,'%P') - endif - call out_line(g,')') - v=g%vardata(v)%elink - enddo - end subroutine gen_vect_dealloc - - - !************************************************************* - ! COMMUNICATION INSTRINSICS - !************************************************************* - - !============================================================ - ! Send messages to multiple other nodes and service - ! Coordinate using non-blocking barrier - ! Arg list: ve block internal-block new-p new-v new-w v w p i - !============================================================ - subroutine gen_mpi_remote_call(g,l,issend) - type(gen_state):: g - integer,intent(in):: l - logical,intent(in):: issend - integer:: a,ve,v,lthis - a=l+comp_op_arg0 - ve=g%codes(a) - call out_line(g,'PM__REQUEST=3-PM__REQUEST') - call out_simple(g,'I$N=1',n=g%lthis) - if(.not.issend) then - v=g%codes(a+6) - endif - call out_line(g,'NNODE=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NNODE') - call out_line(g,'JTHIS_NODE=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE') - call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - if(ve==0) then - call out_simple(g,'NTOT=SIZE($#7,KIND=PM__LN)',l) - else - call out_simple(g,'NTOT=COUNT($#0)',l) - endif - call out_line(g,'IF(NTOT.GT.0) THEN') - call out_line(g,'ALLOCATE(RSTART%P(0:NNODE))') - call out_line(g,'NXSIZE=MIN(PM__EXCHANGE_BLOCK,NTOT)') - call out_line(g,'ALLOCATE(RFROM%P(NXSIZE))') - if(ve/=0) call out_line(g,'IBG=1') - call out_line(g,'DO ISTART=1,NTOT,PM__EXCHANGE_BLOCK') - call out_line(g,'IFINISH=MIN(ISTART+PM__EXCHANGE_BLOCK-1,NTOT)') - call out_line(g,'NTRANS=IFINISH-ISTART+1') - call out_line(g,'RSTART%P(NNODE)=NTRANS+1') - if(ve==0) then - call out_simple(g,'CALL PM__COLLATE_MESSAGES($#7,ISTART,NTRANS,NNODE,RSTART%P,RFROM%P)',l) - else - call out_simple(g,'CALL PM__COLLATE_MESSAGES_MASKED($#7,COUNT($#0,KIND=PM__LN),NNODE,RSTART%P,RFROM%P,$#0,IBG)',l) - endif - call out_line(g,'CALL MPI_IRECV(QRBUFFER%P,1,MPI_AINT,MPI_ANY_SOURCE,PM__REQUEST,'//& - 'JCOMM,JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - call out_line(g,'DO JNODEBLK=0,NNODE-1,PM__NODE_BLOCK') - call out_line(g,'DO JNODE=JNODEBLK,MIN(JNODEBLK+PM__NODE_BLOCK,NNODE-1)') - call out_line(g,'IF(JNODE.EQ.JTHIS_NODE.OR.RSTART%P(JNODE).EQ.RSTART%P(JNODE+1)) CYCLE') - if(issend) then - call gen_mpi_send_part(g,g%codes(a+8),'PM__EXTRA_REQ_TAG','ISEND','RFROM%P',& - 'RSTART%P(JNODE)','RSTART%P(JNODE+1)-1',mode_vect) - else - call gen_mpi_recv_part(g,g%codes(a+5),'PM__DATA_TAG','IRECV',.false.,'RFROM%P',& - 'RSTART%P(JNODE)','RSTART%P(JNODE+1)-1',mode_vect) - endif - call gen_mpi_send_part(g,g%codes(a+6),'PM__EXTRA_REQ_TAG','ISEND','RFROM%P','RSTART%P(JNODE)',& - 'RSTART%P(JNODE+1)-1',mode_vect) - call out_line(g,'ENDDO') - call out_line(g,'ALLOCATE(RSBUFFER%P(JNODEBLK:MIN(JNODEBLK+PM__NODE_BLOCK,NNODE-1)))') - call out_line(g,'DO JNODE=JNODEBLK,MIN(JNODEBLK+PM__NODE_BLOCK,NNODE-1)') - call out_line(g,'IF(JNODE.EQ.JTHIS_NODE.OR.RSTART%P(JNODE).EQ.RSTART%P(JNODE+1)) CYCLE') - call out_line(g,'RSBUFFER%P(JNODE)=RSTART%P(JNODE+1)-RSTART%P(JNODE)') - call out_line(g,'CALL MPI_ISSEND(RSBUFFER%P(JNODE),1,MPI_AINT,JNODE,PM__REQUEST,JCOMM,'//& - 'JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - call out_line(g,'ENDDO') - - call gen_internal_server_block(g,l,'RFROM%P(IX)+1','RSTART%P(JTHIS_NODE)','RSTART%P(JTHIS_NODE+1)-1') - - call out_line(g,'JCOMPLETE=0') - call out_line(g,'DO WHILE(JCOMPLETE.LT.PM__MESSAGE_TOP-1)') - call out_line(g,'CALL MPI_WAITANY(PM__MESSAGE_TOP,PM__MESSAGE_STACK,JRQ,PM__STAT,JERRNO)') - call out_line(g,'IF(JRQ.EQ.1)THEN') - lthis=-1 - call gen_server_block(g,l,issend,1,lthis) - call out_line(g,'ELSE') - call out_line(g,'JCOMPLETE=JCOMPLETE+1') - call out_line(g,'IF(JCOMPLETE.LT.PM__MESSAGE_TOP)THEN') - call out_line(g,'PM__MESSAGE_STACK(JRQ)=MPI_MESSAGE_NULL') - call out_line(g,'ELSE') - call out_line(g,'EXIT') - call out_line(g,'ENDIF') - call out_line(g,'ENDIF') - call out_line(g,'ENDDO') - if(.not.issend) then - call out_line(g,'DO JNODE=JNODEBLK,MIN(JNODEBLK+PM__NODE_BLOCK,NNODE-1)') - call out_line(g,'IF(JNODE.EQ.JTHIS_NODE.OR.RSTART%P(JNODE).EQ.RSTART%P(JNODE+1)) CYCLE') - call gen_mpi_recv_part(g,g%codes(a+5),& - 'PM__DATA_TAG','RECV',.true.,'RFROM%P','RSTART%P(JNODE)','RSTART%P(JNODE+1)-1',& - mode_vect) - call out_line(g,'ENDDO') - endif - call out_line(g,'JMESS=PM__MESSAGE_STACK(1)') - call out_line(g,'DEALLOCATE(RSBUFFER%P)') - call out_line(g,'CALL PM__TIDY_MESSAGES()') - call out_line(g,'ENDDO') - call out_line(g,'ENDDO') - call out_line(g,'ELSE') - call out_line(g,'CALL MPI_IRECV(QRBUFFER%P,1,MPI_AINT,MPI_ANY_SOURCE,PM__REQUEST,'//& - 'JCOMM,JMESS,JERRNO)') - call out_line(g,'ENDIF') - call out_line(g,'IF(NTOT.GT.0) DEALLOCATE(RSTART%P,RFROM%P)') - - call out_line(g,'PM__MESSAGE_STACK(1)=JMESS') - call out_line(g,'CALL MPI_IBARRIER(JCOMM,PM__MESSAGE_STACK(2),JERRNO)') - call out_line(g,'PM__MESSAGE_TOP=2') - call out_line(g,'JCOMPLETE=0') - call out_line(g,'DO') - call out_line(g,'CALL MPI_WAITANY(PM__MESSAGE_TOP,PM__MESSAGE_STACK,JRQ,PM__STAT,JERRNO)') - call out_line(g,'IF(JRQ==1)THEN') - call gen_server_block(g,l,issend,1,lthis) - call out_line(g,'ELSE') - call out_line(g,'IF(JRQ.EQ.2)THEN') - call out_line(g,'CALL MPI_CANCEL(PM__MESSAGE_STACK(1),JERRNO)') - call out_line(g,'CALL MPI_WAIT(PM__MESSAGE_STACK(1),PM__STAT,JERRNO)') - call out_line(g,'IF(PM__MESSAGE_TOP.EQ.2)EXIT') - call out_line(g,'ENDIF') - call out_line(g,'JCOMPLETE=JCOMPLETE+1') - call out_line(g,'PM__MESSAGE_STACK(JRQ)=MPI_MESSAGE_NULL') - call out_line(g,'IF(JCOMPLETE.GE.PM__MESSAGE_TOP-1)EXIT') - call out_line(g,'ENDIF') - call out_line(g,'ENDDO') - call out_line(g,'CALL PM__TIDY_MESSAGES()') - - end subroutine gen_mpi_remote_call - - ! ============================================================= - ! Send messages to single (shared- known) node and service - ! Arg list: ve block internal-block new-v new-w v w p i - ! ========================================================== - subroutine gen_mpi_collect_call(g,l,issend) - type(gen_state):: g - integer,intent(in):: l - logical,intent(in):: issend - integer:: a,ve,v,lthis - a=l+comp_op_arg0 - ve=g%codes(a) - if(.not.issend) then - v=g%codes(a+6) - endif - if(ve==0) then - call out_simple(g,'NTOT=N$N',l,n=g%lthis) - else - call out_simple(g,'NTOT=COUNT($#0)',l) - endif - call out_line(g,'NNODE=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NNODE') - call out_line(g,'JTHIS_NODE=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE') - call out_line(g,'JROOT_NODE=PM__NODE_FRAME(PM__NODE_DEPTH)%ROOT_NODE') - call out_line(g,'JCOMM=PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - call out_simple(g,'JNODE=$7',l) - call out_line(g,'IF(JNODE.NE.JROOT_NODE)THEN') - if(ve>0) call out_simple(g,'RFROM%P=PM__ACTIVE_CELLS($A)',x=ve) - call out_line(g,'QXBUFFER%P(1)=PM__EXCHANGE_BLOCK') - call out_line(g,'DO IXBLK=0,NTOT-1,PM__EXCHANGE_BLOCK') - call out_line(g,'NXSIZE=MIN(PM__EXCHANGE_BLOCK,NTOT-IXBLK)') - if(ve>0) then - if(issend) then - call gen_mpi_send_part(g,g%codes(a+8),& - 'PM__EXTRA_REQ_TAG','ISEND','RFROM%P','IXBLK','IXBLK+NXSIZE-1',mode_vect) - else - call gen_mpi_recv_part(g,g%codes(a+5),& - 'PM__EXTRA_REQ_TAG','IRECV',.false.,'RFROM%P','IXBLK','IXBLK+NXSIZE-1',mode_vect) - endif - call gen_mpi_send_part(g,g%codes(a+6),& - 'PM__EXTRA_REQ_TAG','ISEND','RFROM%P','IXBLK','IXBLK+NXSIZE-1',mode_vect) - else - if(issend) then - call gen_mpi_send(g,g%codes(a+8),& - 'PM__EXTRA_REQ_TAG','ISEND',mode_vect) - else - call gen_mpi_recv(g,g%codes(a+5),& - 'PM__EXTRA_REQ_TAG','IRECV',mode_vect,.false.) - endif - call gen_mpi_send(g,g%codes(a+6),& - 'PM__EXTRA_REQ_TAG','ISEND',mode_vect) - endif - call out_line(g,'IF(NXSIZE.EQ.NTOT-IXBLK)THEN') - call out_line(g,'QSBUFFER%P(1)=-NXSIZE') - call out_simple(g,'CALL MPI_ISEND(QSBUFFER%P,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)',l) - call out_line(g,'ELSE') - call out_simple(g,'CALL MPI_ISEND(QXBUFFER%P,1,MPI_AINT,JNODE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)',l) - call out_line(g,'ENDIF') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - if(.not.issend) then - if(ve>0) then - call gen_mpi_recv_part(g,g%codes(a+6),& - 'PM__DATA_TAG','RECV',.true.,'RFROM%P','IX','IX+NXSIZE-1',0) - else - call gen_mpi_recv(g,g%codes(a+5),& - 'PM__EXTRA_REQ_TAG','IRECV',mode_vect,.true.) - endif - endif - call out_line(g,'CALL PM__COMPLETE_MESSAGES') - call out_line(g,'ENDDO') - call out_line(g,'ELSE') - call out_line(g,'IF(NNODE.GT.1) THEN') - call out_line(g,& - 'CALL MPI_IRECV(QRBUFFER%P,1,MPI_AINT,MPI_ANY_SOURCE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - call out_line(g,'ENDIF') - if(ve>0) then - call gen_internal_server_block(g,l,'RFROM%P(IX)','1','SIZE(RFROM%P)') - else - call gen_internal_server_block(g,l,'IX','1','NTOT') - endif - - call out_line(g,'JCOMPLETE=0') - call out_line(g,'DO WHILE(JCOMPLETE.LT.NNODE-1)') - call out_line(g,'CALL MPI_WAITANY(PM__MESSAGE_TOP,PM__MESSAGE_STACK,JRQ,PM__STAT,JERRNO)') - call out_line(g,'IF(JRQ.EQ.1)THEN') - call out_line(g,'JNODE=PM__STAT(MPI_SOURCE)') - call out_line(g,'NSIZE=QRBUFFER%P(1)') - call out_line(g,'IF(NSIZE.LT.0)THEN') - call out_line(g,'NSIZE=-NSIZE') - call out_line(g,'JCOMPLETE=JCOMPLETE+1') - call out_line(g,'ENDIF') - lthis=-1 - call gen_server_block(g,l,issend,1,lthis) - - call out_line(g,'IF(JCOMPLETE.EQ.NNODE-1)EXIT') - call out_line(g,& - 'CALL MPI_IRECV(QRBUFFER%P,1,MPI_AINT,MPI_ANY_SOURCE,PM__REQ_TAG,JCOMM,JMESS,JERRNO)') - call out_line(g,'PM__MESSAGE_STACK(1)=JMESS') - call out_line(g,'ENDIF') - call out_line(g,'ENDDO') - - call out_line(g,'CALL PM__TIDY_MESSAGES()') - - call out_line(g,'ENDIF') - - end subroutine gen_mpi_collect_call - - !============================================================ - ! Code service of inter-node message - ! Arg list: ve block [ internal-block ] new-v new-w v w p i - ! [ internal-block ] present if extra_arg=1 (instead of 0) - !============================================================ - subroutine gen_server_block(g,l,issend,extra_arg,lthis) - type(gen_state):: g - integer,intent(in):: l,extra_arg - logical,intent(in):: issend - integer,intent(inout):: lthis - integer:: a,save_lthis,save_last_ve,ll - - a=l+comp_op_arg0+extra_arg - save_lthis=g%lthis - if(lthis<0) then - g%ltop=g%ltop+1 - g%lthis=g%ltop - lthis=g%lthis - else - g%lthis=lthis - endif - g%lstack(g%lthis)%nloops=1 - save_last_ve=g%last_ve - g%last_ve=0 - - if(pm_opts%ftn_annotate) then - call out_simple(g,'! BLOCK $N (server)',n=g%lthis) - endif - - call out_simple(g,'N$N=ABS(QRBUFFER%P(1))',n=g%lthis) - call out_line(g,'NA0=1') - - call gen_vect_alloc(g) - - call out_line(g,'JNODE=PM__STAT(MPI_SOURCE)') - if(issend) then - call gen_mpi_recv(g,g%codes(a+4),'PM__EXTRA_REQ_TAG','RECV',mode_vect,.false.) - endif - call gen_mpi_recv(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','RECV',mode_vect,.false.) - - if(issend) then - call out_line(g,& - 'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%IS_SHARED.AND.JTHIS_NODE.EQ.JROOT_NODE)THEN') - call out_line(g,'DO JNODE2=1,PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NNODE-1') - call out_line(g,'JNODE=PM__GET_SHARED(JNODE2)') - call gen_mpi_send(g,g%codes(a+3),'PM__EXTRA_REQ_TAG','ISEND',mode_vect) - call gen_mpi_send(g,g%codes(a+4),'PM__EXTRA_REQ_TAG','ISEND',mode_vect) - call out_line(g,'ENDDO') - call out_line(g,'ENDIF') - endif - - call out_simple(g,'DO I$N=1,N$N ! Start of server block',n=g%lthis) - g%lstack(g%lthis)%loop_active=.true. - ll=g%codes(a+1-extra_arg) - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - call gen_if_nest(g,g%last_ve,0) - - call out_line(g,'ENDDO !End of server block') - g%lstack(g%lthis)%loop_active=.false. - g%last_ve=0 - - if(.not.issend) then - call gen_mpi_send(g,g%codes(a+7),'PM__DATA_TAG','RSEND',mode_vect) - endif - - call gen_vect_dealloc(g) - - g%last_ve=save_last_ve - g%lthis=save_lthis - - call out_line(g,'CALL MPI_IRECV(QRBUFFER%P,1,MPI_AINT,MPI_ANY_SOURCE,PM__REQUEST,'//& - 'JCOMM,JMESS,JERRNO)') - call out_line(g,'PM__MESSAGE_STACK(1)=JMESS') - - if(pm_opts%ftn_annotate) then - call out_simple(g,'! END BLOCK $N (server)',n=g%lthis) - endif - end subroutine gen_server_block - - !============================================================ - ! Code to run block servicing intra-node messages - ! Arg list: ve block internal-block new-v new-w v w p i - ! Assumes aliasing of arguments: - ! new-v <-> v - ! new-w <-> w - !============================================================ - subroutine gen_internal_server_block(g,l,vd,vs,ve) - type(gen_state):: g - integer,intent(in):: l - character(len=*),intent(in):: vd,vs,ve - integer:: ll,a - a=l+comp_op_arg0 - call out_line(g,'DO IX='//vs//','//ve) - call out_char_idx(g,'I',g%lthis) - call out_char(g,'=') - call out_line(g,vd) - g%lstack(g%lthis)%nloops=1 - g%lstack(g%lthis)%loop_active=.true. - ll=g%codes(a+2) - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - call out_line(g,'ENDDO') - g%lstack(g%lthis)%nloops=0 - g%lstack(g%lthis)%loop_active=.false. - g%last_ve=0 - end subroutine gen_internal_server_block - - !============================================================ - ! Broadcast message to all nodes in group and service - ! Arg list: ve block new-v new-w v w p i - !============================================================ - subroutine gen_mpi_bcast_call(g,l) - type(gen_state),intent(inout):: g - integer,intent(in):: l - integer:: a,ll,save_lthis,save_last_ve - a=l+comp_op_arg0 - call out_simple(g,'I$N=1',n=g%lthis) - call out_simple(g,'JNODE=$6',l) - call out_simple(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) NA=N$N',n=g%lthis) - call out_line(g,'CALL MPI_BCAST(NA,1,MPI_AINT,JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') - - g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - save_last_ve=g%last_ve - g%last_ve=0 - - call out_simple(g,'N$N=NA',n=g%lthis) - call out_line(g,'NA0=1') - - call gen_vect_alloc(g) - - call gen_pack(g,g%codes(a+2),g%codes(a+4),0) - call gen_pack(g,g%codes(a+3),g%codes(a+5),0) - - - call gen_mpi_bcast(g,g%codes(a+2)) - call gen_mpi_bcast(g,g%codes(a+3)) - - ll=g%codes(a+1) - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - - call gen_loop(g,l,.true.) - - call gen_vect_dealloc(g) - - g%last_ve=save_last_ve - g%lthis=save_lthis - - end subroutine gen_mpi_bcast_call - - !============================================================================ - ! Broadcast message to all nodes in group and service (conditional context) - ! Arg list: ve block new-v new-w v w p i - !============================================================================ - subroutine gen_mpi_masked_bcast_call(g,l) - type(gen_state),intent(inout):: g - integer,intent(in):: l - integer:: a,ll,save_lthis,save_last_ve - a=l+comp_op_arg0 - call out_simple(g,'I$N=1',n=g%lthis) - call out_simple(g,'JNODE=$6',l) - call out_simple(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) NA=COUNT($#0)',l) - call out_line(g,'CALL MPI_BCAST(NA,1,MPI_AINT,JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') - - g%ltop=g%ltop+1 - save_lthis=g%lthis - g%lthis=g%ltop - g%lstack(g%lthis)%nloops=0 - save_last_ve=g%last_ve - g%last_ve=0 - - call out_simple(g,'N$N=NA',n=g%lthis) - - call gen_vect_alloc(g) - - call out_line(g,'IF(NA.GT.0) THEN') - - call out_simple(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE)THEN') - call gen_pack(g,g%codes(a+2),g%codes(a+4),g%codes(a)) - call gen_pack(g,g%codes(a+3),g%codes(a+5),g%codes(a)) - call out_line(g,'ENDIF') - - call gen_mpi_bcast(g,g%codes(a+2)) - call gen_mpi_bcast(g,g%codes(a+3)) - - ll=g%codes(a+1) - do while(ll>0) - call gen_op(g,ll) - ll=g%codes(ll) - enddo - - call gen_loop(g,l,.true.) - - call out_line(g,'ENDIF') - - call gen_vect_dealloc(g) - - g%last_ve=save_last_ve - g%lthis=save_lthis - - end subroutine gen_mpi_masked_bcast_call - - !============================================================ - ! Code mpi_send, mpi_isend, mpi_issend ... - ! node must be in JNODE - !============================================================ - recursive subroutine gen_mpi_send(g,v,tag,s,mode,comm) - type(gen_state):: g - integer,intent(in):: v - integer,intent(in):: mode - character(len=*),intent(in):: tag,s - character(len=*),intent(in),optional:: comm - integer:: k,k2,i,tno,a - logical:: nonblocking - character(len=5):: ibuffer - type(pm_ptr):: tv - !call out_simple(g,'WRITE(*,*) "SEND",$N',n=abs(v)) - nonblocking=s=='ISEND'.or.s=='ISSEND' - k=g_kind(g,v) - k2=g_v2(g,v) - select case(k) - case(v_is_group) - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - i=g_ptr(g,v,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_mpi_send(g,i,tag,s,mode_vect) - endif - if(k2/=v_is_shared_dref) then - call gen_mpi_send(g,g_ptr(g,v,3),tag,s,mode_vect) - endif - elseif(k2==v_is_storageless) then - continue - elseif(k2==v_is_array) then - if(mode==mode_array) then - call gen_mpi_send(g,g_ptr(g,v,1),tag,s,mode_array_vect) - else - ! Split array view - tno=g_type(g,v) - call g_add_packable(g,pack_array_vect,tno) - call out_simple_part(g,'CALL PM__PACKAVEC$N(NA,$A,',& - n=tno,x=g_ptr(g,v,1)) - call out_arg(g,g_ptr(g,v,2),arg_no_index) - call out_line(g,')') - call send_buffer - endif - else - ! Structures/records - do i=1,g_v1(g,v) - call gen_mpi_send(g,g_ptr(g,v,i),tag,s,mode) - enddo - endif - case(v_is_basic,v_is_elem,v_is_unit_elem,v_is_sub,v_is_vsub,& - v_is_const,v_is_ctime_const) - call out_str(g,'NA=SIZE(') - call out_comm_var(g,v,mode) - call out_line(g,')') - tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) - if(g_is_complex_type(g,tno)) then - call g_add_packable(g,pack_vect,tno) - call out_simple_part(g,'CALL PM__PACKVEC$N(NA,',n=tno) - call out_comm_var(g,v,mode) - call out_line(g,')') - call send_buffer - else - call out_get_mpi_base_type(g,tno) - call out_line(g,'CALL PM__GET_MPI_TYPE(JBASE,NA,JTYPE,JN,LNEW)') - call out_str(g,'CALL MPI_'//s//'(') - call out_comm_var(g,v,mode) - if(nonblocking) then - call out_str(g,',JN,JTYPE,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - call out_str(g,',JN,JTYPE,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',JERRNO)') - endif - call out_line(g,'IF(LNEW) CALL MPI_TYPE_FREE(JTYPE,JERRNO)') - endif - case(v_is_alias,v_is_chan_vect,v_is_vect_wrapped) - call gen_mpi_send(g,g_v1(g,v),tag,s,merge(mode_vect,mode,k==v_is_chan_vect),comm) - case default - write(*,*) 'v=',v,'k=',k - call pm_panic('Problem var in gen_mpi_send') - end select - contains - subroutine send_buffer - if(s=='RSEND') then - call out_str(g,'CALL PM__ISEND_BUFFER(JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,')') - call out_str(g,'CALL MPI_RSEND(J,0,MPI_INTEGER,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',JERROR)') - else - call out_line(g,'CALL PM__'//s//'_BUFFER(JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,')') - if(nonblocking) then - call out_str(g,'CALL MPI_'//s//'(J,0,MPI_INTEGER,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - call out_str(g,'CALL MPI_'//s//'(J,0,MPI_INTEGER,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,')') - endif - endif - end subroutine send_buffer - end subroutine gen_mpi_send - - !============================================================ - ! Output vector component of variable v - mode governs - ! whether this is grouped array - !============================================================ - subroutine out_comm_var(g,v,mode) - type(gen_state):: g - integer,intent(in):: v - integer,intent(in):: mode - !write(*,*) 'v is ',v,g_kind(g,v) - !write(*,*) 'SENDING OUT COMM',mode,g%lthis,g_lthis(g,v) - call out_arg(g,v,merge(0,arg_no_index,mode==mode_array)) - if(mode==mode_array) then - call out_str(g,'%E1%P') - elseif(mode==mode_array_vect) then - call out_str(g,'%P') - endif - end subroutine out_comm_var - - !============================================================ - ! If comm string is present then output it, otherwise - ! output the default communicator for this context - !============================================================ - subroutine out_comm_str(g,comm) - type(gen_state):: g - character(len=*),optional:: comm - if(present(comm)) then - call out_str(g,comm) - else - call out_str(g,'PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM') - endif - end subroutine out_comm_str - - !============================================================ - ! Code mpi_irecv mpi_isrecv ... - ! Node must be in JNODE - !============================================================ - recursive subroutine gen_mpi_recv(g,v,tag,s,mode,rest,comm) - type(gen_state):: g - integer,intent(in):: v - integer,intent(in):: mode - character(len=*),intent(in):: tag,s - character,intent(in),optional:: comm - logical,intent(in):: rest - integer:: k,k2,i,tno,a - logical:: nonblocking,nontrivial - character(len=5):: ibuffer - nonblocking=s=='IRECV' - k=g_kind(g,v) - k2=g_v2(g,v) - select case(k) - case(v_is_group) - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - i=g_ptr(g,v,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_mpi_recv(g,i,tag,s,mode,rest,comm) - endif - if(k2/=v_is_shared_dref) then - call gen_mpi_recv(g,g_ptr(g,v,3),tag,s,mode,rest,comm) - endif - elseif(k2==v_is_storageless) then - continue - elseif(k2==v_is_array) then - if(mode/=mode_array) call pm_panic('recv to split array') - call gen_mpi_recv(g,g_ptr(g,v,1),tag,s,mode_array_vect,rest,comm) - else - ! Structures/records - do i=1,g_v1(g,v) - call gen_mpi_recv(g,g_ptr(g,v,i),tag,s,mode,rest,comm) - enddo - endif - case(v_is_basic) - tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) - if(g_is_complex_type(g,tno)) then - call out_str(g,'NA=SIZE(') - call out_comm_var(g,v,mode) - call out_line(g,')') - if(nonblocking) then - call out_line(g,'CALL MPI_IRECV(J,0,MPI_INTEGER,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - if(.not.rest) then - call out_str(g,'CALL MPI_RECV(J,0,MPI_INTEGER,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',MPI_STATUS_IGNORE,JERRNO)') - endif - call g_add_packable(g,unpack_vect,tno) - call out_str(g,'CALL PM__RECV_BUFFER(JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,')') - call out_line(g,'PM__BUFFER%SIZEOF=0') - call out_simple_part(g,'CALL PM__UNPACKVEC$N(NA,',n=tno) - call out_comm_var(g,v,mode) - call out_line(g,')') - endif - else - if(.not.rest) then - call out_str(g,'NA=SIZE(') - call out_comm_var(g,v,mode) - call out_line(g,')') - call out_get_mpi_base_type(g,tno) - call out_line(g,'CALL PM__GET_MPI_TYPE(JBASE,NA,JTYPE,JN,LNEW)') - call out_str(g,'CALL MPI_'//s//'(') - call out_comm_var(g,v,mode) - if(nonblocking) then - call out_str(g,',JN,JTYPE,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - call out_str(g,',JN,JTYPE,JNODE,'//tag//',') - call out_comm_str(g,comm) - call out_line(g,',MPI_STATUS_IGNORE,JERRNO)') - endif - call out_line(g,'IF(LNEW) CALL MPI_TYPE_FREE(JTYPE,JERRNO)') - endif - endif - case(v_is_alias,v_is_chan_vect,v_is_vect_wrapped) - call gen_mpi_recv(g,g_v1(g,v),tag,s,mode,rest,comm) - case default - write(*,*) 'v=',v,'k=',k - call pm_panic('Problem var in gen_mpi_recv') - end select - end subroutine gen_mpi_recv - - !============================================================ - ! Generate code for mpi broadcast - ! node must be in JNODE - !============================================================ - recursive subroutine gen_mpi_bcast(g,v,isshared,array_vect) - type(gen_state),intent(inout):: g - integer,intent(in):: v - logical,intent(in),optional:: isshared,array_vect - integer:: tno - integer:: k,k2,i - logical:: nontrivial,isvec - k=g_kind(g,v) - k2=g_v2(g,v) - select case(k) - case(v_is_group) - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - if(debug_g) then - write(*,*) 'DREF>',g_ptr(g,v,1),g_ptr(g,v,2),g_ptr(g,v,3),g_ptr(g,v,4),g_ptr(g,v,5) - endif - i=g_ptr(g,v,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_mpi_bcast(g,i,isshared,array_vect) - endif - if(k2/=v_is_shared_dref) then - call gen_mpi_bcast(g,g_ptr(g,v,3),isshared,array_vect) - endif - elseif(k2<0) then - continue - elseif(k2<=v_is_array) then - call gen_mpi_bcast(g,g_ptr(g,v,1),isshared,array_vect=.true.) - call gen_mpi_bcast(g,g_ptr(g,v,2),isshared,array_vect) - else - ! Structures/records - do i=1,g_v1(g,v) - call gen_mpi_bcast(g,g_ptr(g,v,i),isshared,array_vect) - enddo - endif - case(v_is_basic,v_is_chan_vect) - tno=g_type(g,v) - isvec=g_is_vect(g,v).or.present(array_vect) - if(g_is_complex_type(g,tno)) then - call g_add_packable(g,pack_scalar,tno) - call out_line(g,'CALL PM__NEW_BUFFER') - if(isvec) then - call out_simple(g,'NA=SIZE($A)',x=v) - endif - if(present(isshared)) then - call out_line(g,'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE==0) THEN') - else - call out_line(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) THEN') - endif - if(.not.isvec) then - call g_add_packable(g,pack_scalar,tno) - call out_simple(g,'CALL PM__COUNT($I)',x=v) - call out_line(g,'CALL PM__ALLOCATE_BUFFER') - call out_simple(g,'CALL PM__PACK($I)',x=v) - else - call g_add_packable(g,pack_vect,tno) - call out_simple(g,'CALL PM__PACKVEC$N(NA,$A)',n=tno,x=v) - endif - if(present(isshared)) then - call out_line(g,'CALL PM__BCAST_BUFFER(0,PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM)') - call out_line(g,'ELSE') - call out_line(g,'CALL PM__BCAST_BUFFER(0,PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM)') - else - call out_line(g,'CALL PM__BCAST_BUFFER(JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - call out_line(g,'ELSE') - call out_line(g,'CALL PM__BCAST_BUFFER(JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - endif - if(.not.isvec) then - call out_simple(g,'CALL PM__UNPACK$N($A)',x=v,n=tno) - else - call out_simple(g,'CALL PM__UNPACKVEC$N(NA,$A)',x=v,n=tno) - endif - call out_line(g,'ENDIF') - else - tno=g_type(g,v) - if(.not.isvec) then - call out_line(g,'JN=1') - call out_get_mpi_base_type(g,tno) - call out_line(g,'JTYPE=JBASE') - else - if(present(array_vect)) then - call out_simple(g,'NA=SIZE($A%P)',x=v) - else - call out_simple(g,'NA=SIZE($A)',x=v) - endif - call out_get_mpi_base_type(g,tno) - call out_simple(g,& - 'CALL PM__GET_MPI_TYPE(JBASE,NA,JTYPE,JN,LNEW)',n=g%lthis) - endif - call out_str(g,'CALL MPI_BCAST(') - call out_arg(g,v,merge(arg_no_index,0,isvec)) - if(present(array_vect)) then - call out_str(g,'%P') - endif - if(present(isshared)) then - call out_line(g,& - ',JN,JTYPE,0,PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM,JERRNO)') - else - call out_line(g,& - ',JN,JTYPE,JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') - endif - if(isvec) then - call out_line(g,'IF(LNEW) CALL MPI_TYPE_FREE(JTYPE,JERRNO)') - endif - endif - case(v_is_alias) - call gen_mpi_bcast(g,g_v1(g,v)) - case default - call pm_panic('problem var in gen_mpi_bcast') - end select - end subroutine gen_mpi_bcast - - !======================================================================== - ! Code mpi_send mpi_isend ... for sub-array defined in disp_var - ! Node must be in JNODE - !======================================================================== - subroutine gen_mpi_send_disp_or_grid(g,v,tag,s,disp_var,mode) - type(gen_state):: g - integer,intent(in):: v,disp_var - character(len=*),intent(in):: tag,s - integer,intent(in),optional:: mode - call gen_mpi_send_part(g,v,tag,s,'$A','1','SIZE($A)',mode,disp_var) - end subroutine gen_mpi_send_disp_or_grid - - !======================================================================== - ! Code mpi_recv mpi_irecv ... for sub-array defined in disp_var - ! Node must be in JNODE - !======================================================================== - subroutine gen_mpi_recv_disp_or_grid(g,v,tag,s,disp_var,mode,rest) - type(gen_state):: g - integer,intent(in):: v,disp_var - character(len=*),intent(in):: tag,s - logical,intent(in):: rest - integer,intent(in):: mode - call gen_mpi_recv_part(g,v,tag,s,rest,'$A','1','SIZE($A)',mode,disp_var) - end subroutine gen_mpi_recv_disp_or_grid - - !======================================================================== - ! Code mpi_isend mpi_issend ... for sub-array - ! - either dv(dv1:dv2) or by displacements defined in dvv - ! Node must be in JNODE - !======================================================================== - recursive subroutine gen_mpi_send_part(g,v,tag,s,dv,dv1,dv2,mode,dvv) - type(gen_state):: g - integer,intent(in):: v,mode - character(len=*),intent(in):: dv,dv1,dv2,tag,s - integer,intent(in),optional:: dvv - integer:: k,k2,i,tno,a - logical:: nonblocking,nontrivial,ok - character(len=5):: ibuffer - !call out_simple(g,'WRITE(*,*) "SEND DISP",$N,$M',n=abs(v),m=mode) - if(debug_g) write(*,*) 'SEND_DISP> v=',v,'s=',trim(s),'k=',g_kind(g,v) - nonblocking=s=='ISEND'.or.s=='ISSEND' - k=g_kind(g,v) - k2=g_v2(g,v) - select case(k) - case(v_is_group) - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - i=g_ptr(g,v,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_mpi_send_part(g,i,tag,s,dv,dv1,dv2,mode,dvv) - endif - if(k2/=v_is_shared_dref) then - call gen_mpi_send_part(g,g_ptr(g,v,3),tag,s,dv,dv1,dv2,mode,dvv) - endif - elseif(k2<0) then - continue - elseif(k2==v_is_array) then - if(mode==mode_array) then - call gen_mpi_send_part(g,g_ptr(g,v,1),tag,s,dv,dv1,dv2,mode_array_vect,dvv) - else - call out_simple(g,'NA='//dv2//'-'//dv1//'+1',x=dvv) - tno=g_type(g,v) - call g_add_packable(g,pack_array_vect_disp,tno) - call out_simple_part(g,'CALL PM__PACKADVEC$N(NA,$A,',& - n=tno,x=g_ptr(g,v,1)) - call out_arg(g,g_ptr(g,v,2),arg_no_index) - call out_simple(g,','//dv//'('//dv1//':'//dv2//'))',x=dvv) - call out_line(g,'CALL PM__'//s//'_BUFFER(JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - endif - else - ! Structures/records - do i=1,g_v1(g,v) - call gen_mpi_send_part(g,g_ptr(g,v,i),tag,s,dv,dv1,dv2,mode,dvv) - enddo - endif - case(v_is_basic,v_is_sub,v_is_vsub,v_is_elem,& - v_is_unit_elem,v_is_const,v_is_ctime_const) - tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) - if(g_is_complex_type(g,tno)) then - call out_simple(g,'NA='//dv2//'-'//dv1//'+1',x=dvv) - if(nonblocking) then - call out_line(g,'CALL MPI_'//s//'(J,0,MPI_INTEGER,JNODE,'//& - tag//',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - call out_line(g,'CALL MPI_'//s//'(J,0,MPI_INTEGER,JNODE,'//& - tag//',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') - endif - call g_add_packable(g,pack_vect_disp,tno) - call out_simple_part(g,'CALL PM__PACKDVEC$N(NA,',n=tno) - call out_comm_var(g,v,mode) - call out_simple(g,','//dv//'('//dv1//':'//dv2//'))',x=dvv) - call out_line(g,'CALL PM__'//s//'_BUFFER(JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - elseif(tno>=pm_int) then - call make_disp_mpi_type(g,tno,mode,dv,dv1,dv2,dvv) - call out_str(g,'CALL MPI_'//s//'(') - if(debug_g) write(*,*) 'SENDING> v=',v,nonblocking,mode - call out_comm_var(g,v,mode) - if(nonblocking) then - call out_line(g,',1,JTYPE,JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - call out_line(g,',1,JTYPE,JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') - endif - endif - case(v_is_alias,v_is_chan_vect,v_is_vect_wrapped) - call gen_mpi_send_part(g,g_v1(g,v),tag,s,dv,dv1,dv2,mode,dvv) - case default - write(*,*) 'v=',v,'k=',k - call pm_panic('Problem var in gen_mpi_send_part') - end select - if(debug_g) write(*,*) 'END SEND DISP>',v - end subroutine gen_mpi_send_part - - !============================================================ - ! Code mpi_recv, mpi_irecv - ! - either dv(dv1:dv2) or by displacements defined in dvv - ! Node must be in JNODE - !============================================================ - recursive subroutine gen_mpi_recv_part(g,v,tag,s,rest,dv,dv1,dv2,mode,dvv) - type(gen_state):: g - integer,intent(in):: v,mode - character(len=*),intent(in):: tag,s,dv,dv1,dv2 - integer,intent(in),optional:: dvv - logical,intent(in):: rest - integer:: k,k2,i,tno,a - logical:: nonblocking,ok - character(len=5):: ibuffer - if(debug_g) write(*,*) 'RECV>',v - nonblocking=s=='IRECV' - k=g_kind(g,v) - k2=g_v2(g,v) - select case(k) - case(v_is_group) - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - i=g_ptr(g,v,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_mpi_recv_part(g,i,tag,s,rest,dv,dv1,dv2,mode,dvv) - endif - if(k2/=v_is_shared_dref) then - call gen_mpi_recv_part(g,g_ptr(g,v,3),tag,s,rest,dv,dv1,dv2,mode,dvv) - endif - elseif(k2<0) then - continue - elseif(k2<=v_is_array) then - if(mode/=mode_array) call pm_panic('recv_disp to split array') - call gen_mpi_recv_part(g,g_ptr(g,v,1),tag,s,rest,dv,dv1,dv2,mode_array_vect,dvv) - else - ! Structures/records - do i=1,g_v1(g,v) - call gen_mpi_recv_part(g,g_ptr(g,v,i),tag,s,rest,dv,dv1,dv2,mode,dvv) - enddo - endif - case(v_is_basic,v_is_sub,v_is_vsub,v_is_elem,v_is_unit_elem) - tno=g_type(g,v) - if(mode==mode_array) then - !write(*,*) 'tno=',pm_typ_as_string(g%context,tno) - tno=pm_typ_arg(g%context,tno,1) - endif - if(g_is_complex_type(g,tno)) then - if(nonblocking) then - call out_line(g,'CALL MPI_IRECV(J,0,MPI_INTEGER,JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - if(.not.rest) then - call out_line(g,'CALL MPI_RECV(J,0,MPI_INTEGER,JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,MPI_STATUS_IGNORE,JERRNO)') - endif - call out_line(g,& - 'CALL PM__RECV_BUFFER(JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - call g_add_packable(g,unpack_vect_disp,tno) - call out_simple_part(g,'CALL PM__UNPACKDVEC$N(',n=tno) - call out_str(g,'('//dv2//')-('//dv1//')+1,') - call out_comm_var(g,v,mode) - call out_simple(g,','//dv//'('//dv1//':'//dv2//'))',x=dvv) - endif - elseif(tno>=pm_int) then - if(.not.rest) then - call make_disp_mpi_type(g,tno,mode,dv,dv1,dv2,dvv) - call out_str(g,'CALL MPI_'//s//'(') - call out_comm_var(g,v,mode) - if(nonblocking) then - call out_line(g,',1,JTYPE,JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JMESS,JERRNO)') - call out_line(g,'CALL PM__PUSH_MESSAGE(JMESS)') - else - call out_simple(g,',1,JTYPE,JNODE,'//tag//& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,MPI_STATUS_IGNORE,JERRNO)') - endif - endif - endif - case(v_is_alias,v_is_chan_vect,v_is_vect_wrapped) - call gen_mpi_recv_part(g,g_v1(g,v),tag,s,rest,dv,dv1,dv2,mode,dvv) - case default - write(*,*) 'v=',v,'k=',k - call pm_panic('Problem var in gen_mpi_recv_part') - end select - end subroutine gen_mpi_recv_part - - !============================================================ - ! Generate code for mpi broadcast - ! node must be in JNODE - !============================================================ - recursive subroutine gen_mpi_bcast_part(g,v,isshared,dv,dv1,dv2,mode,dvv) - type(gen_state),intent(inout):: g - integer,intent(in):: v,mode - logical,intent(in),optional:: isshared - character(len=*),intent(in):: dv,dv1,dv2 - integer,intent(in),optional:: dvv - integer:: tno - integer:: k,k2,i - k=g_kind(g,v) - k2=g_v2(g,v) - select case(k) - case(v_is_group) - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - if(debug_g) then - write(*,*) 'DREF>',g_ptr(g,v,1),g_ptr(g,v,2),g_ptr(g,v,3),g_ptr(g,v,4),g_ptr(g,v,5) - endif - i=g_ptr(g,v,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_mpi_bcast_part(g,i,isshared,dv,dv1,dv2,mode,dvv) - endif - if(k2/=v_is_shared_dref) then - call gen_mpi_bcast_part(g,g_ptr(g,v,3),isshared,dv,dv1,dv2,mode,dvv) - endif - elseif(k2<0) then - continue - elseif(k2<=v_is_array) then - call gen_mpi_bcast_part(g,g_ptr(g,v,i),isshared,dv,dv1,dv2,mode_array_vect,dvv) - else - ! Structures/records - do i=1,g_v1(g,v) - call gen_mpi_bcast_part(g,g_ptr(g,v,i),isshared,dv,dv1,dv2,mode,dvv) - enddo - endif - case(v_is_basic) - tno=g_type(g,v) - if(mode==mode_array) tno=pm_typ_arg(g%context,tno,1) - if(g_is_complex_type(g,tno)) then - call out_simple(g,'NA='//dv2//'-'//dv1//'+1',x=dvv) - call g_add_packable(g,pack_vect_disp,tno) - call g_add_packable(g,unpack_vect_disp,tno) - if(isshared) then - call out_line(g,'IF(PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_NODE==0) THEN') - else - call out_line(g,'IF(JNODE.EQ.PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_NODE) THEN') - endif - call out_simple_part(g,'CALL PM__PACKDVEC$N(NA,%A',n=tno,x=v) - call out_simple(g,dv//'('//dv1//':'//dv2//'))',x=dvv) - if(isshared) then - call out_line(g,'CALL PM__BCAST_BUFFER(0,PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM)') - call out_line(g,'ELSE') - call out_line(g,'CALL PM__BCAST_BUFFER(0,PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM)') - else - call out_line(g,'CALL PM__BCAST_BUFFER(JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - call out_line(g,'ELSE') - call out_line(g,'CALL PM__BCAST_BUFFER(JNODE,PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM)') - endif - call out_simple_part(g,'CALL PM__UNPACKDVEC$N(NA,%A',n=tno,x=v) - call out_line(g,'ENDIF') - elseif(tno>=pm_int) then - call make_disp_mpi_type(g,tno,mode,dv,dv1,dv2,dvv) - call out_str(g,'CALL MPI_BCAST(') - call out_arg(g,v,arg_no_index) - - if(isshared) then - call out_line(g,',1,JTYPE,JNODE,'& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%SHARED_COMM,JERRNO)') - else - call out_simple(g,',1,JTYPE,JNODE,'& - ',PM__NODE_FRAME(PM__NODE_DEPTH)%THIS_COMM,JERRNO)') - endif - endif - case(v_is_alias,v_is_chan_vect,v_is_vect_wrapped) - call gen_mpi_bcast_part(g,g_v1(g,v),isshared,dv,dv1,dv2,mode,dvv) - case default - call pm_panic('problem var in gen_mpi_bcast_disp') - end select - end subroutine gen_mpi_bcast_part - - !============================================================ - ! Output code to wait on all pending mpi messages - ! implementing op_sync_mess - !============================================================ - subroutine gen_sync_mess(g,l,a,n) - type(gen_state):: g - integer,intent(in):: l,a,n - call gen_sync_reg - call out_line(g,& - 'CALL MPI_WAITALL(PM__MESSAGE_TOP,PM__MESSAGE_STACK,MPI_STATUSES_IGNORE,JERRNO)') - call gen_sync_reg - call out_line(g,'CALL PM__TIDY_MESSAGES()') - contains - subroutine gen_sync_reg - integer:: i,arg - if(n>0) then - call out_line(g,'IF(.NOT.MPI_ASYNC_PROTECTS_NONBLOCKING)THEN') - do i=1,n-1 - arg=g%codes(a+i) - if(g%varindex(arg)==0) cycle - if(g_flags_set(g,arg,v_is_param)) cycle - if(g_kind(g,arg)==v_is_ctime_const) cycle - call out_simple(g,'CALL MPI_F_SYNC_REG($Y)',l,x=i) - enddo - call out_line(g,'ENDIF') - endif - end subroutine gen_sync_reg - end subroutine gen_sync_mess - - - !================================================================ - ! Create MPI datatype to either encode displacements dv(dv1:dv2) - ! or PM grid defined by dvv (if dvv argument present) - !================================================================ - - !!! Change to disp_or_grid type - !!! correct access to tuple - - subroutine make_disp_mpi_type(g,tno,mode,dv,dv1,dv2,dvv) - type(gen_state):: g - integer,intent(in):: tno,mode - character(len=*),intent(in):: dv,dv1,dv2 - integer,intent(in),optional:: dvv - integer:: grid_tuple,grid_dim,i,j - type(pm_ptr):: tv - if(present(dvv)) then - if(g_kind(g,dvv)==v_is_group) then - grid_tuple=g_ptr(g,dvv,1) - if(pm_debug_checks) then - if(g_kind(g,grid_tuple)/=v_is_group) then - call pm_panic('norm grid not a group') - endif - endif - call out_get_mpi_base_type(g,tno) - call out_line(g,'JTYPE=JBASE') - do i=1,g_v1(g,grid_tuple) - grid_dim=g_ptr(g,grid_tuple,i) - if(g_kind(g,grid_tuple)/=v_is_group) then - call pm_panic('norm grid dim not a group') - endif - if(g_v1(g,grid_dim)==1) then - grid_dim=g_ptr(g,grid_dim,1) - if(g_kind(g,grid_dim)==v_is_group) then - if(g_v2(g,grid_dim)/=v_is_array.and.g_v2(g,grid_dim)/=v_is_var_array) then - call pm_panic('grid dim array not array') - endif - call out_simple(g,'CALL PM__GET_MPI_DISP_TYPE(JTYPE,$A,1_PM__LN,JTYPE_N)',& - x=g_ptr(g,grid_dim,1)) - call out_line(g,'JTYPE=JTYPE_N') - elseif(pm_typ_kind(g%context,g_type(g,grid_dim))==pm_typ_is_array) then - call out_simple(g,'CALL PM__GET_MPI_DISP_TYPE(JTYPE,$A%P,1_PM__LN,JTYPE_N)',& - x=g_ptr(g,grid_dim,1)) - call out_line(g,'JTYPE=JTYPE_N') - endif - else - if(g_v1(g,grid_dim)/=6) then - call pm_panic('grid_dim incorrect number of entries') - endif - call out_str(g,'CALL PM__GET_MPI_SUBRANGE_TYPE(JTYPE,') - tv=pm_typ_vect(g%context,g_type(g,grid_dim)) - do j=1,6 - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,j)),pm_typ_has_storage)/=0) then - call out_arg(g,g_ptr(g,grid_dim,j),0) - call out_char(g,',') - else - call out_const(g,pm_typ_val(g%context,pm_tv_arg(tv,j))) - call out_char(g,',') - endif - enddo - call out_line(g,'JTYPE_N)') - call out_line(g,'JTYPE=JTYPE_N') - endif - enddo - call out_line(g,'CALL MPI_TYPE_COMMIT(JTYPE,JERRNO)') - return - endif - endif - call out_get_mpi_base_type(g,tno) - !write(*,*) dvv,'::','CALL PM__GET_MPI_DISP_TYPE(JBASE,'//dv//'('//dv1//':'//dv2//')' - call out_simple_part(g,'CALL PM__GET_MPI_DISP_TYPE(JBASE,'//dv//'('//dv1//':'//dv2//')',x=dvv) - call out_line(g,',1_PM__LN,JTYPE)') - end subroutine make_disp_mpi_type - - !============================================================ - ! Generate code for - ! v1<-pack(v2,m) where m is logical vector - !============================================================ - recursive subroutine gen_pack(g,v1,v2,m) - type(gen_state),intent(inout):: g - integer,intent(in):: v1,v2,m - integer:: k,k2,i - if(debug_g) write(*,*) 'PACK> v1=',v1,g_kind(g,v1),'v2=',v2,g_kind(g,v2),'m=',m - k=g_kind(g,v1) - k2=g_v2(g,v1) - if(k==v_is_group) then - if(k2==v_is_dref.or.k2==v_is_shared_dref) then - i=g_ptr(g,v1,2) - if(g_kind(g,i)==v_is_group.and.g_v2(g,i)==v_is_dref) then - call gen_pack(g,i,g_ptr(g,v2,2),m) - endif - if(k2/=v_is_shared_dref) then - call gen_pack(g,g_ptr(g,v1,3),g_ptr(g,v2,3),m) - endif - elseif(k2<0) then - continue - elseif(k2<=v_is_array) then - call gen_pack(g,g_ptr(g,v1,1),g_ptr(g,v2,1),m) - call gen_pack(g,g_ptr(g,v1,2),g_ptr(g,v2,2),m) - else - ! Structures/records - do i=1,g_v1(g,v1) - call gen_pack(g,g_ptr(g,v1,i),g_ptr(g,v2,i),m) - enddo - endif - elseif(iand(k2,v_is_poly)/=0) then - call out_line(g,'IX=0') - call out_simple(g,'DO I$N=1,N$N',n=g%lthis) - if(m/=0) call out_simple(g,'IF($I) THEN',x=m) - call out_line(g,'IX=IX+1') - call out_arg(g,v1,arg_ix_index) - call out_char(g,'=') - call out_arg(g,v2,0) - call out_new_line(g) - if(m/=0) call out_line(g,'ENDIF') - call out_line(g,'ENDDO') - else - call out_arg(g,v1,arg_no_index) - if(m==0) then - call out_char(g,'=') - call out_arg(g,v2,arg_wrapped) - call out_str(g,' ! pack - copy') - else - call out_str(g,'=PACK(') - call out_arg(g,v2,arg_wrapped) - call out_char(g,',') - call out_arg(g,m,arg_wrapped) - call out_char(g,')') - endif - call out_new_line(g) - endif - if(debug_g) write(*,*) 'PACKED> v1=',v1 - end subroutine gen_pack - - !*************************************************************** - ! ROUTINES TO (UN)PACK DATA TO A COMMUNICATIONS BUFFER - !*************************************************************** - - subroutine gen_packables(g) - type(gen_state),intent(inout):: g - integer:: i,kind,tno - type(pm_ptr):: key - ! Generate any required COUNT/PACK/UNPACK subroutines - i=1 - do while(i<=pm_set_size(g%context,g%packables)) - key=pm_set_key(g%context,g%packables,int(i,pm_ln)) - kind=key%data%i(key%offset) - tno=key%data%i(key%offset+1) - select case(kind) - case(pack_scalar) - call gen_count_routine(g,tno) - call gen_pack_routine(g,tno) - call gen_unpack_routine(g,tno) - case(pack_vect,pack_vect_disp) - call gen_vect_pack_to_buffer(g,tno,kind/=pack_vect) - case(pack_array_vect,pack_array_vect_disp) - call gen_array_vect_pack_to_buffer(g,tno,kind/=pack_array_vect) - case(unpack_vect,unpack_vect_disp) - call gen_vect_unpack_from_buffer(g,tno,kind/=unpack_vect) - case default - call pm_panic('gen_packables') - end select - i=i+1 - enddo - end subroutine gen_packables - - !==================================================== - ! Flag that we need pack/unpack routines for type tno - ! kind= which routines needed (pack_scalar..) - !==================================================== - recursive subroutine g_add_packable(g,kind,tno) - type(gen_state),intent(inout):: g - integer,intent(in):: kind,tno - integer:: key(2),i - integer(pm_ln):: j - if(tno<=pm_null) return - key(1)=kind - key(2)=tno - j=pm_iset_add(g%context,g%packables,key,2) - end subroutine g_add_packable - - !=============================================== - ! Pack variable v to newly allocated buffer - ! v is a vector length NA - !============================================== - subroutine gen_vect_pack_to_buffer(g,tno,isdisp) - type(gen_state):: g - integer,intent(in):: tno - logical,intent(in):: isdisp - integer(pm_ln),dimension(pm_int:pm_string):: counts - logical:: has_depth - call out_new_line(g) - if(isdisp) then - call out_simple(g,'SUBROUTINE PM__PACKDVEC$N(NA,X,D)',n=tno) - else - call out_simple(g,'SUBROUTINE PM__PACKVEC$N(NA,X)',n=tno) - endif - call out_line(g,'INTEGER(PM__LN):: NA') - call out_type(g,tno) - call out_line(g,',DIMENSION(:)::X') - if(isdisp) call out_line(g,'INTEGER(PM__LN),DIMENSION(NA)::D') - call out_line(g,'CALL PM__NEW_BUFFER') - has_depth=.false. - counts=0 - call out_line(g,'NP1=NA') - call precount(g,tno,counts,has_depth) - if(has_depth) then - if(isdisp) then - call out_line(g,'DO IX=1,NA') - call out_line(g,'IP1=D(IX)+1') - else - call out_line(g,'DO IP1=1,NA') - endif - call outcount(g,tno,'X'//'(IP1)',1) - call out_line(g,'ENDDO') - endif - call outaddcount(g,counts,1) - call out_line(g,'CALL PM__ALLOCATE_BUFFER') - call g_add_packable(g,pack_scalar,tno) - if(isdisp) then - call out_line(g,'DO IIX=1,NA') - call out_line(g,'IX=D(IIX)+1') - else - call out_line(g,'DO IX=1,NA') - endif - call out_simple(g,'CALL PM__PACK$N(X(IX))',n=tno) - call out_line(g,'ENDDO') - if(isdisp) then - call out_simple(g,'END SUBROUTINE PM__PACKDVEC$N',n=tno) - else - call out_simple(g,'END SUBROUTINE PM__PACKVEC$N',n=tno) - endif - end subroutine gen_vect_pack_to_buffer - - !=============================================== - ! Pack variable v to newly allocated buffer - ! v is a vector length NA - !============================================== - subroutine gen_vect_unpack_from_buffer(g,tno,isdisp) - type(gen_state):: g - integer,intent(in):: tno - logical,intent(in):: isdisp - call out_new_line(g) - if(isdisp) then - call out_simple(g,'SUBROUTINE PM__UNPACKDVEC$N(NA,X,D)',n=tno) - else - call out_simple(g,'SUBROUTINE PM__UNPACKVEC$N(NA,X)',n=tno) - endif - call out_line(g,'INTEGER(PM__LN):: NA') - call out_type(g,tno) - call out_line(g,',DIMENSION(:):: X') - if(isdisp) then - call out_line(g,'INTEGER(PM__LN),DIMENSION(NA):: D') - endif - call g_add_packable(g,pack_scalar,tno) - if(isdisp) then - call out_line(g,'DO IIX=1,NA') - call out_line(g,'IX=D(IIX)+1') - else - call out_line(g,'DO IX=1,NA') - endif - call out_simple(g,'CALL PM__UNPACK$N(X(IX))',n=tno) - call out_line(g,'ENDDO') - if(isdisp) then - call out_simple(g,'END SUBROUTINE PM__UNPACKDVEC$N',n=tno) - else - call out_simple(g,'END SUBROUTINE PM__UNPACKVEC$N',n=tno) - endif - end subroutine gen_vect_unpack_from_buffer - - - !================================================== - ! Pack split array v1/cv2 to newly allocated buffer - ! v1 and v2 are vectors length NA - !=================================================== - subroutine gen_array_vect_pack_to_buffer(g,tno,isdisp) - type(gen_state):: g - integer,intent(in):: tno - logical:: isdisp - integer(pm_ln),dimension(pm_int:pm_string):: counts - logical:: has_depth - type(pm_ptr):: tv - integer:: tno1,tno2 - tv=pm_typ_vect(g%context,tno) - tno1=pm_tv_arg(tv,1) - tno2=pm_tv_arg(tv,2) - call out_new_line(g) - if(isdisp) then - call out_simple(g,'SUBROUTINE PM__PACKADVEC$N(NA,X,Y,D)',n=tno) - else - call out_simple(g,'SUBROUTINE PM__PACKAVEC$N(NA,X,Y)',n=tno) - endif - call out_line(g,'INTEGER(PM__LN):: NA') - call out_simple(g,'TYPE(PM__TV$N),DIMENSION(:):: X',n=tno) - call out_type(g,tno2) - call out_line(g,',DIMENSION(:)::Y') - if(isdisp) then - call out_line(g,'INTEGER(PM__LN),DIMENSION(NA):: D') - endif - call out_line(g,'CALL PM__NEW_BUFFER') - has_depth=.false. - counts=0 - call precount(g,pm_tv_arg(tv,1),counts,has_depth) - if(has_depth) then - call out_simple(g,'NP1=0') - if(isdisp) then - call out_line(g,'DO IX=1,NA') - call out_line(g,'IP1=D(IX)+1') - else - call out_line(g,'DO IP1=1,NA') - endif - call out_line(g,'NP2=SIZE('//'X'//'(IP1)%P)') - call out_line(g,'NP1=NP1+NP2') - call out_line(g,'DO IP2=1,NP2') - call outcount(g,pm_tv_arg(tv,1),'X'//'(IP1)%P(IP2)',2) - call out_line(g,'ENDDO') - call out_line(g,'ENDDO') - else - call out_line(g,'NP1=NA') - endif - call outaddcount(g,counts,1) - call out_line(g,'CALL PM__ALLOCATE_BUFFER') - call g_add_packable(g,pack_scalar,tno1) - call g_add_packable(g,pack_scalar,tno2) - call g_add_packable(g,pack_scalar,int(pm_long)) - if(isdisp) then - call out_line(g,'DO IIX=1,NA') - call out_line(g,'IX=D(IIX)+1') - else - call out_line(g,'DO IX=1,NA') - endif - call out_str(g,'NV=SIZE(X(IX)%P)') - call out_simple(g,'CALL PM__PACK$N(NV)',n=int(pm_long)) - call out_line(g,'DO IY=1,NV') - call out_simple_part(g,'CALL PM__PACK$N(X(IX)%P(IY))',n=tno1) - call out_line(g,'ENDDO') - call out_simple_part(g,'CALL PM__PACK$N(Y)',n=tno2) - call out_line(g,'ENDDO') - if(isdisp) then - call out_simple(g,'END SUBROUTINE PM__PACKADVEC$N',n=tno) - else - call out_simple(g,'END SUBROUTINE PM__PACKAVEC$N',n=tno) - endif - end subroutine gen_array_vect_pack_to_buffer - - - !=============================================================================== - ! Create subroutine PM__PACKtno(X,N) to pack the N elements of X - ! into the current buffer - ! Buffer must be allocated to correct size (determined by PM__COUNT) beforehand - !=============================================================================== - subroutine gen_pack_routine(g,tno) - type(gen_state):: g - integer,intent(in):: tno - integer,dimension(pm_int:pm_string):: counts - logical:: hasdepth - logical:: recur - recur=iand(pm_typ_flags(g%context,tno),pm_typ_has_poly)/=0 - counts=0 - call out_new_line(g) - if(recur) call out_str(g,'RECURSIVE ') - call out_str(g,'SUBROUTINE PM__PACK') - call out_idx(g,tno) - call out_line(g,'(X)') - call out_type(g,tno) - call out_line(g,'::X') - call outpack(tno,'X',0) - call out_str(g,'END SUBROUTINE PM__PACK') - call out_idx(g,tno) - call out_new_line(g) - contains - - include 'fisnull.inc' - - recursive subroutine outpack(tno,varname,depth) - integer,intent(in):: tno - character(len=*),intent(in):: varname - integer,intent(in):: depth - type(pm_ptr):: tv,tlist,telem - character(len=5):: ibuffer - integer:: i,n,tno2 - tv=pm_typ_vect(g%context,tno) - select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) - if(tno>=pm_int.and.tno<=pm_string) then - call out_str(g,'PM__BUFFER%SIZEOF(') - call out_kind(g,tno) - call out_str(g,')=PM__BUFFER%SIZEOF(') - call out_kind(g,tno) - call out_line(g,')+1') - call out_str(g,'PM__BUFFER%') - call out_suffix(g,tno) - call out_str(g,'(PM__BUFFER%SIZEOF(') - call out_kind(g,tno) - call out_str(g,'))') - call out_char(g,'=') - call out_line(g,varname) - endif - case(pm_typ_is_array) - write(ibuffer,'(i5)') depth+1 - ibuffer=adjustl(ibuffer) - call out_line(g,'NP'//trim(ibuffer)//'=SIZE('//varname//'%E1%P)') - call outpack(int(pm_long),'NP'//trim(ibuffer),depth) - call out_line(g,'DO IP'//trim(ibuffer)//'=1,NP'//trim(ibuffer)) - call outpack(pm_tv_arg(tv,1),varname//'%E1%P(IP'//trim(ibuffer)//')',depth+1) - call out_line(g,'ENDDO') - call outpack(pm_tv_arg(tv,2),varname//'%E2',depth) - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) - do i=1,pm_tv_numargs(tv) - write(ibuffer,'(i5)') i - call outpack(pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) - enddo - case(pm_typ_is_poly) - call out_line(g,'PM__BUFFER%SIZEOF(PM__INT)=PM__BUFFER%SIZEOF(PM__INT)+1') - call out_line(g,'PM__BUFFER%I(PM__BUFFER%SIZEOF(PM__INT))=0') - call out_str(g,'SELECT TYPE(POLYVAR=>') - call out_str(g,varname) - call out_line(g,'%P)') - tlist=g_check_poly(g,tno) - if(.not.pm_fast_isnull(tlist)) then - n=pm_set_size(g%context,tlist) - do i=1,n - telem=pm_set_key(g%context,tlist,int(i,pm_ln)) - tno2=telem%data%i(telem%offset) - if(tno2<=pm_string) then - call out_simple(g,'TYPE IS(PM__T$S)',x=tno2) - call outpack(tno2,'POLYVAR%P',depth) - else - call out_str(g,'TYPE IS(PM__T') - call out_idx(g,tno2) - call out_line(g,')') - call out_str(g,'CALL PM__PACK') - call out_idx(g,tno2) - call out_line(g,'(POLYVAR)') - endif - call out_simple(g,'PM__BUFFER%I(PM__BUFFER%SIZEOF(PM__INT))=$N',n=tno2) - enddo - endif - call out_line(g,'END SELECT') - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) - continue - case(pm_typ_is_all,pm_typ_is_par_kind,pm_typ_is_enveloped,& - pm_typ_is_vect) - call outpack(pm_tv_arg(tv,1),varname,depth) - end select - end subroutine outpack - end subroutine gen_pack_routine - - !=============================================================================== - ! Create a subroutine PM__UNPACKtno(X,N) to unpack N elements from buffer into X - !=============================================================================== - subroutine gen_unpack_routine(g,tno) - type(gen_state):: g - integer,intent(in):: tno - logical:: recur - recur=iand(pm_typ_flags(g%context,tno),pm_typ_has_poly)/=0 - if(recur) call out_str(g,'RECURSIVE ') - call out_str(g,'SUBROUTINE PM__UNPACK') - call out_idx(g,tno) - call out_line(g,'(X)') - call out_type(g,tno) - call out_line(g,'::X') - if(recur) call declare_poly_vars(tno) - call outunpack(tno,'X',0) - call out_str(g,'END SUBROUTINE PM__UNPACK') - call out_idx(g,tno) - call out_new_line(g) - contains - include 'fisnull.inc' - - recursive subroutine declare_poly_vars(tno) - integer,intent(in):: tno - type(pm_ptr):: tv,tlist,telem - integer:: tno2,i,n - tv=pm_typ_vect(g%context,tno) - select case(pm_tv_kind(tv)) - case(pm_typ_is_poly) - tlist=g_check_poly(g,tno) - if(.not.pm_fast_isnull(tlist)) then - n=pm_set_size(g%context,tlist) - do i=1,n - telem=pm_set_key(g%context,tlist,int(i,pm_ln)) - tno2=telem%data%i(telem%offset) - if(tno2<=pm_string) then - call out_simple_part(g,'TYPE(PM__T$S)',x=tno2) - else - call out_type(g,tno2) - endif - call out_str(g,'::PVAL') - call out_idx(g,tno2) - call out_new_line(g) - enddo - endif - case(pm_typ_is_array,& - pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) - do i=1,pm_tv_numargs(tv) - call declare_poly_vars(pm_tv_arg(tv,i)) - enddo - end select - end subroutine declare_poly_vars - - recursive subroutine outunpack(tno,varname,depth) - integer,intent(in):: tno - character(len=*),intent(in):: varname - integer,intent(in):: depth - type(pm_ptr):: tv,tlist,telem - character(len=5):: ibuffer - integer:: i,n,tno2 - tv=pm_typ_vect(g%context,tno) - select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) - if(tno>=pm_int.and.tno<=pm_string) then - call out_str(g,'PM__BUFFER%SIZEOF(') - call out_kind(g,tno) - call out_str(g,')=PM__BUFFER%SIZEOF(') - call out_kind(g,tno) - call out_line(g,')+1') - call out_str(g,varname) - call out_str(g,'=PM__BUFFER%') - call out_suffix(g,tno) - call out_str(g,'(PM__BUFFER%SIZEOF(') - call out_kind(g,tno) - call out_line(g,'))') - endif - case(pm_typ_is_array) - write(ibuffer,'(i5)') depth+1 - ibuffer=adjustl(ibuffer) - call outunpack(int(pm_long),'NP'//trim(ibuffer),depth) - call out_line(g,'IF(ALLOCATED('//varname//'%E1%P)) DEALLOCATE('//varname//'%E1%P)') - call out_line(g,'ALLOCATE('//varname//'%E1%P(NP'//trim(ibuffer)//'))') - call out_line(g,'DO IP'//trim(ibuffer)//'=1,NP'//trim(ibuffer)) - call outunpack(pm_tv_arg(tv,1),varname//'%E1%P(IP'//trim(ibuffer)//')',depth+1) - call out_line(g,'ENDDO') - call outunpack(pm_tv_arg(tv,2),varname//'%E2',depth) - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) - do i=1,pm_tv_numargs(tv) - write(ibuffer,'(i5)') i - call outunpack(pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) - enddo - case(pm_typ_is_poly) - call out_line(g,'PM__BUFFER%SIZEOF(PM__INT)=PM__BUFFER%SIZEOF(PM__INT)+1') - call out_line(g,'SELECT CASE(PM__BUFFER%I(PM__BUFFER%SIZEOF(PM__INT)))') - tlist=g_check_poly(g,tno) - if(.not.pm_fast_isnull(tlist)) then - n=pm_set_size(g%context,tlist) - do i=1,n - telem=pm_set_key(g%context,tlist,int(i,pm_ln)) - tno2=telem%data%i(telem%offset) - call out_str(g,'CASE(') - call out_idx(g,tno2) - call out_line(g,')') - write(ibuffer,'(i5)') tno2 - if(tno2<=pm_string) then - call outunpack(tno2,'PVAL'//trim(adjustl(ibuffer))//'%P',depth) - else - call out_str(g,'CALL PM__UNPACK') - call out_idx(g,tno2) - call out_line(g,'(PVAL'//trim(adjustl(ibuffer))//')') - endif - call out_simple(g,'ALLOCATE('//varname//'%P,SOURCE=PVAL$N)',n=tno2) - enddo - endif - call out_line(g,'END SELECT') - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) - continue - case(pm_typ_is_all,pm_typ_is_par_kind,pm_typ_is_enveloped,& - pm_typ_is_vect) - call outunpack(pm_tv_arg(tv,1),varname,depth) - end select - end subroutine outunpack - end subroutine gen_unpack_routine - - - !============================================================ - ! Generate a subroutine PM__COUNTtno(X,N) to count basic - ! elements in X (including dynamic sub-elements) - ! placing result in current buffer - !============================================================ - subroutine gen_count_routine(g,tno) - type(gen_state):: g - integer,intent(in):: tno - integer(pm_ln),dimension(pm_int:pm_string):: counts - logical:: has_depth - logical:: recur - recur=iand(pm_typ_flags(g%context,tno),pm_typ_has_poly)/=0 - if(recur) call out_str(g,'RECURSIVE ') - call out_str(g,'SUBROUTINE PM__COUNT') - call out_idx(g,tno) - call out_line(g,'(X)') - call out_type(g,tno) - call out_line(g,'::X') - counts=0 - has_depth=.false. - call precount(g,tno,counts,has_depth) - call outaddcount(g,counts,0) - if(has_depth) then - call outcount(g,tno,'X',0) - endif - call out_str(g,'END SUBROUTINE PM__COUNT') - call out_idx(g,tno) - call out_new_line(g) - end subroutine gen_count_routine - - !======================================================= - ! Determine the compile-time count of each basic type - ! in type tno. Returns has_depth if there are elements - ! with dynamic run-time sizes (arrays/polymorphic types) - !======================================================= - recursive subroutine precount(g,tno,counts,has_depth) - type(gen_state):: g - integer,intent(in):: tno - integer(pm_ln),intent(inout),dimension(pm_int:pm_string):: counts - logical,intent(inout):: has_depth - integer(pm_ln),dimension(pm_int:pm_string):: counts2 - logical:: has_depth2 - type(pm_ptr):: tv,val - integer:: i - integer(pm_ln):: n - tv=pm_typ_vect(g%context,tno) - select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) - if(tno>=pm_int.and.tno<=pm_string) then - counts(tno)=counts(tno)+1 - endif - case(pm_typ_is_array) - has_depth2=.false. - call precount(g,pm_tv_arg(tv,2),counts,has_depth2) - if(pm_tv_arg(tv,3)/=pm_long.and..not.has_depth2) then - call precount(g,pm_tv_arg(tv,1),counts2,has_depth) - if(.not.has_depth) then - val=pm_typ_val(g%context,pm_tv_arg(tv,3)) - counts=counts+counts2*val%data%ln(val%offset) - endif - else - has_depth=.true. - endif - counts(pm_long)=counts(pm_long)+1 - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) - do i=1,pm_tv_numargs(tv) - call precount(g,pm_tv_arg(tv,i),counts,has_depth) - enddo - case(pm_typ_is_poly) - counts(pm_int)=counts(pm_int)+1 - has_depth=.true. - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) - continue - case default - call pm_panic("precount") - end select - end subroutine precount - - !=================================================================== - ! Code the addition of basic types counts determined by precount - ! to the counts entries in the current buffer - !=================================================================== - subroutine outaddcount(g,counts,depth) - type(gen_state):: g - integer(pm_ln),intent(inout),dimension(pm_int:pm_string):: counts - integer,intent(in):: depth - integer:: i - do i=pm_int,pm_string - if(counts(i)>0) then - call out_str(g,'PM__BUFFER%SIZEOF(') - call out_kind(g,i) - call out_str(g,')=PM__BUFFER%SIZEOF(') - call out_kind(g,i) - call out_str(g,')+') - call out_long(g,counts(i)) - if(depth>0) then - call out_simple_part(g,'*NP$N',n=depth) - endif - call out_new_line(g) - endif - enddo - end subroutine outaddcount - - !============================================================ - ! Output code to count dynamic elements of the type - ! -- static elements already counted by precount - !============================================================ - recursive subroutine outcount(g,tno,varname,depth) - type(gen_state):: g - integer,intent(in):: tno - character(len=*):: varname - integer,intent(in):: depth - type(pm_ptr):: tv,tlist,telem - integer:: i,n,tno2 - character(len=5):: ibuffer - integer(pm_ln),dimension(pm_int:pm_string):: counts - logical:: has_depth - tv=pm_typ_vect(g%context,tno) - select case(pm_tv_kind(tv)) - case(pm_typ_is_basic) - continue - case(pm_typ_is_array) - call outcount(g,pm_tv_arg(tv,2),varname//'%E2',depth) - has_depth=.false. - counts=0 - call precount(g,pm_tv_arg(tv,1),counts,has_depth) - if(has_depth) then - write(ibuffer,'(i5)') depth+1 - ibuffer=adjustl(ibuffer) - call get_vect_size(varname) - call out_simple(g,'DO IP$N=1,NP$N',n=depth+1) - call outcount(g,pm_tv_arg(tv,1),varname//'%E1%P(IP'//trim(ibuffer)//')',depth+1) - call out_line(g,'ENDDO') - else - call get_vect_size(varname) - endif - call outaddcount(g,counts,depth+1) - case(pm_typ_is_poly) - call out_line(g,'SELECT TYPE(POLYVAR=>'//varname//'%P)') - tlist=g_check_poly(g,tno) - if(.not.pm_fast_isnull(tlist)) then - n=pm_set_size(g%context,tlist) - do i=1,n - telem=pm_set_key(g%context,tlist,int(i,pm_ln)) - tno2=telem%data%i(telem%offset) - if(tno2<=pm_string) then - call out_simple(g,'TYPE IS(PM__T$S)',x=tno2) - counts=0 - call precount(g,tno2,counts,has_depth) - call outaddcount(g,counts,depth) - else - call out_simple(g,'TYPE IS(PM__T$N)',n=tno2) - call g_add_packable(g,pack_scalar,tno2) - call out_str(g,'CALL PM__COUNT') - call out_idx(g,tno2) - call out_line(g,'(POLYVAR)') - endif - enddo - endif - call out_line(g,'END SELECT') - case(pm_typ_is_struct,pm_typ_is_rec,pm_typ_is_dref) - do i=1,pm_tv_numargs(tv) - write(ibuffer,'(i5)') i - call outcount(g,pm_tv_arg(tv,i),varname//'%E'//trim(adjustl(ibuffer)),depth) - enddo - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_value) - continue - case(pm_typ_is_all,pm_typ_is_par_kind,pm_typ_is_enveloped,& - pm_typ_is_vect) - call outcount(g,pm_tv_arg(tv,1),varname,depth) - end select - contains - include 'fisnull.inc' - - subroutine get_vect_size(var) - character(len=*):: var - call out_simple(g,'NP$N=SIZE('//var//'%E1%P)',n=depth+1) - end subroutine get_vect_size - end subroutine outcount - - !======================================================== - ! Create subroutine PM__MAKE_MPI_TYPES that - ! creates all required MPI types from PM types, - ! fills global PM__MPI_TYPES - !======================================================== - subroutine gen_mpi_types(g) - type(gen_state):: g - integer:: i,j,n,nn,size,typ,maxargs,set_key(1) - type(pm_ptr):: keys,key,tv - - call out_new_line(g) - call out_line_noindent(g,'SUBROUTINE PM__MAKE_MPI_TYPES') - - size=pm_set_size(g%context,g%mpi_types) - if(size==0) then - call out_line_noindent(g,'END SUBROUTINE PM__MAKE_MPI_TYPES') - return - endif - - keys=pm_set_keys(g%context,g%mpi_types) - maxargs=0 - do i=0,size-1 - key=keys%data%ptr(keys%offset+i) - typ=abs(key%data%i(key%offset)) - !write(*,*) 'TYPE #',i,' ',trim(pm_typ_as_string(g%context,typ)) - call out_type(g,typ) - call out_str(g,'::T') - call out_idx(g,typ) - call out_line(g,'(2)') - tv=pm_typ_vect(g%context,typ) - maxargs=max(maxargs,pm_tv_numargs(tv)) - enddo - call out_simple(g,'INTEGER,DIMENSION($N):: DATATYPES,BLOCKLENGTHS',n=maxargs) - call out_simple(g,'INTEGER(MPI_ADDRESS_KIND),DIMENSION($N):: OFFSETS',n=maxargs) - call out_line(g,'INTEGER(MPI_ADDRESS_KIND):: LOWER,EXTENT') - call out_line(g,'BLOCKLENGTHS=1') - call out_simple(g,'ALLOCATE(PM__MPI_TYPES($N))',n=size) - - do i=0,size-1 - key=keys%data%ptr(keys%offset+i) - typ=abs(key%data%i(key%offset)) - call out_comment_line(g,pm_typ_as_string(g%context,typ)) - if(debug_g) then - write(*,*) 'MPI TYP>',pm_typ_as_string(g%context,typ) - endif - tv=pm_typ_vect(g%context,typ) - n=pm_tv_numargs(tv) - nn=0 - do j=1,n - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,j)),& - pm_typ_has_storage)/=0) then - call out_simple(g,'CALL MPI_GET_ADDRESS(T$N(1)%E$M,OFFSETS($M),JERROR)',& - n=typ,m=j) - nn=nn+1 - endif - enddo - do j=2,nn - call out_simple(g,'OFFSETS($N)=OFFSETS($N)-OFFSETS(1)',n=j) - enddo - call out_simple(g,'CALL MPI_GET_ADDRESS(T$N(2),EXTENT,JERROR)',n=typ) - call out_line(g,'EXTENT=EXTENT-OFFSETS(1)') - call out_line(g,'OFFSETS(1)=0') - do j=1,nn - call out_comment_line(g,pm_typ_as_string(g%context,pm_tv_arg(tv,j))) - call out_get_mpi_base_type(g,pm_tv_arg(tv,j)) - call out_simple(g,'DATATYPES($N)=JBASE',n=j) - enddo - call out_simple(g,& - 'CALL MPI_TYPE_CREATE_STRUCT($N,BLOCKLENGTHS,OFFSETS,DATATYPES,JTYPE,JERROR)',& - n=nn) - call out_line(g,'CALL MPI_TYPE_CREATE_RESIZED(JTYPE,0_MPI_ADDRESS_KIND,EXTENT,JTYPE2,JERROR)') - call out_simple(g,'PM__MPI_TYPES($N)=JTYPE2',n=i+1) - enddo - - size=pm_set_size(g%context,g%mpi_root_types) - keys=pm_set_keys(g%context,g%mpi_root_types) - do i=0,size-1 - key=keys%data%ptr(keys%offset+i) - set_key(1)=abs(key%data%i(key%offset)) - j=pm_ivect_lookup(g%context,g%mpi_types,set_key,1) - if(j<0) call pm_panic('gen_mpi_types') - call out_simple(g,'CALL MPI_TYPE_COMMIT(PM__MPI_TYPES($N),JERROR)',n=j) - enddo - - call out_line_noindent(g,'END SUBROUTINE PM__MAKE_MPI_TYPES') - end subroutine gen_mpi_types - - - !******************************************************************** - ! VARIABLE AND TYPE DEFINITIONS - !******************************************************************** - - !============================================ - ! Output definition for variable at index i - ! - in communicating proc, iscomm==.true. - !============================================ - subroutine out_var_def(g,i,iscomm) - type(gen_state):: g - integer,intent(in):: i - logical,intent(in):: iscomm - integer:: ix,flags,j,oindex - logical:: isvect - - isvect=g_var_at_index_is_a_vect(g,i) - flags=g%vardata(i)%flags - ix=abs(g%vardata(i)%index) - - if(iand(g%vardata(i)%gflags,var_is_recycled)/=0) then - return - endif - - oindex=g%vardata(i)%oindex - if(debug_g) then - write(*,*) 'VAR>>',i,oindex,' ',trim(pm_typ_as_string(g%context,g%vardata(i)%tno)) - endif - -!!$ if(g_kind(g,oindex)==v_is_basic) call out_simple(g,'!'//& -!!$ trim(pm_name_as_string(g%context,g_v1(g,oindex)))) - -!!$ call out_simple_part(g,'! idx=$N / lthis=$M '//& -!!$ trim(pm_typ_as_string(g%context,g%vardata(i)%tno)),& -!!$ n=g%vardata(i)%oindex,m=g%vardata(i)%lthis) -!!$ call out_simple_part(g,'/ flags=$N state=$M',n=g%vardata(i)%flags,m=g%vardata(i)%state) -!!$ call out_simple_part(g,'/ start=$N finish=$M',n=g%vardata(i)%start,m=g%vardata(i)%finish) -!!$ call out_simple(g,'/ end_assign=$N',n=merge(1,0,g%vardata(i)%finish_on_assign)) - - if(iand(flags,v_is_chan)/=0) then - call out_str(g,'TYPE(PM__TV') - call out_type_idx(g,g%vardata(i)%tno) - call out_str(g,'_7)') - isvect=.false. - elseif(iand(flags,v_is_array_par_vect)/=0) then - call out_str(g,'TYPE(PM__TV') - call out_type_idx(g,g%vardata(i)%tno) - call out_char(g,'_') - call out_type_idx(g,g_v1(g,oindex)) - call out_char(g,')') - else - call out_type(g,g%vardata(i)%tno) - endif - - if(iand(flags,v_is_ref+v_is_param)==v_is_ref+v_is_param) then - call out_str(g,',INTENT(INOUT)') - elseif(iand(flags,v_is_param)/=0) then - call out_str(g,',INTENT(IN)') - elseif(iand(flags,v_is_result)/=0) then - if(iand(flags,v_is_chan)/=0) then - call out_str(g,',INTENT(INOUT)') - else - call out_str(g,',INTENT(OUT)') - endif - endif - - if(iand(flags,v_is_key)/=0) call out_str(g,',OPTIONAL') - - if(isvect) then - if(iand(flags,v_is_array_par_vect+v_is_array_par_dom)/=0) then - call out_str(g,',DIMENSION(:)') - elseif(iand(flags,v_is_param+v_is_result)/=0) then - if(.not.iscomm) then - call out_str(g,',DIMENSION(:)') - else - call out_str(g,',DIMENSION(N1)') - endif - else - call out_str(g,',ALLOCATABLE,DIMENSION(:)') - endif - endif - - call out_str(g,'::') - if(ix/=0) then - call out_char_idx(g,'V',ix) - else - call out_var_name_at_index(g,i) - endif - - call out_str(g,' ! '//trim(pm_typ_as_string(g%context,g%vardata(i)%tno))) - - if(pm_opts%ftn_annotate) then - call out_simple_part(g,' idx=$N', n=oindex) - endif - - call out_new_line(g) - end subroutine out_var_def - - !=========================================== - ! Output definitions for all types in - ! typeset - !============================================ - subroutine out_type_defs(g,typeset) - type(gen_state):: g - type(pm_ptr),intent(in):: typeset - integer:: i - type(pm_ptr):: keys,key - keys=pm_set_keys(g%context,typeset) - do i=0,pm_set_size(g%context,typeset)-1 - key=keys%data%ptr(keys%offset+i) - call out_type_def(g,key%data%i(key%offset),key%data%i(key%offset+1)) - call out_new_line(g) - enddo - contains - include 'fesize.inc' - end subroutine out_type_defs - - !======================================== - ! Output type definition for PM type tno - ! - dim==0 : plain type - ! - dim==pm_long : allocatable vector - ! - dim==... : fixed length vector - !======================================== - subroutine out_type_def(g,tno,dim) - type(gen_state):: g - integer,intent(in):: tno,dim - type(pm_ptr):: tv,val - integer:: i,n,k - if(tno==0) return - if(dim>0) then - call out_comment_line(g,trim(pm_typ_as_string(g%context,tno))) - call out_str(g,'TYPE PM__TV') - call out_idx(g,tno) - call out_char_idx(g,'_',dim) - call out_new_line(g) - call out_type(g,tno) - if(dim==pm_long) then - call out_line(g,',DIMENSION(:),ALLOCATABLE::P') - else - val=pm_typ_val(g%context,dim) - call out_str(g,',DIMENSION(') - call out_const(g,val) - call out_str(g,')::P') - endif - call out_str(g,'END TYPE PM__TV') - call out_idx(g,tno) - call out_char_idx(g,'_',dim) - call out_new_line(g) - return - endif - call out_char(g,'!') - call out_comment_line(g,trim(pm_typ_as_string(g%context,tno))) - call out_str(g,'TYPE PM__T') - call out_idx(g,tno) - call out_new_line(g) - !call out_line(g,',SEQUENTIAL') - tv=pm_typ_vect(g%context,tno) - n=pm_tv_numargs(tv) - k=pm_tv_kind(tv) - if(k==pm_typ_is_array) then - call out_str(g,'TYPE(PM__TV') - call out_type_idx(g,pm_tv_arg(tv,1)) - call out_char(g,'_') - call out_type_idx(g,pm_tv_arg(tv,3)) - call out_line(g,')::E1') - call out_type(g,pm_tv_arg(tv,2)) - call out_line(g,'::E2') - elseif(k==pm_typ_is_vect) then - continue - else - do i=1,n - if(iand(pm_typ_flags(g%context,pm_tv_arg(tv,i)),& - pm_typ_has_storage)/=0) then - call out_type(g,pm_tv_arg(tv,i)) - call out_str(g,'::E') - call out_idx(g,i) - call out_new_line(g) - endif - enddo - endif - call out_str(g,'END TYPE PM__T') - call out_idx(g,tno) - call out_new_line(g) - end subroutine out_type_def - - !================================================= - ! Output the type index for a given type - ! -- type number expect for polymorphic types - !================================================ - subroutine out_type_idx(g,tno) - type(gen_state):: g - integer,intent(in):: tno - if(pm_typ_kind(g%context,tno)==pm_typ_is_poly) then - call out_idx(g,int(pm_pointer)) - else - call out_idx(g,tno) - endif - end subroutine out_type_idx - - !============================================================ - ! Output code to allocate avar to size nc - !============================================================ - recursive subroutine out_alloc_var(g,avar,nc) - type(gen_state):: g - integer,intent(in):: avar - character(len=*),intent(in):: nc - integer:: var,i,n - var=abs(avar) - select case(g_kind(g,var)) - case(v_is_group) - n=g_v1(g,var) - do i=1,n - call out_alloc_var(g,g_ptr(g,var,i),nc) - enddo - case(v_is_sub,v_is_vsub,v_is_elem,v_is_unit_elem) - write(*,*) 'v_',var - call pm_panic('out_alloc_var') - case(v_is_cove) - call out_alloc_var(g,g_v2(g,var),nc) - case(v_is_alias) - call out_alloc_var(g,g_v1(g,var),nc) - case(v_is_const,v_is_ctime_const) - continue - case default - call out_str(g,'ALLOCATE(') - call out_char_idx(g,'V',g_index(g,var)) - call out_line(g,'('//nc//'))') - end select - end subroutine out_alloc_var - - !============================================================ - ! Output code for simple operation with one output - !============================================================ - subroutine out_simple_scalar(g,str,l,n,x) - type(gen_state):: g - character(len=*),intent(in):: str - integer,intent(in):: l - integer,intent(in),optional:: n,x - integer:: arg1 - arg1=g%codes(l+comp_op_arg0+1) - if(.not.g_is_shared(g,arg1)) call gen_loop(g,l,.false.) - if(g_kind(g,arg1)/=v_is_ctime_const) then - call out_simple(g,str,l,n,x) - endif - end subroutine out_simple_scalar - - - !========================================================= - ! Return code string expanded with variable/value info - ! followed by new line - ! For expansions see out_simple_part - !========================================================= - recursive subroutine out_simple(g,str,l,n,m,x) - type(gen_state):: g - character(len=*),intent(in):: str - integer,intent(in),optional:: l,n,m,x - call out_simple_part(g,str,l,n,m,x) - call out_new_line(g) - end subroutine out_simple - - !========================================================= - ! Return code string expanded with variable/value info - ! Expansions: - ! $0 .. $9 - given argument (l must be passed) - ! $(10)... - ! $#0 .. $#9 - given argument without index - ! $#(10)... - ! $A - variable passed as x without index - ! $I - variable passed as x - ! $N - integer value passed as n - ! $M - integer value passed as m - ! $X - argument x (l must be passed) - ! $Y - argument x no index - ! $S - suffix string for pm basic type x - !========================================================= - recursive subroutine out_simple_part(g,str,l,n,m,x) - type(gen_state):: g - character(len=*),intent(in):: str - integer,intent(in),optional:: l,n,m,x - integer:: i,j,k,opt,tens - character:: c - opt=0 - k=len(str) - j=1 - do while(j<=k) - c=str(j:j) - if(c/='$') then - g%n=g%n+1 - g%linebuffer(g%n:g%n)=c - else - j=j+1 - c=str(j:j) - select case(c) - case('#') - j=j+1 - c=str(j:j) - call out_arg(g,g%codes(l+comp_op_arg0+iachar(c)-iachar('0')),arg_no_index) - case('0','1','2','3','4','5','6','7','8','9') - call out_arg(g,g%codes(l+comp_op_arg0+iachar(c)-iachar('0')),0) - case('(') - j=j+1 - c=str(j:j) - tens=iachar(c)-iachar('0') - j=j+1 - c=str(j:j) - call out_arg(g,g%codes(l+comp_op_arg0+tens*10+iachar(c)-iachar('0')),0) - j=j+1 - if(str(j:j)/=')') call pm_panic('out_simple: bad $( arg') - case('A') - call out_arg(g,x,arg_no_index) - case('I') - call out_arg(g,x,0) - - case('N') - call out_idx(g,n) - case('M') - call out_idx(g,m) - case('X') - call out_arg(g,g%codes(l+comp_op_arg0+x),0) - case('Y') - call out_arg(g,g%codes(l+comp_op_arg0+x),arg_no_index) - case('S') - call out_suffix(g,x) - case default - write(*,*) 'Bad char (',c,')' - call pm_panic('Bad char in out_simple') - end select - endif - j=j+1 - if(g%n+k-j>ftn_max_line) call out_line_break(g) - enddo - end subroutine out_simple_part - - !======================================================= - ! Output argument to a procedure call - ! - expand all arrays to two components - ! - ignore compile time constants - ! - pass channels directly - ! Options - ! arg_no_index Do not index vectors - ! arg_ix_index Index vectors with IX - ! arg_comm_arg Argument to a communicating procedure - ! arg_wrapped Argument is wrapped vector - !======================================================= - recursive subroutine out_call_arg(g,avar,opts) - type(gen_state):: g - integer,intent(in):: avar,opts - integer:: var,i,n,k,v - type(pm_ptr):: tv - var=abs(avar) - k=g_kind(g,var) - select case(k) - case(v_is_group) - select case(g_v2(g,var)) - case(v_is_array) - call out_arg(g,g_ptr(g,var,1),opts) - call out_comma(g) - call out_arg(g,g_ptr(g,var,2),opts) - case(v_is_dref,v_is_shared_dref) - n=g_v1(g,var) - if(iand(opts,arg_wrapped)/=0) then - tv=pm_typ_vect(g%context,g_type(g,var)) - call out_dref_vect_arg(g,g_ptr(g,var,1),pm_tv_arg(tv,1),opts) - call out_comma(g) - call out_call_arg(g,g_ptr(g,var,2),opts) - call out_comma(g) - do i=3,n - call out_dref_vect_arg(g,g_ptr(g,var,i),pm_tv_arg(tv,i),opts) - if(i/=n) call out_comma(g) - enddo - else - do i=1,n - call out_call_arg(g,g_ptr(g,var,i),opts) - if(i/=n) call out_comma(g) - enddo - end if - case default - n=g_v1(g,var) - do i=1,n - call out_call_arg(g,g_ptr(g,var,i),opts) - if(i/=n) call out_comma(g) - enddo - end select - case(v_is_ctime_const) - continue - case(v_is_chan_vect) - if(iand(opts,arg_comm_arg)==0) then - call out_call_arg(g,g_v1(g,var),ior(opts,arg_chan)) - else - call out_arg(g,g_v1(g,var),opts) - endif - case(v_is_vect_wrapped) - call out_call_arg(g,g_v1(g,var),ior(opts,arg_wrapped)) - case(v_is_alias) - call out_call_arg(g,g_v1(g,var),opts) - case default - if(pm_typ_kind(g%context,g_type(g,var))==pm_typ_is_array) then - call out_arg(g,var,opts) - call out_str(g,'%E1,') - call out_arg(g,var,opts) - call out_str(g,'%E2') - return - else - call out_arg(g,var,opts) - endif - end select - end subroutine out_call_arg - - !=================================================== - ! Output one element of a dref - ! - if the element is a vector it is wrapped - !=================================================== - recursive subroutine out_dref_vect_arg(g,var,tno,opts) - type(gen_state):: g - integer,intent(in):: var,tno,opts - if(pm_typ_get_mode(g%context,tno)>=sym_mirrored) then - call out_call_arg(g,var,opts) - else - call out_call_arg(g,var,ior(opts,arg_wrapped)) - endif - end subroutine out_dref_vect_arg - - !================================================ - ! Output parameter name - ! - split groups - ! - ignore compile time constants - !================================================ - recursive subroutine out_param(g,avar) - type(gen_state):: g - integer,intent(in):: avar - integer:: var,i,n,k - var=abs(avar) - k=g_kind(g,var) - select case(k) - case(v_is_group) - n=g_v1(g,var) - do i=1,n - call out_param(g,g_ptr(g,var,i)) - call out_comma(g) - enddo - case(v_is_alias,v_is_chan_vect,v_is_vect_wrapped) - call out_param(g,g_v1(g,var)) - case(v_is_ctime_const) - continue - case(v_is_cove) - call out_param(g,g_v2(g,var)) - case default - call out_arg_name(g,var,0) - end select - end subroutine out_param - - !================================================ - ! Output argument - ! opts - - ! arg_no_index Do not index vectors - ! arg_ix_index Index vectors with IX - ! arg_wrapped Argument is wrapped vector - !================================================ - recursive subroutine out_arg(g,avar,opts) - type(gen_state):: g - integer,intent(in):: avar,opts - integer:: var,i,n,k - var=abs(avar) - k=g_kind(g,var) - select case(k) - case(v_is_group) - n=g_v1(g,var) - do i=1,n - call out_arg(g,g_ptr(g,var,i),opts) - if(i/=n) call out_comma(g) - enddo - case(v_is_sub) - call out_arg(g,g_v1(g,var),opts) - call out_str(g,'%E1%P((') - call out_arg(g,g_v2(g,var),opts) - call out_str(g,')+1)') - case(v_is_vsub) - call out_arg(g,g_v1(g,var),opts) - call out_str(g,'%P((') - call out_arg(g,g_v2(g,var),opts) - call out_str(g,')+1)') - case(v_is_vect_wrapped) - call out_arg(g,g_v1(g,var),ior(opts,arg_wrapped)) - case(v_is_elem) - call out_elem(g,g_v1(g,var),g_v2(g,var),opts) - case(v_is_unit_elem) - call out_arg(g,g_v1(g,var),opts) - case(v_is_chan_vect) - call out_arg(g,g_v1(g,var),ior(opts,arg_chan)) - case(v_is_const) - call out_const(g,g%fn%data%ptr(g%fn%offset+2+g_v1(g,var))) - case(v_is_ctime_const) - call out_const(g,g%fn%data%ptr(g%fn%offset+2+g_v1(g,var))) - case(v_is_cove) - call out_arg(g,g_v2(g,var),opts) - case(v_is_alias) - call out_arg(g,g_v1(g,var),opts) - case default - call out_arg_name(g,var,opts) - if(iand(opts,arg_chan)/=0) then - call out_str(g,'%P') - call out_loop_index(g,var,opts) - elseif(.not.g_flags_set(g,var,v_is_chan)) then - call out_loop_index(g,var,opts) - endif - end select - end subroutine out_arg - - !============================================= - ! Output variable name associated with var - !============================================= - subroutine out_arg_name(g,var,opt) - type(gen_state):: g - integer,intent(in):: var,opt - integer:: i - if(g_var_is_merged(g,var)) then - call out_char_idx(g,'V',g_index(g,var)) - else - if(g%varindex(var)==0) then - write(*,*) 'var=',var,'kind=',g_kind(g,var) - call pm_panic('out_arg_name') - endif - i=g%varindex(var) - call out_var_name_at_index(g,i) - endif - end subroutine out_arg_name - - !============================================================== - ! If variable v is a vector than append the required index - ! - usually the index variable for the associated parallel - ! context - ! - can also be IX for opt==arg_ix_index - ! - can also be IDO for use inside op_do_at - ! - can also be 1 outside of active loop for given context - !============================================================= - subroutine out_loop_index(g,v,opt) - type(gen_state):: g - integer,intent(in):: v,opt - integer:: i,lthis - - if(g_is_a_vect(g,v)) then - lthis=g_lthis(g,v) - if(iand(opt,arg_ix_index)/=0.and.g_is_vect(g,v)) then - call out_str(g,'(IX)') - elseif(iand(opt,arg_no_index+arg_wrapped)==0.or.lthis/=g%lthis.and.iand(opt,arg_wrapped)==0) then - if(lthis==g%lalt) then - call out_str(g,'(IDO)') - elseif(.not.g%lstack(lthis)%loop_active.or.lthis==0) then - call out_str(g,'(1)') - else - call out_char(g,'(') - call out_char_idx(g,'I',lthis) - call out_char(g,')') - endif - endif - if(g_flags_set(g,v,v_is_array_par_vect)) then - call out_str(g,'%P') - endif - endif - end subroutine out_loop_index - - !==================================================== - ! Output var.n as var%n - !==================================================== - recursive subroutine out_elem(g,var,n,opts) - type(gen_state):: g - integer,intent(in):: var,n,opts - call out_arg(g,var,opts) - call out_char(g,'%') - call out_char_idx(g,'E',n) - end subroutine out_elem - - !==================================================== - ! Output variable at given index - !==================================================== - subroutine out_var_at_index(g,i) - type(gen_state):: g - integer,intent(in):: i - integer:: j - j=abs(g%vardata(i)%index) - if(j/=0) then - call out_char_idx(g,'V',j) - else - call out_var_name_at_index(g,i) - endif - end subroutine out_var_at_index - - !==================================================== - ! Output constant value associated with variable v - !==================================================== - subroutine out_const(g,v) - type(gen_state):: g - type(pm_ptr),intent(in):: v - character(len=max_line):: buffer - integer:: vk,i,n - buffer=' ' - vk=pm_fast_vkind(v) - select case(vk) - case(pm_int) - write(buffer,*) v%data%i(v%offset) - case(pm_long) - write(buffer,*) v%data%ln(v%offset) - call append('_PM__LN') - case(pm_longlong) - write(buffer,*) v%data%lln(v%offset) - call append('_PM__LN') - case(pm_int8) - write(buffer,*) v%data%i8(v%offset) - call append('_PM__I8') - case(pm_int16) - write(buffer,*) v%data%i16(v%offset) - call append('_PM__I16') - case(pm_int32) - write(buffer,*) v%data%i32(v%offset) - call append('_PM__I32') - case(pm_int64) - write(buffer,*) v%data%i64(v%offset) - call append('_PM__I64') - case(pm_single) - write(buffer,*) v%data%r(v%offset) - case(pm_double) - write(buffer,*) v%data%d(v%offset) - call append('_PM__D') - case(pm_single_complex) - write(buffer,*) v%data%c(v%offset) - case(pm_double_complex) - write(buffer,*) '(',real(v%data%dc(v%offset)) - call append('_PM__D,') - write(buffer(len_trim(buffer)+1:),*) imag(v%data%dc(v%offset)) - call append('_PM__D)') - case(pm_logical) - if(v%data%l(v%offset)) then - buffer='.TRUE.' - else - buffer='.FALSE.' - endif - case(pm_string) - if(g%n+20>ftn_max_line) call out_line_break(g) - n=pm_fast_esize(v) - g%linebuffer(g%n+1:g%n+12)='PM__STRVAL("' - g%n=g%n+12 - do i=0,n-1 - if(g%n>ftn_max_line-5) call out_line_break(g) - g%n=g%n+1 - g%linebuffer(g%n:g%n)=v%data%s(v%offset+i) - enddo - g%linebuffer(g%n+1:g%n+2)='")' - g%n=g%n+2 - return - case(0:pm_null) - return - end select - buffer=adjustl(buffer) - n=len_trim(buffer) - if(g%n+n>ftn_max_line) then - call out_line_break(g) - endif - g%linebuffer(g%n+1:g%n+1)='(' - g%linebuffer(g%n+2:g%n+n+1)=buffer(1:n) - g%linebuffer(g%n+n+2:g%n+n+2)=')' - g%n=g%n+n+2 - contains - include 'fvkind.inc' - include 'fesize.inc' - - subroutine append(c) - character(len=*),intent(in):: c - integer:: m - m=len_trim(buffer) - buffer(m+1:m+len(c))=c - end subroutine append - - end subroutine out_const - - !=========================================== - ! Output PM type typ as a Fortran type - !=========================================== - subroutine out_type(g,typ) - type(gen_state):: g - integer,intent(in):: typ - type(pm_ptr):: tv - integer:: tno - tno=pm_typ_strip_to_basic(g%context,typ) - select case(tno) - case(pm_int) - call out_str(g,'INTEGER') - case(pm_long) - call out_str(g,'INTEGER(PM__LN)') - case(pm_longlong) - call out_str(g,'INTEGER(PM__LLN)') - case(pm_int8) - call out_str(g,'INTEGER(PM__I8)') - case(pm_int16) - call out_str(g,'INTEGER(PM__I16)') - case(pm_int32) - call out_str(g,'INTEGER(PM__I32)') - case(pm_int64) - call out_str(g,'INTEGER(PM__I64)') - case(pm_single) - call out_str(g,'REAL') - case(pm_double) - call out_str(g,'REAL(PM__D)') - case(pm_single_complex) - call out_str(g,'COMPLEX') - case(pm_double_complex) - call out_str(g,'COMPLEX(PM__D)') - case(pm_logical) - call out_str(g,'LOGICAL') - case(pm_string) - call out_str(g,'CHARACTER(LEN=1)') - case(pm_string_type) - call out_str(g,'TYPE(PM__STR)') - case(pm_pointer,pm_poly_type) - call out_str(g,'TYPE(PM__POLY)') - case default - tv=pm_typ_vect(g%context,tno) - if(pm_tv_kind(tv)==pm_typ_is_poly) then - call out_str(g,'TYPE(PM__POLY)') - else - call out_str(g,'TYPE(PM__T') - call out_idx(g,tno) - call out_char(g,')') - endif - end select - end subroutine out_type - - !=========================================== - ! Output a kind (integer enum) associated with - ! basic type tno - !=========================================== - subroutine out_kind(g,tno) - type(gen_state):: g - integer,intent(in):: tno - select case(tno) - case(pm_int) - call out_str(g,'PM__INT') - case(pm_long) - call out_str(g,'PM__LONG') - case(pm_longlong) - call out_str(g,'PM__LONGLONG') - case(pm_int8) - call out_str(g,'PM__INT8') - case(pm_int16) - call out_str(g,'PM__INT16') - case(pm_int32) - call out_str(g,'PM__INT32') - case(pm_int64) - call out_str(g,'PM__INT64') - case(pm_single) - call out_str(g,'PM__SINGLE') - case(pm_double) - call out_str(g,'PM__DOUBLE') - case(pm_single_complex) - call out_str(g,'PM__SINGLE_COMPLEX') - case(pm_double_complex) - call out_str(g,'PM__DOUBLE_COMPLEX') - case(pm_logical) - call out_str(g,'PM__LOGICAL') - end select - end subroutine out_kind - - !=========================================== - ! Output a standard suffix associated with - ! basic type tno - !=========================================== - subroutine out_suffix(g,tno) - type(gen_state):: g - integer,intent(in):: tno - select case(tno) - case(pm_int) - call out_str(g,'I') - case(pm_long) - call out_str(g,'LN') - case(pm_longlong) - call out_str(g,'LLN') - case(pm_int8) - call out_str(g,'I8') - case(pm_int16) - call out_str(g,'I16') - case(pm_int32) - call out_str(g,'I32') - case(pm_int64) - call out_str(g,'I64') - case(pm_single) - call out_str(g,'R') - case(pm_double) - call out_str(g,'D') - case(pm_single_complex) - call out_str(g,'C') - case(pm_double_complex) - call out_str(g,'DC') - case(pm_logical) - call out_str(g,'L') - end select - end subroutine out_suffix - - !=========================================== - ! Output code to place the MPI type that - ! corresponds to tno in JBASE - !========================================== - subroutine out_get_mpi_base_type(g,tno) - type(gen_state):: g - integer,intent(in):: tno - integer:: j - call out_str(g,'JBASE=') - select case(tno) - case(pm_int) - call out_line(g,'MPI_INTEGER') - case(pm_long) - call out_line(g,'MPI_AINT') - case(pm_longlong) - call out_line(g,'MPI_OFFSET') - case(pm_int8) - call out_line(g,'MPI_INTEGER1') - case(pm_int16) - call out_line(g,'MPI_INTEGER2') - case(pm_int32) - call out_line(g,'MPI_INTEGER4') - case(pm_int64) - call out_line(g,'MPI_INTEGER8') - case(pm_single) - call out_line(g,'MPI_REAL') - case(pm_double) - call out_line(g,'MPI_DOUBLE_PRECISION') - case(pm_single_complex) - call out_line(g,'MPI_COMPLEX') - case(pm_double_complex) - call out_line(g,'MPI_DOUBLE_COMPLEX') - case default - j=add_mpi_type(g,tno) - call out_simple(g,'PM__MPI_TYPES($N)',n=j) - end select - end subroutine out_get_mpi_base_type - - !============================================= - ! Add to the set of mpi composite types - ! that will need to be generated - !============================================== - recursive function add_mpi_type(g,typ) result(j) - type(gen_state):: g - integer,intent(in):: typ - integer:: j - type(pm_ptr):: tv - integer:: i,tno - if(debug_g) then - write(*,*) 'ADD MPI TYPE',trim(pm_typ_as_string(g%context,typ)) - endif - tno=pm_typ_strip_to_basic(g%context,typ) - if(tno<=pm_string) return - j=check_set(tno) - if(j>0) return - j=add_to_root_set(tno) - tv=pm_typ_vect(g%context,tno) - select case(pm_tv_kind(tv)) - case(pm_typ_is_struct,pm_typ_is_rec) - do i=1,pm_tv_numargs(tv) - j=add_mpi_type(g,pm_tv_arg(tv,i)) - enddo - j=add_to_set(tno) - case(pm_typ_is_poly) - call pm_panic('add_mpi_type: poly type') - case(pm_typ_is_array) - if(pm_tv_arg(tv,3)==pm_long) then - call pm_panic('add_mpi_type: var length array') - else - j=add_mpi_type(g,pm_tv_arg(tv,1)) - j=add_mpi_type(g,pm_tv_arg(tv,2)) - j=add_to_set(tno) - endif - case default - write(*,*) 'Type',pm_typ_as_string(g%context,tno),' kind ',pm_tv_kind(tv) - call pm_panic('add_mpi_type') - j=0 - end select - contains - - function check_set(tno) result(j) - integer,intent(in):: tno - integer:: j - integer:: key(1) - key(1)=tno - j=pm_ivect_lookup(g%context,g%mpi_types,key,1) - end function check_set - - function add_to_set(tno) result(j) - integer,intent(in):: tno - integer:: j,key(1) - key(1)=tno - j=pm_iset_add(g%context,g%mpi_types,key,1) - end function add_to_set - - function check_root_set(tno) result(j) - integer,intent(in):: tno - integer:: j - integer:: key(1) - key(1)=tno - j=pm_ivect_lookup(g%context,g%mpi_root_types,key,1) - end function check_root_set - - function add_to_root_set(tno) result(j) - integer,intent(in):: tno - integer:: j,key(1) - key(1)=tno - j=pm_iset_add(g%context,g%mpi_root_types,key,1) - end function add_to_root_set - - end function add_mpi_type - - !========================================= - ! Output given character followed by an - ! integer index - !========================================= - subroutine out_char_idx(g,ltr,idx) - type(gen_state):: g - integer,intent(in):: idx - character,intent(in):: ltr - integer:: i,j - if(idx<0) call pm_panic('out_char_idx') - if(g%n>ftn_max_line-ftn_max_name) & - call out_line_break(g) - g%n=g%n+1 - g%linebuffer(g%n:g%n)=ltr - i=idx - j=10 - do while(j<=i) - j=j*10 - end do - j=j/10 - do while(j>0) - g%n=g%n+1 - g%linebuffer(g%n:g%n)=& - achar(iachar('0')+i/j) - i=mod(i,j) - j=j/10 - enddo - end subroutine out_char_idx - - !========================================= - ! Output integer index - !========================================= - subroutine out_idx(g,idx) - type(gen_state):: g - integer,intent(in):: idx - integer:: i,j - if(g%n>ftn_max_line-ftn_max_name) & - call out_line_break(g) - i=idx - j=10 - do while(j<=i) - j=j*10 - end do - j=j/10 - do while(j>0) - g%n=g%n+1 - g%linebuffer(g%n:g%n)=& - achar(iachar('0')+i/j) - i=mod(i,j) - j=j/10 - enddo - end subroutine out_idx - - !========================================= - ! Output long integer number - !========================================= - subroutine out_long(g,idx) - type(gen_state):: g - integer(pm_ln),intent(in):: idx - integer(pm_ln):: i,j - if(g%n>ftn_max_line-ftn_max_name) & - call out_line_break(g) - i=idx - j=10 - do while(j<=i) - j=j*10 - end do - j=j/10 - do while(j>0) - g%n=g%n+1 - g%linebuffer(g%n:g%n)=& - achar(iachar('0')+i/j) - i=mod(i,j) - j=j/10 - enddo - g%linebuffer(g%n+1:g%n+7)='_PM__LN' - g%n=g%n+7 - end subroutine out_long - - !========================================= - ! Output given string as a complete line - !========================================= - subroutine out_line(g,str) - type(gen_state):: g - character(len=*):: str - call out_str(g,str) - call out_new_line(g) - end subroutine out_line - - !========================================= - ! Output comment line with text str - !========================================= - subroutine out_comment_line(g,str) - type(gen_state):: g - character(len=*):: str - call out_new_line(g) - call out_char(g,'!') - call out_char(g,' ') - if(len(str)>ftn_max_line-5) then - call out_str(g,str(1:ftn_max_line-5)) - else - call out_str(g,str) - endif - call out_new_line(g) - end subroutine out_comment_line - - !================================== - ! Output a given string - !================================== - subroutine out_str(g,str) - type(gen_state):: g - character(len=*):: str - integer:: m - m=len(str) - if(g%n+m>ftn_max_line) call out_line_break(g) - if(g%n+m>ftn_max_line) call pm_panic('line too long') - g%linebuffer(g%n+1:g%n+m)=str - g%n=g%n+m - end subroutine out_str - - - !========================= - ! Output given character - !========================= - subroutine out_char(g,str) - type(gen_state):: g - character(len=1):: str - if(g%n+1>ftn_max_line) call out_line_break(g) - g%n=g%n+1 - g%linebuffer(g%n:g%n)=str - end subroutine out_char - - !=============================================== - ! Output comma providing last character was - ! not a comma or open parenthesis - !================================================ - subroutine out_comma(g) - type(gen_state):: g - if(g%linebuffer(g%n:g%n)/=','& - .and.g%linebuffer(g%n:g%n)/='(') call out_char(g,',') - end subroutine out_comma - - !=============================================== - ! Output close brackets - removing any trailing - ! comma - !================================================ - subroutine out_close(g) - type(gen_state):: g - if(g%linebuffer(g%n:g%n)/=',') then - g%n=g%n+1 - if(g%n>ftn_max_line) call out_line_break(g) - endif - g%linebuffer(g%n:g%n)=')' - end subroutine out_close - - !============================== - ! Start a new line - !============================== - subroutine out_new_line(g) - type(gen_state):: g - g%line_breaks=0 - write(g%outunit,'(A)') g%linebuffer(1:g%n) - g%linebuffer(1:2)=' ' - g%n=2 - end subroutine out_new_line - - !================================== - ! Start a new continuation line - !================================== - subroutine out_line_break(g) - type(gen_state):: g - g%line_breaks=g%line_breaks+1 - if(g%line_breaks>=pm_opts%ftn_lines) then - call pm_panic('Program too complex - generated Fortran subexpression too long') - endif - write(g%outunit,'(A,"&")') g%linebuffer(1:g%n) - g%n=1 - g%linebuffer(1:1)='&' - end subroutine out_line_break - - !==================================================== - ! Output the start of a line with no starting indent - !==================================================== - subroutine out_str_noindent(g,str) - type(gen_state):: g - character(len=*):: str - g%linebuffer=str - g%n=len_trim(g%linebuffer) - end subroutine out_str_noindent - - !====================================== - ! Output a line with no starting indent - !====================================== - subroutine out_line_noindent(g,str) - type(gen_state):: g - character(len=*):: str - g%line_breaks=0 - write(g%outunit,'(A)') str - g%linebuffer(1:1)=' ' - g%n=1 - end subroutine out_line_noindent - - - !========================================================= - ! Output variable name for the given index - !========================================================= - subroutine out_var_name_at_index(g,i) - type(gen_state):: g - integer,intent(in):: i - character(len=ftn_max_name-8):: name - call out_check_name_has_space(g) - call out_char_idx(g,'X',i) - if(pm_opts%ftn_name_vars.or.& - pm_opts%ftn_name_params.and.& - iand(g%vardata(i)%flags,v_is_param)/=0) then - call out_ftn_name(g,g%vardata(i)%name) - endif - end subroutine out_var_name_at_index - - !========================================================= - ! Output Fortran name contribution for a PM name - !========================================================= - subroutine out_ftn_name(g,name) - type(gen_state):: g - integer,intent(in):: name - integer:: n - character(len=ftn_max_name-8):: name_str - n=pm_name_stem(g%context,name) - if(n>num_sym) then - name_str=pm_name_as_string(g%context,n) - call out_char(g,'_') - call out_str(g,trim(name_str)) - endif - end subroutine out_ftn_name - - !========================================================= - ! Check if there is space on the current line for a name - ! - if not, start new continuation line - !========================================================= - subroutine out_check_name_has_space(g) - type(gen_state):: g - if(g%n+ftn_max_name>ftn_max_line) call out_line_break(g) - end subroutine out_check_name_has_space - - !********************************************************** - ! SERVICE ROUTINES (VARIABLES) - !********************************************************** - - !======================================================== - ! Get kind of variable v - !======================================================== - function g_kind(g,n) result(kind) - type(gen_state),intent(inout):: g - integer,intent(in):: n - integer:: kind - integer:: info - info=g%vars(abs(n)) - kind=iand(info,cvar_flag_mask) - end function g_kind - - !======================================================== - ! Get first value associated with variable v - !======================================================== - function g_v1(g,n) result(v1) - type(gen_state),intent(inout):: g - integer,intent(in):: n - integer:: v1 - integer:: info - info=g%vars(abs(n)) - v1=info/cvar_flag_mult - end function g_v1 - - !======================================================== - ! Get second value associated with variable v - !======================================================== - function g_v2(g,n) result(v2) - type(gen_state),intent(inout):: g - integer,intent(in):: n - integer:: v2 - integer:: info - info=g%vars(abs(n)+1) - v2=info/cvar_flag_mult - end function g_v2 - - - !======================================================== - ! Set second value associated with variable v - !======================================================== - subroutine g_set_v2(g,n,v) - type(gen_state),intent(inout):: g - integer,intent(in):: n,v - g%vars(abs(n)+1)=v*cvar_flag_mult - end subroutine g_set_v2 - - !======================================================== - ! Get type associated with variable v - !======================================================== - function g_type(g,n) result(typ) - type(gen_state),intent(inout):: g - integer,intent(in):: n - integer:: typ - integer:: info - info=g%vars(abs(n)+2) - typ=info/cvar_flag_mult - end function g_type - - !======================================================== - ! Get pointer #i associated with variable v - !======================================================== - function g_ptr(g,n,i) result(v) - type(gen_state),intent(inout):: g - integer,intent(in):: n,i - integer:: v - if(pm_debug_checks) then - if(g_kind(g,n)/=v_is_group) call pm_panic('g_ptr - kind') - if(g_v1(g,n)pm_init_gc() - call pm_init_compilation - call pm_init_names(context) - call init_typ(context) - - ! ****** Command line ***** - - reg=>pm_register(context,'main',ve) - - if(pm_get_cl_count()==1) then - call pm_get_cl_arg(1,str) - out_debug_files=.false. - else if(pm_get_cl_count()==2) then - call pm_get_cl_arg(1,str) - if(str/='-d') call usage() - out_debug_files=pm_main_process - call pm_get_cl_arg(2,str) - else - call usage() - endif - - call pm_module_filename(str) - !write(*,*) 'Input file:',trim(str) - if(.not.pm_file_exists(str)) call usage() - - ! ************* Parser ******************** - if(pm_debug_level>1) write(*,*) 'PARSING>>' - - ! Parse sytem module - call init_parser(parser,context) - call sysdefs(parser) - call pm_gc(context,.false.) - if(out_debug_files) then - open(unit=9,file='sysmod.dmp') - call dump_module(context,9,parser%sysmodl) - close(9) - endif - - ! Parse other modules - name=pm_name_entry(context,trim(str)) - call new_modl(parser,name) - root=parser%modls - do - parser%modl=parser%modls - if(pm_fast_isnull(parser%modl)) exit - parser%modls=parser%modl%data%ptr(& - parser%modl%offset+modl_link) - if(pm_fast_isnull(parser%modl)) exit - str=' ' - call pm_name_string(context,& - int(get_modl_name(parser%modl),pm_p),str) - call pm_module_filename(str) - call pm_open_file(pm_comp_file_unit,str,ok) - if(.not.ok) then - if(pm_main_process) then - write(*,*) 'Cannot open: '//trim(str) - call pm_stop('Compilation terminated') - endif - endif - parser%iunit=pm_comp_file_unit - parser%lineno=0 - call next_line(parser) - call scan(parser) - call decl(parser) - close(pm_comp_file_unit) - call pm_gc(context,.false.) - if(out_debug_files) then - open(unit=9,file=trim(str)//'.dmp') - call dump_module(context,9,parser%modl) - close(9) - endif - enddo - if(parser%error_count>0) call pm_stop('Parse errors') - call pm_gc(context,.false.) - - ! ***************Linker******************* - if(pm_debug_level>1) write(*,*) 'LINKING>>' - call link_includes(context,parser%modl_dict) - call pm_gc(context,.false.) - if(out_debug_files) then - open(unit=pm_comp_file_unit,file='linker.out') - call dump_module(context,pm_comp_file_unit,root) - close(pm_comp_file_unit) - endif - - !************ Code generation *************** - if(pm_debug_level>1) write(*,*) 'CODE GENERATION>>' - prog=root%data%ptr(root%offset+modl_stmts) - if(pm_fast_isnull(prog)) call pm_stop('No program defined to run') - call init_coder(context,coder) - call trav_prog(coder,prog) - if(out_debug_files) then - open(unit=pm_comp_file_unit,file='codegen.out') - call qdump_code_tree(coder,pm_null_obj,pm_comp_file_unit,coder%vstack(1),1) - call dump_sigs(coder,pm_comp_file_unit) - close(pm_comp_file_unit) - - endif - if(coder%num_errors>0) call pm_stop('Code generation errors') - - ! *********** Type Inference ********************* - if(pm_debug_level>1) write(*,*) 'TYPE INFERENCE>>' - call prc_prog(coder) - if(out_debug_files) then - open(unit=pm_comp_file_unit,file='infer.out') - call dump_code_tree(coder,pm_null_obj,pm_comp_file_unit,coder%vstack(1),1) - call dump_res_sigs(coder,pm_comp_file_unit) - close(pm_comp_file_unit) - endif - if(coder%num_errors>0) call pm_stop('Type inference errors') - - !**************** Backend ********************** - if(pm_debug_level>1) write(*,*) 'FINAL STAGE>>' - call init_fs(context,fs,coder%proc_cache) - open(unit=pm_comp_file_unit,file='pmout.f90') - fs%outunit=pm_comp_file_unit - call finalise_prog(fs,coder%vstack(1)) - close(unit=pm_comp_file_unit) - if(coder%num_errors>0) call pm_stop('Errors in final coding stage') -contains - - include 'fisnull.inc' - include 'fnewnc.inc' - - subroutine usage() - if(pm_main_process) then - write(*,*) 'Usage: pm [-d] root_module_name' - write(*,*) 'Module name should not have .pmm suffix' - write(*,*) 'Option -d outputs intermediate compilation for debug' - endif - call pm_stop(' ') - end subroutine usage - -end program pm diff --git a/src/cnodes.f90 b/src/cnodes.f90 new file mode 100644 index 0000000..5eec820 --- /dev/null +++ b/src/cnodes.f90 @@ -0,0 +1,918 @@ +! +! PM (Parallel Models) Programming Language +! +! Released under the MIT License (MIT) +! +! Copyright (c) Tim Bellerby, 2024 +! +! Permission is hereby granted, free of charge, to any person obtaining a copy +! of this software and associated documentation files (the "Software"), to deal +! in the Software without restriction, including without limitation the rights +! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is +! furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in +! all copies or substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +! THE SOFTWARE. + +!================================================ +! Middle-level Intermediate representation +!------------------------------------------------ +! The structure is built of cnodes: +! proc - user defined procedure +! builtin - intrinsic (built-in) procedure +! cblock - list of calls +! call - either linked to a signature +! (list of argument types and procedures) +! or flagged as a "special" call +! - argument list refers to var, const, and +! cblock cnodes +! - control stuctures = calls with cblock args +! var - vars and runtime consts +! const - literal constants +!================================================ + +module pm_cnodes + + use pm_kinds + use pm_sysdep + use pm_compbase + use pm_memory + use pm_hash + use pm_options + use pm_lib + use pm_symbol + use pm_types + use pm_ast + + implicit none + + ! Debug cnode operations + logical,parameter:: debug_cnodes=.true. + + ! Magic number for code tree nodes + integer,parameter:: cnode_magic_no=10456_pm_p + + ! Offsets common to all cnode structures + integer,parameter:: cnode_magic=0 + integer,parameter:: cnode_kind=1 + integer,parameter:: cnode_modl_name=2 + integer,parameter:: cnode_lineno=3 + integer,parameter:: cnode_charno=4 + integer,parameter:: cnode_args=5 + + ! Types of cnode structure + integer,parameter:: cnode_is_cblock=1 + integer,parameter:: cnode_is_var=2 + integer,parameter:: cnode_is_const=3 + integer,parameter:: cnode_is_call=4 + integer,parameter:: cnode_is_arglist=5 + integer,parameter:: cnode_is_builtin=6 + integer,parameter:: cnode_is_proc=7 + integer,parameter:: cnode_is_resolved_proc=8 + integer,parameter:: cnode_is_arg_constraint=9 + integer,parameter:: cnode_is_par_constraint=10 + integer,parameter:: cnode_is_type_constraint=11 + integer,parameter:: cnode_is_any_sig=12 + integer,parameter:: cnode_is_autoconv_sig=13 + integer,parameter:: cnode_is_changelist=14 + integer,parameter:: cnode_is_callsig=15 + integer,parameter:: cnode_num_kinds=15 + + ! Offsets into cblock cnodes + integer,parameter:: cblock_parent=cnode_args+0 + integer,parameter:: cblock_first_var=cnode_args+1 + integer,parameter:: cblock_last_var=cnode_args+2 + integer,parameter:: cblock_first_call=cnode_args+3 + integer,parameter:: cblock_last_call=cnode_args+4 + integer,parameter:: cblock_sym=cnode_args+5 + integer,parameter:: cblock_start=cnode_args+6 + integer,parameter:: cblock_flags=cnode_args+7 + integer,parameter:: cblock_index=cnode_args+8 + integer,parameter:: cblock_last_loop_call=cnode_args+9 + integer,parameter:: cblock_var_inits=cnode_args+10 + integer,parameter:: cblock_node_size=11 + + ! Flags for cblocks + integer,parameter:: cblock_is_comm=1 + integer,parameter:: cblock_is_open=2 + + ! Offsets into call cnodes + integer,parameter:: call_args=cnode_args+0 + integer,parameter:: call_keys=cnode_args+1 + integer,parameter:: call_parent=cnode_args+2 + integer,parameter:: call_sig=cnode_args+3 + integer,parameter:: call_flags=cnode_args+4 + integer,parameter:: call_link=cnode_args+5 + integer,parameter:: call_back_link=cnode_args+6 + integer,parameter:: call_nret=cnode_args+7 + integer,parameter:: call_key_names=cnode_args+8 + integer,parameter:: call_index=cnode_args+9 + integer,parameter:: call_var=cnode_args+10 + integer,parameter:: call_amp=cnode_args+11 + integer,parameter:: call_node_size=12 + + ! Offsets into var cnodes + integer,parameter:: var_parent=cnode_args+0 + integer,parameter:: var_name=cnode_args+1 + integer,parameter:: var_flags=cnode_args+2 + integer,parameter:: var_link=cnode_args+3 + integer,parameter:: var_index=cnode_args+4 + integer,parameter:: var_lex_scope = cnode_args + 5 + integer,parameter:: var_node_size=6 + integer,parameter:: var_extra_info=cnode_args+6 + + ! Flags for var cnodes + integer,parameter:: var_is_var=1 + integer,parameter:: var_is_ref=2 + integer,parameter:: var_is_param=4 + integer,parameter:: var_is_shadowed=16 + integer,parameter:: var_is_imported=32 + integer,parameter:: var_is_accessed=64 + integer,parameter:: var_is_changed=128 + integer,parameter:: var_is_multi_access=256 + integer,parameter:: var_is_key=512 + integer,parameter:: var_is_varg=1024 + integer,parameter:: var_is_par_var=2048 + integer,parameter:: var_is_maybe_not_private=4096 + integer,parameter:: var_is_where=8192 + integer,parameter:: var_is_reference=16384 + + ! Offsets into proc & builtin nodes + integer,parameter:: pr_ptype=cnode_args+0 + integer,parameter:: pr_rtype=cnode_args+1 + integer,parameter:: pr_nargs=cnode_args+2 + integer,parameter:: pr_nret=cnode_args+3 + integer,parameter:: pr_flags=cnode_args+4 + integer,parameter:: pr_amps=cnode_args+5 + integer,parameter:: pr_name=cnode_args+6 + + ! Offets into proc nodes only + integer,parameter:: pr_cblock=cnode_args+7 + integer,parameter:: pr_max_index=cnode_args+8 + integer,parameter:: pr_recurse=cnode_args+9 + integer,parameter:: pr_id=cnode_args+10 + integer,parameter:: pr_ncalls=cnode_args+11 + integer,parameter:: pr_keys=cnode_args+12 + integer,parameter:: pr_keycall=cnode_args+13 + integer,parameter:: pr_argcall=cnode_args+14 + integer,parameter:: pr_when= cnode_args+15 + integer,parameter:: pr_whenvar= cnode_args+16 + integer,parameter:: pr_node_size=17 + + ! Offsets into builtin nodes only + integer,parameter:: bi_opcode=cnode_args+7 + integer,parameter:: bi_opcode2=cnode_args+8 + integer,parameter:: bi_id=cnode_args+9 + integer,parameter:: bi_node_size=10 + + ! Special signatures + integer,parameter:: sp_sig_in_process=-1_pm_p + integer,parameter:: sp_sig_recursive=-2_pm_p + integer,parameter:: sp_sig_break=-3_pm_p + integer,parameter:: sp_sig_link=-4_pm_p + integer,parameter:: sp_sig_dup=-5_pm_p + integer,parameter:: sp_sig_noop=-6_pm_p + integer,parameter:: sp_sig_setval=-7_pm_p + + integer,parameter:: sp_sig_deactivated=-huge(1) + + ! Access codes + ! Note - if change access_kind then need to + ! check for and change any %data%i8 accesses + ! in bprop routines + integer,parameter:: access_kind=pm_i8 + integer(pm_p),parameter:: access_pm_type=pm_int8 + integer(access_kind),parameter:: access_deactivated_call=-1 + integer(access_kind),parameter:: access_is_var=1 + integer(access_kind),parameter:: access_used_ever=2 + integer(access_kind),parameter:: access_used_now=4 + integer(access_kind),parameter:: access_holds_result=8 + integer(access_kind),parameter:: access_everything=& + access_is_var+access_used_ever+access_used_now + +contains + + !================================= + ! Check cnode (debugging) + !================================= + subroutine check_cnode(ptr,n) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer(pm_p):: m + if(.not.pm_fast_vkind(ptr)==pm_pointer) then + write(*,*) 'vKind=',ptr%data%vkind + call pm_panic('cnode not ptr') + endif + if(ptr%data%ptr(ptr%offset)%offset/=cnode_magic_no) then + call pm_panic('bad cnode magic no') + endif + m=ptr%data%ptr(ptr%offset+1)%offset + if(m<1.or.m>cnode_num_kinds) & + call pm_panic('cnode bad kind') + if(n<0.or.n>pm_fast_esize(ptr)) & + call pm_panic('bad cnode offset') + contains + include 'fvkind.inc' + include 'fesize.inc' + end subroutine check_cnode + + !========================================== + ! Get argument n from cnode + !========================================== + function cnode_arg(ptr,n) result(val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + type(pm_ptr):: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+cnode_args+n-1) + end function cnode_arg + + !====================================== + ! Get element n from cnode + !====================================== + function cnode_get(ptr,n) result(val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + type(pm_ptr):: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+n) + end function cnode_get + + !==================================== + ! Set element n of cnode + !==================================== + subroutine cnode_set(context,ptr,n,val) + type(pm_context),pointer:: context + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + type(pm_ptr),intent(in):: val + if(debug_cnodes) call check_cnode(ptr,n) + call pm_ptr_assign(context,ptr,int(n,pm_ln),val) + end subroutine cnode_set + + ! ======================================== + ! Get element n from cnode as a number + !========================================= + function cnode_get_num(ptr,n) result(val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer:: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+n)%offset + end function cnode_get_num + + !============================================ + ! Module name for a cnode + !============================================ + function cnode_module_name(ptr) result(name) + type(pm_ptr),intent(in):: ptr + integer:: name + name=cnode_get_num(ptr,cnode_modl_name) + end function cnode_module_name + + !============================================ + ! Get argument n from cnode as a number + !============================================ + function cnode_num_arg(ptr,n) result(val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer:: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+n+cnode_args-1)%offset + end function cnode_num_arg + + !========================================= + ! Get element n from cnode as a name + !========================================= + function cnode_get_name(ptr,n) result(val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer:: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+n)%offset + end function cnode_get_name + + !========================================== + ! Set element n in cnode to a new number + ! (must be number already) + !========================================== + subroutine cnode_set_num(ptr,n,val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer,intent(in):: val + if(debug_cnodes) call check_cnode(ptr,n) + ptr%data%ptr(ptr%offset+n)%offset=val + end subroutine cnode_set_num + + !========================================== + ! Increment argument n from cnode + !========================================== + subroutine cnode_incr_num(ptr,n,val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer,intent(in):: val + if(debug_cnodes) call check_cnode(ptr,n) + ptr%data%ptr(ptr%offset+n)%offset=& + ptr%data%ptr(ptr%offset+n)%offset+val + end subroutine cnode_incr_num + + !============================================== + ! Set given flags in an element of a cnode + ! (bitwise or of existing number) + !============================================== + subroutine cnode_set_flags(ptr,n,val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer,intent(in):: val + type(pm_ptr):: p + if(debug_cnodes) then + call check_cnode(ptr,n) + p=ptr%data%ptr(ptr%offset+n) + if(pm_fast_vkind(p)/=pm_tiny_int.and.pm_fast_vkind(p)/=pm_null) then + write(*,*) 'vkind=',pm_fast_vkind(ptr) + call pm_panic('Set flags') + endif + if(cnode_get_kind(ptr)==cnode_is_var.and.& + n/=var_flags.or.& + cnode_get_kind(ptr)==cnode_is_cblock.and.n/=cblock_flags.or.& + cnode_get_kind(ptr)==cnode_is_call.and.n/=call_flags) then + call pm_panic('set flags') + endif + endif + ptr%data%ptr(ptr%offset+n)%offset=ior(& + ptr%data%ptr(ptr%offset+n)%offset,int(val,pm_p)) + contains + include 'fvkind.inc' + end subroutine cnode_set_flags + + !============================================ + ! Clear flags in element of a code code + ! (Bitwise clear of exiting number) + !============================================ + subroutine cnode_clear_flags(ptr,n,val) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n + integer,intent(in):: val + type(pm_ptr):: p + if(debug_cnodes) then + call check_cnode(ptr,n) + p=ptr%data%ptr(ptr%offset+n) + if(pm_fast_vkind(p)/=pm_tiny_int.and.pm_fast_vkind(p)/=pm_null) then + write(*,*) 'vkind=',pm_fast_vkind(ptr) + call pm_panic('Set flags') + endif + if(cnode_get_kind(ptr)==cnode_is_var.and.& + n/=var_flags.or.& + cnode_get_kind(ptr)==cnode_is_cblock.and.n/=cblock_flags.or.& + cnode_get_kind(ptr)==cnode_is_call.and.n/=call_flags) then + call pm_panic('set flags') + endif + endif + ptr%data%ptr(ptr%offset+n)%offset=iand(& + ptr%data%ptr(ptr%offset+n)%offset,not(int(val,pm_p))) + contains + include 'fvkind.inc' + end subroutine cnode_clear_flags + + !=================================================================== + ! Check all given flags in a given element of a cnode are clear + ! (bitwise and of extisting number and check for zero) + !=================================================================== + function cnode_flags_clear(ptr,n,flags) result(ok) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n,flags + logical:: ok + integer:: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+n)%offset + ok=iand(flags,val)==0 + end function cnode_flags_clear + + !============================================================ + ! Check all given flags in an element of a cnode are set + ! (bitwise and) + !============================================================ + function cnode_flags_set(ptr,n,flags) result(ok) + type(pm_ptr),intent(in):: ptr + integer,intent(in):: n,flags + logical:: ok + integer(pm_p):: val + if(debug_cnodes) call check_cnode(ptr,n) + val=ptr%data%ptr(ptr%offset+n)%offset + ok=iand(flags,int(val))==flags + end function cnode_flags_set + + !========================================== + ! Return kind of a cnode + !========================================== + function cnode_get_kind(ptr) result(n) + type(pm_ptr),intent(in):: ptr + integer:: n + if(pm_debug_checks) call check_cnode(ptr,0) + n=ptr%data%ptr(ptr%offset+1)%offset + end function cnode_get_kind + + !======================================== + ! Return number of arguments of a cnode + !======================================== + function cnode_numargs(ptr) result(n) + type(pm_ptr),intent(in):: ptr + integer:: n + if(debug_cnodes) call check_cnode(ptr,0) + n=pm_fast_esize(ptr)-cnode_args+1 + contains + include 'fesize.inc' + end function cnode_numargs + + + !======================================== + ! Does a cblock contain any communicating + ! operations? + !======================================== + function cblock_has_comm(cblock) result(ok) + type(pm_ptr):: cblock + logical:: ok + ok=(iand(cnode_get_num(cblock,cblock_flags),& + cblock_is_comm)/=0) + end function cblock_has_comm + + + subroutine print_all_sigs(context,iunit,sig_cache,proc_cache) + type(pm_context),pointer:: context + integer,intent(in):: iunit + type(pm_ptr),intent(in):: sig_cache,proc_cache + integer:: i + + do i=1,pm_dict_size(context,proc_cache) + call print_sig(context,iunit,sig_cache,proc_cache,i) + enddo + + end subroutine print_all_sigs + + subroutine print_sig(context,iunit,sig_cache,proc_cache,n) + type(pm_context),pointer:: context + integer,intent(in):: iunit,n + type(pm_ptr),intent(in):: sig_cache,proc_cache + integer:: kind,i + type(pm_ptr):: cnode,key,rvec + key=pm_dict_key(context,proc_cache,int(n,pm_ln)) + cnode=pm_dict_val(context,proc_cache,int(n,pm_ln)) + if(pm_fast_vkind(cnode)==pm_pointer) then + kind=cnode_get_kind(cnode) + !write(*,*) 'KinD=',kind + select case(kind) + case(cnode_is_resolved_proc) + write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//& + trim(pm_name_as_string(context,& + cnode_get_name(cnode_arg(cnode,1),pr_name)))//' {' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_recursive)) & + write(iunit,'(a)') ' [recursive]' + if(cnode_flags_set(cnode,cnode_args+2,proc_unfinished)) & + write(iunit,'(a)') ' [unfinished]' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_impure)) & + write(iunit,'(a)') ' [impure]' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_not_inlinable)) & + write(iunit,'(a)') ' [not inlinable]' + if(cnode_flags_set(cnode,cnode_args+2,proc_has_for)) & + write(iunit,'(a)') ' [has for]' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_not_pure_each)) & + write(iunit,'(a)') ' [not pure each]' + if(cnode_flags_set(cnode,cnode_args+2,proc_has_vkeys)) & + write(iunit,'(a)') ' [has vkeys]' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_dcomm)) & + write(iunit,'(a)') ' [dcomm]' + if(cnode_flags_set(cnode,cnode_args+2,proc_is_file)) & + write(iunit,'(a)') ' [file]' + rvec=cnode_arg(cnode,2) + + if(pm_fast_istiny(rvec)) then + write(iunit,*) '---->',cnode%offset + else + call print_proc_cnode(context,iunit,cnode_arg(cnode,2),& + sig_cache,cnode_arg(cnode,1)) + endif + write(iunit,'(a)') '}' + case(cnode_is_callsig) + write(iunit,'(a)') 'sig{' + do i=1,cnode_numargs(cnode) + call print_proc_cnode(context,iunit,pm_null_obj,& + sig_cache,cnode_arg(cnode,i)) + enddo + write(iunit,'(a)') '}' + case(cnode_is_arglist) + write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'{' + do i=3,cnode_numargs(cnode),2 + write(iunit,'(a)') ' '//& + trim(pm_name_as_string(context,& + key%data%i(key%offset+pm_fast_esize(key))))//& + trim(pm_type_as_string(context,& + cnode_num_arg(cnode,i)))//' {' + call print_proc_cnode(context,iunit,pm_null_obj,& + sig_cache,cnode_arg(cnode,i+1)) + write(iunit,'(a)') ' }' + enddo + write(iunit,'(a)') '}' + case(cnode_is_any_sig) + write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'Any{' + do i=1,cnode_numargs(cnode) + call pm_dump_tree(context,iunit,cnode_arg(cnode,i),2) + enddo + write(iunit,'(a)') '}' + case(cnode_is_autoconv_sig) + write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'Auto {' + do i=1,cnode_numargs(cnode) + call pm_dump_tree(context,iunit,cnode_arg(cnode,i),2) + enddo + write(iunit,'(a)') '}' + case(cnode_is_builtin) + write(iunit,'(a)') '['//trim(pm_int_as_string(n))//'] {' + call print_proc_cnode(context,iunit,pm_null_obj,& + sig_cache,cnode) + write(iunit,'(a)') '}' + case default + write(iunit,'("????",i5)') kind + end select + else + call pm_dump_tree(context,iunit,cnode,1) + endif + contains + include 'fesize.inc' + include 'fvkind.inc' + include 'fistiny.inc' + end subroutine print_sig + + subroutine print_proc_cnode(context,iunit,rvec,sig_cache,cnode) + type(pm_context),pointer:: context + integer,intent(in):: iunit + type(pm_ptr),intent(in):: rvec,sig_cache,cnode + integer:: flags + + write(iunit,'(a)') ' '//& + trim(pm_name_as_string(context,cnode_get_num(cnode,pr_name)))//& + merge('.',merge(merge('''','%',cnode_flags_set(cnode,pr_flags,proccall_is_general)),' ',& + cnode_flags_set(cnode,pr_flags,proccall_is_comm)),cnode_flags_set(cnode,pr_flags,proccall_is_ref))//& + trim(pm_type_as_string(context,cnode_get_num(cnode,pr_ptype)))//' {' + + if(cnode_get_kind(cnode)==cnode_is_builtin) then + write(iunit,'(a)') ' Builtin '//& + op_names(cnode_get_num(cnode,bi_opcode))//& + pm_int_as_string(cnode_get_num(cnode,bi_opcode2)) + else + write(iunit,'(A,i2,A,i2,A,i2,A,i3,A)') & + ' [nargs=',& + cnode_get_num(cnode,pr_nargs),',nret=',cnode_get_num(cnode,pr_nret),& + ',ncalls=',cnode_get_num(cnode,pr_ncalls),']' + call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_get(cnode,pr_cblock),4) + endif + + write(iunit,'(a)') ' }' + contains + include 'fisnull.inc' + end subroutine print_proc_cnode + + recursive subroutine print_cblock_cnode(context,iunit,rvec,sig_cache,cnode,depth) + type(pm_context),pointer:: context + integer,intent(in):: iunit,depth + type(pm_ptr),intent(in):: rvec,sig_cache,cnode + type(pm_ptr)::p + p=cnode_get(cnode,cblock_first_call) + do while(.not.pm_fast_isnull(p)) + call print_call_cnode(context,iunit,rvec,sig_cache,p,depth) + p=cnode_get(p,call_link) + enddo + contains + include 'fisnull.inc' + end subroutine print_cblock_cnode + + recursive subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) + type(pm_context),pointer:: context + integer,intent(in):: iunit,depth + type(pm_ptr),intent(in):: rvec,sig_cache,cnode + integer:: signo,name,i,j,k,nret,nargs,modl,line + type(pm_ptr):: p,args,amps,keys,keynames + character(len=120):: str,location + signo=cnode_get_num(cnode,call_sig) + str=' ' + if(.not.pm_fast_isnull(rvec)) then + k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) + if(k==sp_sig_deactivated) then + str='[--]' + endif + endif + if(signo<0) then + str=repeat(' ',depth)//trim(str)//pm_name_as_string(context,-signo) + i=len_trim(str)+1 + if(.not.pm_fast_isnull(rvec)) then + k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) + if(k>=0) then + call append_to_line(iunit,str,i,& + '['//trim(pm_int_as_string(k))//'] ',.false.,depth) + endif + endif + elseif(signo==0) then + str=repeat(' ',depth)//trim(str)//'var-call' + i=len_trim(str)+1 + call print_value_cnode(context,iunit,rvec,sig_cache,& + cnode_get(cnode,call_var),depth,str,i) + call append_to_line(iunit,str,i,': ',.false.,depth) + else + p=pm_dict_key(context,sig_cache,& + int(signo,pm_ln)) + name=p%data%i(p%offset+pm_fast_esize(p)) + if(.not.pm_fast_isnull(cnode_get(cnode,call_var))) then + str=repeat(' ',depth)//trim(str)//'call *(' + i=depth+7 + call print_value_cnode(context,iunit,rvec,sig_cache,& + cnode_get(cnode,call_var),depth,str,i) + call append_to_line(iunit,str,i,') ',.false.,depth) + elseif(pm_fast_isnull(rvec)) then + str=repeat(' ',depth)//trim(str)//'call '//pm_name_as_string(context,name) + else + k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) + if(k==sp_sig_link) then + str=trim(str)//repeat(' ',depth)//trim(str)//'call [link]'//& + pm_name_as_string(context,name) + elseif(k==sp_sig_dup) then + str=repeat(' ',depth)//trim(str)//'call [dup]'//& + pm_name_as_string(context,name) + elseif(k==sp_sig_noop) then + str=repeat(' ',depth)//trim(str)//'call [noop]'//& + pm_name_as_string(context,name) + elseif(k==sp_sig_deactivated) then + str=repeat(' ',depth)//trim(str)//'call '//& + pm_name_as_string(context,name) + elseif(k<0) then + str=repeat(' ',depth)//trim(str)//'call '//'!![-'//trim(pm_int_as_string(-k))//']'& + //pm_name_as_string(context,name) + else + str=repeat(' ',depth)//trim(str)//'call '//'['//trim(pm_int_as_string(k))//']'& + //pm_name_as_string(context,name) + endif + endif + i=len_trim(str) + call append_proc_call_flags(iunit,str,i,cnode_get_num(cnode,call_flags),.false.,depth) + i=i+1 + end if + + args=cnode_get(cnode,call_args) + nargs=cnode_numargs(args) + nret=cnode_get_num(cnode,call_nret) + amps=cnode_get(cnode,call_amp) + amps=pm_name_val(context,int(amps%offset)) + + if(nret>0) then + do j=1,nret + call print_value_cnode(context,iunit,rvec,sig_cache,cnode_arg(args,j),depth,str,i) + i=i+1 + enddo + call append_to_line(iunit,str,i,'<- ',.false.,depth) + endif + k=0 + do j=nret+1,nargs + if(.not.pm_fast_isnull(amps)) then + if(pm_fast_vkind(amps)/=pm_int) then + call append_to_line(iunit,str,i,'?AMPS?',.false.,depth) + exit + else + if(amps%data%i(amps%offset+k)==i-nret) then + call append_to_line(iunit,str,i,'&',.false.,depth) + k=min(k+1,pm_fast_esize(amps)) + endif + endif + endif + call print_value_cnode(context,iunit,rvec,sig_cache,cnode_arg(args,j),depth,str,i) + i=i+1 + enddo + keys=cnode_get(cnode,call_keys) + if(.not.pm_fast_isnull(keys)) then + + keynames=pm_name_val(context,cnode_get_num(cnode,call_key_names)) + do j=1,cnode_numargs(keys) + call append_to_line(iunit,str,i,& + trim(pm_name_as_string(context,keynames%data%i(keynames%offset+j-1))),.false.,depth) + call append_to_line(iunit,str,i,':=:'//trim(pm_name_as_string(context,name))//':',.false.,depth) + call print_value_cnode(context,iunit,rvec,sig_cache,cnode_arg(keys,j),depth,str,i) + i=i+1 + enddo + endif + modl=cnode_get_num(cnode,cnode_modl_name) + line=cnode_get_num(cnode,cnode_lineno) + location=trim(pm_name_as_string(context,modl))//':'//pm_int_as_string(line) + if(i>len(str)-len_trim(location)) then + write(iunit,'(a)') str + str=' ' + endif + str(len(str)-len_trim(location)+1:)=location + write(iunit,'(a)') str + + contains + include 'fesize.inc' + include 'fisnull.inc' + include 'fvkind.inc' + end subroutine print_call_cnode + + recursive subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth,str,i) + type(pm_context),pointer:: context + integer,intent(in):: iunit,depth + type(pm_ptr),intent(in):: rvec,sig_cache,cnode + character(len=*),intent(inout):: str + integer,intent(inout):: i + integer:: kind,name,tno + type(pm_ptr):: p + kind=pm_fast_vkind(cnode) + if(kind==pm_tiny_int) then + call append_to_line(iunit,str,i,& + trim(pm_int_as_string(int(cnode%offset))),.false.,depth) + elseif(kind==pm_null) then + call append_to_line(iunit,str,i,& + 'NULL',.false.,depth) + elseif(kind==pm_name) then + call append_to_line(iunit,str,i,& + "'"//trim(pm_name_as_string(context,int(cnode%offset))),.false.,depth) + elseif(kind==pm_type) then + call append_to_line(iunit,str,i,& + '<'//trim(pm_type_as_string(context,int(cnode%offset)))//'>',.false.,depth) + else + kind=cnode_get_kind(cnode) + select case(kind) + case(cnode_is_var) + name=cnode_get_num(cnode,var_name) + if(name==0) then + call append_to_line(iunit,str,i,'#'//& + trim(pm_int_as_string(cnode_get_num(cnode,var_index))),.false.,depth) + else + call append_quoted_to_line(iunit,str,i,& + trim(pm_name_as_string(context,name)),.false.,depth) + if(.not.cnode_flags_clear(cnode,var_flags,var_is_imported+var_is_shadowed)) then + call append_to_line(iunit,str,i,''''//& + trim(pm_int_as_string(cnode_get_num(cnode,var_index))),.false.,depth) + endif + endif + if(.not.pm_fast_isnull(rvec)) then + tno=rvec%data%i(rvec%offset+cnode_get_num(cnode,var_index)) + if(tno==sp_sig_deactivated) then + call append_to_line(iunit,str,i,'[---]',.false.,depth) + else + call append_to_line(iunit,str,i,& + '['//trim(pm_type_as_string(context,tno))//']',.false.,depth) + endif + endif + if(cnode_flags_set(cnode,var_flags,var_is_maybe_not_private)) then + call append_to_line(iunit,str,i,'^',.false.,depth) + endif + case(cnode_is_const) + p=cnode_arg(cnode,1) + if(pm_fast_vkind(p)==pm_name) p=pm_name_val(context,int(p%offset)) + call append_to_line(iunit,str,i,& + trim(pm_value_as_string(context,p)),.false.,depth) + case(cnode_is_cblock) + call append_to_line(iunit,str,i,'{',.true.,depth) + call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode,min(50,depth+2)) + str=' ' + str(depth+1:depth+1)='}' + i=depth+1 + case(cnode_is_changelist) + call append_to_line(iunit,str,i,'^(',.false.,depth) + p=cnode_arg(cnode,1) + do while(.not.pm_fast_isnull(p)) + call print_value_cnode(context,iunit,rvec,sig_cache,p%data%ptr(p%offset),depth,str,i) + p=p%data%ptr(p%offset+1) + if(.not.pm_fast_isnull(p)) then + call append_to_line(iunit,str,i,',',.false.,depth) + endif + enddo + call append_to_line(iunit,str,i,') &(',.false.,depth) + p=cnode_arg(cnode,2) + do while(.not.pm_fast_isnull(p)) + call print_value_cnode(context,iunit,rvec,sig_cache,p%data%ptr(p%offset),depth,str,i) + p=p%data%ptr(p%offset+1) + if(.not.pm_fast_isnull(p)) then + call append_to_line(iunit,str,i,',',.false.,depth) + endif + enddo + call append_to_line(iunit,str,i,')',.false.,depth) + end select + endif + contains + include 'fvkind.inc' + include 'fisnull.inc' + end subroutine print_value_cnode + + subroutine append_proc_call_flags(iunit,str,i,flags,proc_flags,depth) + integer,intent(in):: iunit + character(len=*),intent(inout):: str + integer,intent(inout):: i + integer,intent(in):: flags + logical,intent(in):: proc_flags + integer,intent(in):: depth + if(iand(flags,proccall_is_comm)/=0) then + if(iand(flags,proccall_is_general)/=0) then + call append_to_line(iunit,str,i,'''',.false.,depth) + elseif(iand(flags,proccall_is_ref)/=0) then + call append_to_line(iunit,str,i,'.',.false.,depth) + else + call append_to_line(iunit,str,i,'%',.false.,depth) + endif + endif + if(flags/=iand(flags,proccall_is_comm)) then + call append_to_line(iunit,str,i,'<',.false.,depth) + if(iand(flags,proccall_is_inline)/=0) then + call append_to_line(iunit,str,i,'I',.false.,depth) + endif + if(iand(flags,proccall_is_no_inline)/=0) then + call append_to_line(iunit,str,i,'N',.false.,depth) + endif + if(proc_flags) then + if(iand(flags,proc_is_open)/=0) then + call append_to_line(iunit,str,i,'o',.false.,depth) + endif + if(iand(flags,proc_is_cond)/=0) then + call append_to_line(iunit,str,i,'c',.false.,depth) + endif + if(iand(flags,proc_is_uncond)/=0) then + call append_to_line(iunit,str,i,'u',.false.,depth) + endif + if(iand(flags,proc_is_abstract)/=0) then + call append_to_line(iunit,str,i,'a',.false.,depth) + endif + else + if(iand(flags,call_is_fixed)/=0) then + call append_to_line(iunit,str,i,'f',.false.,depth) + endif + if(iand(flags,call_is_assign_call)/=0) then + call append_to_line(iunit,str,i,'a',.false.,depth) + endif + if(iand(flags,call_is_vararg)/=0) then + call append_to_line(iunit,str,i,'v',.false.,depth) + endif + if(iand(flags,call_inline_when_compiling)/=0) then + call append_to_line(iunit,str,i,'i',.false.,depth) + endif + if(iand(flags,call_dup_result)/=0) then + call append_to_line(iunit,str,i,'d',.false.,depth) + endif + if(iand(flags,call_is_cond)/=0) then + call append_to_line(iunit,str,i,'c',.false.,depth) + endif + if(iand(flags,call_is_no_touch)/=0) then + call append_to_line(iunit,str,i,'n',.false.,depth) + endif + if(iand(flags,call_is_unlabelled)/=0) then + call append_to_line(iunit,str,i,'u',.false.,depth) + endif + endif + call append_to_line(iunit,str,i,'>',.false.,depth) + end if + end subroutine append_proc_call_flags + + subroutine append_quoted_to_line(iunit,str,i,part,break,depth) + integer,intent(in):: iunit + character(len=*),intent(inout):: str + integer,intent(inout):: i + character(len=*),intent(in):: part + logical,intent(in):: break + integer,intent(in):: depth + integer:: first + first=iachar(part(1:1)) + if(first>=iachar('a').and.first<=iachar('z').or.& + first>=iachar('A').and.first<=iachar('Z')) then + call append_to_line(iunit,str,i,part,break,depth) + else + call append_to_line(iunit,str,i,"'"//trim(part)//"'",break,depth) + endif + end subroutine append_quoted_to_line + + subroutine append_to_line(iunit,str,i,part,break,depth) + integer,intent(in):: iunit + character(len=*),intent(inout):: str + integer,intent(inout):: i + character(len=*),intent(in):: part + logical,intent(in):: break + integer,intent(in):: depth + integer:: n + n=len(part) + if(i+n>len(str)) then + write(iunit,'(a)') str(1:min(len(str),i)) + str=repeat(' ',depth+1)//part(1:min(len(str)-depth-1,n)) + i=depth+1+n + else + str(i+1:i+n)=part(1:n) + i=i+n + endif + if(break.or.i>len(str)) then + write(iunit,'(a)') str(1:i) + i=1 + endif + end subroutine append_to_line + + +end module pm_cnodes diff --git a/src/codegen.f90 b/src/codegen.f90 index 6592087..570803e 100755 --- a/src/codegen.f90 +++ b/src/codegen.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2025 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -17,7 +17,7 @@ ! ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT IN NO EVENT SHALL THE ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN @@ -26,6 +26,7 @@ !================================================ ! The following routines process the parse tree ! into an intermediate form representation +! (defined in pm_cnodes) !------------------------------------------------ ! The new structure is built of cnodes: ! proc - user defined procedure @@ -51,201 +52,33 @@ module pm_codegen use pm_lib use pm_symbol use pm_types - use pm_parser - use pm_sysdefs + use pm_ast + use pm_cnodes implicit none logical,parameter:: debug_codegen=.false. logical,parameter:: debug_more_codegen=.false. - ! Langauge features - integer,parameter:: num_comm_args=3 - ! Limits integer,parameter:: max_code_stack=4096 integer,parameter:: code_local_hash=1024 - integer,parameter:: max_par_depth=256 + integer,parameter:: max_trace_depth=256 integer,parameter:: max_type_nesting=64 integer,parameter:: max_error_nodes=1024 - ! Magic number for code tree nodes - integer,parameter:: cnode_magic_no=10456_pm_p - - ! Offsets common to all cnode structures - integer,parameter:: cnode_magic=0 - integer,parameter:: cnode_kind=1 - integer,parameter:: cnode_modl_name=2 - integer,parameter:: cnode_lineno=3 - integer,parameter:: cnode_charno=4 - integer,parameter:: cnode_args=5 - - ! Types of cnode structure - integer,parameter:: cnode_is_cblock=1 - integer,parameter:: cnode_is_var=2 - integer,parameter:: cnode_is_const=3 - integer,parameter:: cnode_is_call=4 - integer,parameter:: cnode_is_arglist=5 - integer,parameter:: cnode_is_builtin=6 - integer,parameter:: cnode_is_proc=7 - integer,parameter:: cnode_is_resolved_proc=8 - integer,parameter:: cnode_is_arg_constraint=9 - integer,parameter:: cnode_is_par_constraint=10 - integer,parameter:: cnode_is_typ_constraint=11 - integer,parameter:: cnode_is_interface_constraint=12 - integer,parameter:: cnode_is_any_sig=13 - integer,parameter:: cnode_is_autoconv_sig=14 - integer,parameter:: cnode_num_kinds=14 - - ! Offsets into cblock cnodes - integer,parameter:: cblock_parent=cnode_args+0 - integer,parameter:: cblock_first_var=cnode_args+1 - integer,parameter:: cblock_last_var=cnode_args+2 - integer,parameter:: cblock_first_call=cnode_args+3 - integer,parameter:: cblock_last_call=cnode_args+4 - integer,parameter:: cblock_sym=cnode_args+5 - integer,parameter:: cblock_start=cnode_args+6 - integer,parameter:: cblock_flags=cnode_args+7 - integer,parameter:: cblock_index=cnode_args+8 - integer,parameter:: cblock_last_loop_call=cnode_args+9 - integer,parameter:: cblock_var_inits=cnode_args+10 - integer,parameter:: cblock_node_size=11 - - ! Flags for cblocks - integer,parameter:: cblock_is_comm=1 - integer,parameter:: cblock_is_open=2 - - ! Offsets into call cnodes - integer,parameter:: call_args=cnode_args+0 - integer,parameter:: call_parent=cnode_args+1 - integer,parameter:: call_sig=cnode_args+2 - integer,parameter:: call_flags=cnode_args+3 - integer,parameter:: call_link=cnode_args+4 - integer,parameter:: call_nret=cnode_args+5 - integer,parameter:: call_nkeys=cnode_args+6 - integer,parameter:: call_index=cnode_args+7 - integer,parameter:: call_par_depth=cnode_args+8 - integer,parameter:: call_var=cnode_args+9 - integer,parameter:: call_amp=cnode_args+10 - integer,parameter:: call_node_size=11 - - ! Flags for call nodes - ! (call_is_comm=1.. defined in parser) - integer,parameter:: call_is_fixed = 2**10 - integer,parameter:: call_is_assign_call = 2**11 - integer,parameter:: call_is_vararg = 2**12 - integer,parameter:: call_inline_when_compiling = 2**13 - integer,parameter:: call_dup_result = 2**14 - integer,parameter:: call_is_cond = 2**15 - integer,parameter:: call_is_no_touch = 2**16 - integer,parameter:: call_is_unlabelled = 2**17 - - ! Offsets into var cnodes - integer,parameter:: var_parent=cnode_args+0 - integer,parameter:: var_name=cnode_args+1 - integer,parameter:: var_flags=cnode_args+2 - integer,parameter:: var_link=cnode_args+3 - integer,parameter:: var_index=cnode_args+4 - integer,parameter:: var_par_depth=cnode_args+5 - integer,parameter:: var_create_depth = cnode_args + 6 - integer,parameter:: var_node_size=7 - integer,parameter:: var_extra_info=cnode_args+7 - - ! Flags for var cnodes - integer,parameter:: var_is_var=1 - integer,parameter:: var_is_ref=2 - integer,parameter:: var_is_param=4 - integer,parameter:: var_is_shadowed=16 - integer,parameter:: var_is_imported=32 - integer,parameter:: var_is_accessed=64 - integer,parameter:: var_is_changed=128 - integer,parameter:: var_is_multi_access=256 - integer,parameter:: var_is_key=512 - integer,parameter:: var_is_varg=1024 - integer,parameter:: var_is_par_var=2048 - integer,parameter:: var_is_incomplete=4096 - integer,parameter:: var_is_aliased=8192 - integer,parameter:: var_is_not_inited=16384 - integer,parameter:: var_is_no_import_export=32768 - integer,parameter:: var_is_sync=65536 - - ! Offsets into proc nodes - integer,parameter:: pr_cblock=cnode_args+0 - integer,parameter:: pr_max_index=cnode_args+1 - integer,parameter:: pr_recurse=cnode_args+2 - integer,parameter:: pr_id=cnode_args+3 - integer,parameter:: pr_rtype=cnode_args+4 ! Must be same as bi_rtype - integer,parameter:: pr_nargs=cnode_args+5 - integer,parameter:: pr_nkeys=cnode_args+6 - integer,parameter:: pr_nret=cnode_args+7 - integer,parameter:: pr_flags=cnode_args+8 - integer,parameter:: pr_name=cnode_args+9 - integer,parameter:: pr_ncalls=cnode_args+10 - integer,parameter:: pr_tkeys=cnode_args+11 - integer,parameter:: pr_node_size=12 - - ! Offsets into builtin nodes - integer,parameter:: bi_opcode=cnode_args+0 - integer,parameter:: bi_opcode2=cnode_args+1 - integer,parameter:: bi_data=cnode_args+2 - integer,parameter:: bi_flags=cnode_args+3 - integer,parameter:: bi_rtype=cnode_args+4 ! Must be same as pr_rtype - integer,parameter:: bi_rcode=cnode_args+5 - integer,parameter:: bi_rsym=cnode_args+6 - integer,parameter:: bi_id=cnode_args+7 - integer,parameter:: bi_node_size=8 - - ! Parallel status of a value - integer,parameter:: value_is_shared=0 - integer,parameter:: value_is_private=1 - - ! Flags indicating state within parallel statement nesting - integer,parameter:: par_state_nhd=0 - integer,parameter:: par_state_outer=1 - integer,parameter:: par_state_for=2 - integer,parameter:: par_state_loop=3 - integer,parameter:: par_state_cond_loop=4 - ! -- The following are conditional states (can check >=par_state_cond) - integer,parameter:: par_state_cond=5 - integer,parameter:: par_state_par=6 - integer,parameter:: par_state_masked=7 - integer,parameter:: par_state_over=8 - integer,parameter:: par_state_any=9 - integer,parameter:: par_state_labelled=10 - - ! Reference flags - integer,parameter:: ref_is_val=1 - integer,parameter:: ref_ignores_rules=2 - integer,parameter:: ref_is_dollar=4 - integer,parameter:: ref_is_priv=8 - integer,parameter:: ref_is_shared=16 - integer,parameter:: ref_is_subscripted=32 - integer,parameter:: ref_has_at=64 - integer,parameter:: ref_is_amp=256 - - ! Offsets for loop variables - integer,parameter:: lv_dom=-3 - integer,parameter:: lv_prc=-2 - integer,parameter:: lv_distr=-1 - integer,parameter:: lv_tile=0 - integer,parameter:: lv_num=1 - integer,parameter:: lv_numz=2 - integer,parameter:: lv_index=5 - integer,parameter:: lv_here=6 - integer,parameter:: lv_end=1 - integer,parameter:: lv_state=2 - integer,parameter:: lv_last=3 - integer,parameter:: lv_idx=3 + ! Parallel context + integer,parameter:: par_state_none=0 + integer,parameter:: par_state_for=1 + integer,parameter:: par_state_comm_proc=2 + integer,parameter:: par_state_masked=3 + integer,parameter:: par_state_cond=4 + integer,parameter:: par_state_par=5 ! Flags indicating start/end of a block of type variables ! as opposed to regular variables on variables stack integer,parameter:: typevar_start=-4 integer,parameter:: typevar_end=-5 - ! Must match definitions in infer - integer(pm_p),parameter:: spsig_thru=-4_pm_p - integer(pm_p),parameter:: spsig_dup=-5_pm_p - integer(pm_p),parameter:: spsig_noop=-6_pm_p - ! Maximum number of coding errors before exit integer,parameter:: max_code_errors = 20 @@ -261,10 +94,8 @@ module pm_codegen type(pm_ptr):: visibility ! Stack for local variables (stack() for names, var() for info records) - ! Fixed size hash table to search variable names (chained using link()) - integer,dimension(max_code_stack):: stack,link + integer,dimension(max_code_stack):: stack type(pm_ptr),dimension(max_code_stack):: var - integer,dimension(code_local_hash):: hash integer:: top ! Stack of values for creating cnodes @@ -281,13 +112,9 @@ module pm_codegen ! Flags for current procedure integer:: proc_flags - ! for & par statements - import/export - type(pm_ptr):: loop_cblock - type(pm_ptr),dimension(max_par_depth):: & - imports,import_cblock,region - integer:: par_depth,proc_par_depth - integer:: par_base,over_base - + ! State variables (as position in coder%var) + integer:: param_base,state_base,mask + ! Caches for call signatures and resolved procedures type(pm_ptr):: sig_cache,proc_cache,poly_cache @@ -299,42 +126,66 @@ module pm_codegen type(pm_ptr):: proc_name_vals ! Misc values - type(pm_ptr):: temp,temp2,true,false,one,comm_amp,check_mess,undef_val + type(pm_ptr):: temp,temp2,true,false,one,comm_amp + type(pm_ptr):: std_amp,block_amp,iter_amps,iter_block_amps + type(pm_ptr):: undef_val ! 'true and 'false types - integer:: true_name,false_name + integer:: true_fix,false_fix,true_literal,false_literal ! '1 type integer:: unit_type - ! Contextual information for this point in the traverse - type(pm_ptr):: proc, proc_keys - integer:: proc_base,proc_nret,proc_key_base,proc_ncalls - integer:: run_mode,run_flags,par_state - type(pm_ptr):: label,default_label - logical:: fixed,aliased,in_sync + ! Types with literals (int real bool string) + integer:: literal_types + + ! Check default error message + integer:: check_mess - ! This point in a subscript tuple - integer:: subs_index + ! Contextual information for this point in the traverse + type(pm_ptr):: proc + integer:: proc_base,proc_ncalls + logical:: fixed + integer:: par_state - ! Counter to give each proc a unique index + ! Counter to give each proc a unique index for all procs integer:: id ! Counter to provide unique index for all nodes created integer:: index + ! Counter to provide unique index for all blocks + integer:: block_id + + ! Lexical scope (offset into vstack) + integer:: lex_scope + + ! Blocks + integer:: block_entry,block_base + ! Flags indicating type inference not complete - logical:: types_finished,redo_calls,incomplete,first_pass + logical:: incomplete,types_changed - ! Taints + ! Type inference - depth of nested loops + integer:: loop_depth + + ! Type Inference - Taints integer:: taints,proc_taints + + ! Type inference - arg & return types + integer:: atype,new_atype,rtype - ! This is the parallel kind storeageless implicit argument - integer:: par_kind,par_kind2 + ! Type inference base of current proc record + integer:: base ! Type inference flag recursion -- use to locate infinite recursion logical:: flag_recursion - + + ! Type inference procedure trace + type(pm_ptr),dimension(max_trace_depth):: trace + integer,dimension(max_trace_depth)::trace_keys + integer:: trace_depth + ! Error count type(pm_ptr):: error_nodes(max_error_nodes) integer:: num_errors @@ -348,7 +199,6 @@ module pm_codegen ! SETUP !******************************************************** - !======================================================== ! Initialise code generator structure !======================================================== @@ -356,41 +206,28 @@ subroutine init_coder(context,coder,visibility) type(pm_context),pointer:: context type(pm_ptr),intent(in):: visibility type(code_state),intent(out):: coder - type(pm_ptr):: sig - integer:: sym coder%context=>context coder%visibility=visibility coder%top=1 coder%vtop=0 coder%wtop=0 - coder%hash=0 coder%reg=>pm_register(context,'coder-var stack',coder%temp,coder%temp2,& coder%sig_cache,coder%proc_cache,coder%true,coder%false,coder%one,& coder%undef_val,& array=coder%var,array_size=coder%top) coder%reg2=>pm_register(context,'coder-node stack',& - coder%proc_name_vals,coder%poly_cache,coder%comm_amp,array=& - coder%vstack,array_size=coder%vtop) - coder%reg3=>pm_register(context,'coder-for stack',coder%defer_check,& - coder%check_mess,& - array=coder%imports,& - array_size=coder%par_depth) + coder%proc_name_vals,coder%poly_cache,coder%comm_amp,& + coder%std_amp,coder%block_amp,coder%iter_amps,& + coder%iter_block_amps,array=coder%vstack,& + array_size=coder%vtop) + coder%reg3=>pm_register(context,'coder-for stack',coder%defer_check) coder%sig_cache=pm_dict_new(context,32_pm_ln) coder%prog_cblock=pm_null_obj coder%defer_check=pm_null_obj coder%proc_base=1 - coder%link(coder%proc_base)=0 coder%proc_ncalls=0 - coder%par_base=0 - coder%over_base=0 - coder%par_depth=0 - coder%proc_par_depth=0 - coder%par_state=par_state_outer - coder%run_mode=sym_complete - coder%run_flags=0 - coder%loop_cblock=pm_null_obj - coder%proc_keys=pm_null_obj coder%index=0 + coder%lex_scope=0 coder%true=pm_new_small(context,pm_logical,1_pm_p) coder%true%data%l(coder%true%offset)=.true. coder%false=pm_new_small(context,pm_logical,1_pm_p) @@ -398,46 +235,66 @@ subroutine init_coder(context,coder,visibility) coder%one=pm_new_small(context,pm_long,1_pm_p) coder%one%data%ln(coder%one%offset)=1 - coder%unit_type=pm_new_value_typ(coder%context,coder%one) + coder%unit_type=pm_new_fix_value_type(coder%context,coder%one) coder%one=pm_new_small(context,pm_int,1_pm_p) coder%one%data%i(coder%one%offset)=1 coder%comm_amp=pm_new_small(context,pm_int,1_pm_p) coder%comm_amp%data%i(coder%comm_amp%offset)=num_comm_args+1 - + coder%std_amp=pm_new_small(context,pm_int,1_pm_p) + coder%std_amp%data%i(coder%std_amp%offset)=2 + coder%block_amp=pm_new_small(context,pm_int,1_pm_p) + coder%block_amp%data%i(coder%block_amp%offset)=num_comm_args+2 + coder%iter_amps=pm_new_small(context,pm_int,2_pm_p) + coder%iter_amps%data%i(coder%iter_amps%offset)=num_comm_args+2 + coder%iter_amps%data%i(coder%iter_amps%offset+1)=num_comm_args+4 + coder%iter_block_amps=pm_new_small(context,pm_int,2_pm_p) + coder%iter_block_amps%data%i(coder%iter_block_amps%offset)=num_comm_args+1 + coder%iter_block_amps%data%i(coder%iter_block_amps%offset+1)=num_comm_args+3 coder%one=pm_fast_tinyint(coder%context,& pm_intern_val(coder%context,coder%one)) coder%comm_amp=pm_fast_tinyint(coder%context,& pm_intern_val(coder%context,coder%comm_amp)) - coder%check_mess=pm_new_string(coder%context,'Failed "check" or "test""') + coder%std_amp=pm_fast_tinyint(coder%context,& + pm_intern_val(coder%context,coder%std_amp)) + coder%block_amp=pm_fast_tinyint(coder%context,& + pm_intern_val(coder%context,coder%block_amp)) + coder%iter_amps=pm_fast_tinyint(coder%context,& + pm_intern_val(coder%context,coder%iter_amps)) + coder%iter_block_amps=pm_fast_tinyint(coder%context,& + pm_intern_val(coder%context,coder%iter_block_amps)) + coder%check_mess=pm_new_literal_value_type(coder%context,& + pm_new_string(coder%context,'Failed "check" or "test""')) coder%proc_name_vals=pm_dict_new(coder%context,8_pm_ln) coder%id=0 - coder%true_name=pm_new_value_typ(coder%context,coder%true) - coder%false_name=pm_new_value_typ(coder%context,coder%false) - - coder%default_label=pm_fast_name(coder%context,sym_pct) - coder%label=coder%default_label + coder%block_id=0 + coder%true_fix=pm_new_fix_value_type(coder%context,coder%true) + coder%false_fix=pm_new_fix_value_type(coder%context,coder%false) + coder%true_literal=pm_new_literal_value_type(coder%context,coder%true) + coder%false_literal=pm_new_literal_value_type(coder%context,coder%false) + + call push_word(coder,pm_type_new_any) + call push_word(coder,0) + call push_word(coder,int(pm_long)) + call push_word(coder,int(pm_logical)) + call push_word(coder,int(pm_string_type)) + call push_word(coder,int(pm_double)) + call make_type(coder,6) + coder%literal_types=pop_word(coder) + coder%num_errors=0 coder%supress_errors=.false. coder%fixed=.false. - coder%aliased=.false. - coder%in_sync=.false. - coder%subs_index=-1 + coder%par_state=par_state_none contains include 'fname.inc' include 'ftiny.inc' - - function name_type(n) result(u) - integer,intent(in):: n - integer:: u - u=pm_new_name_typ(coder%context,n) - end function name_type - end subroutine init_coder !======================================================== ! Finalise and delete code generator + ! (this is actually done after inference is completed) !======================================================== subroutine term_coder(coder) type(code_state),intent(inout):: coder @@ -459,23 +316,21 @@ subroutine trav_prog(coder,stmt_list) ! Some general constants call make_const(coder,prog_cblock,stmt_list,& - pm_fast_tinyint(coder%context,-9999)) + pm_fast_tinyint(coder%context,-9999),int(pm_tiny_int)) coder%undef_val=pop_code(coder) + ! State variables (set to null) + call make_state_vars(coder,prog_cblock,stmt_list) + ! filesystem variable call make_sys_var(coder,prog_cblock,stmt_list,sym_filesystem,var_is_var) call make_sys_call(coder,prog_cblock,stmt_list,sym_get_filesystem,0,1) - call make_var_mode(coder,prog_cblock,stmt_list,coder%var(coder%top)) call trav_stmt_list(coder,prog_cblock,stmt_list,stmt_list,sym_do) call make_sp_call(coder,prog_cblock,stmt_list,sym_do,1,0) call close_cblock(coder,prog_cblock) if(coder%num_errors/=0) return - - ! Finalise any var calls - call complete_vcall_sigs(coder) - if(coder%num_errors/=0) return ! Complete type definitions call complete_type_checks(coder) @@ -485,32 +340,56 @@ subroutine trav_prog(coder,stmt_list) ! Sort signatures call sort_sigs(coder) - contains include 'fnewnc.inc' include 'fname.inc' include 'ftiny.inc' end subroutine trav_prog - + !=============================================== + ! Create state variables and set to null + !=============================================== + subroutine make_state_vars(coder,cblock,node,topo) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + type(pm_ptr),intent(in),optional:: topo + coder%state_base=coder%top + if(present(topo)) then + call push_var(coder,sym_topology,topo) + else + call make_sys_var(coder,cblock,node,sym_topology,0) + endif + call make_sys_var(coder,cblock,node,sym_outer,0) + call make_sys_var(coder,cblock,node,sym_region,0) + call make_sys_var(coder,cblock,node,sym_subregion,0) + call make_sys_var(coder,cblock,node,sym_here_in_tile,0) + call make_sys_var(coder,cblock,node,sym_mask,0) + coder%mask=coder%top + call make_sp_call(coder,cblock,node,sym_null,0,& + num_comm_args-merge(1,0,present(topo))) + end subroutine make_state_vars + !******************************************************* - ! SEQUENTIAL STATEMENTS + ! STATEMENTS !******************************************************* - !======================================================== ! Traverse statement list - push cblock onto stack !======================================================== recursive subroutine trav_stmt_list(coder,parent,& - listp,list,lsym) + listp,list,lsym,open_scope) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: parent,listp,list integer,intent(in):: lsym + logical,intent(in),optional:: open_scope type(pm_ptr):: cblock cblock=make_cblock(coder,parent,listp,lsym) call trav_open_stmt_list(coder,cblock,& listp,list) call close_cblock(coder,cblock) + if(present(open_scope)) then + call cnode_set_flags(top_code(coder),cblock_flags,cblock_is_open) + endif end subroutine trav_stmt_list !======================================================== @@ -520,10 +399,10 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& listp,list) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,listp,list - integer:: i,j,n,sym,base,vbase,wbase - integer:: save_par_state,save_over_base,save_run_flags + integer:: i,j,n,sym,base,vbase,wbase,lex_scope,save_par_state + integer:: xbase,xtop,dtop type(pm_ptr):: node,cblock2,var,p - logical:: iscomm,isshared,ok,oldfix + logical:: iscomm if(pm_fast_isnull(list)) goto 10 do i=1,node_numargs(list) vbase=coder%vtop @@ -532,20 +411,22 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& sym=node_sym(node) if(debug_codegen) then write(*,*) 'TRAVERSE>',sym_names(sym),coder%vtop,vbase - !call dump_parse_tree(coder%context,6,node,2) + call dump_parse_tree(coder%context,6,node,2) endif select case(sym) - case(sym_if) + case(sym_if,sym_if_invar) + lex_scope=push_lex_scope(coder) save_par_state=coder%par_state call trav_xexpr(coder,cblock,node,& node_arg(node,1)) - if(coder%par_state>par_state_outer) then - if(pm_fast_isnull(node_arg(node,3))) then - coder%par_state=par_state_masked - else - coder%par_state=par_state_cond - endif + if(sym==sym_if_invar) then + call code_check_invar(coder,cblock,node,top_code(coder),sym_if_invar) + else + coder%par_state=merge(merge(par_state_masked,par_state_cond,& + pm_fast_isnull(node_arg(node,3))),par_state_none,& + coder%par_state/=par_state_none) endif + coder%lex_scope=lex_scope call trav_stmt_list(coder,cblock,node,& node_arg(node,2),sym_if) if(.not.pm_fast_isnull(node_arg(node,3))) then @@ -554,108 +435,80 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& else call code_null(coder) endif - call resolve_if_inits(coder,node) - call make_sp_call(coder,cblock,node,& - sym_if,3,0) coder%par_state=save_par_state - case(sym_if_invar) - if(coder%par_state>=par_state_cond) then - call code_error(coder,node,& - 'Cannot have "if invar" in a conditional context') - endif + call get_lex_scope(coder,node) + call make_sp_call(coder,cblock,node,& + sym_if,4,0) + call pop_lex_scope(coder) + case(sym_switch,sym_switch_invar) call trav_xexpr(coder,cblock,node,& node_arg(node,1)) - call code_check_invar(coder,cblock,node,top_code(coder)) - call trav_stmt_list(coder,cblock,node,& - node_arg(node,2),sym_if_invar) - if(.not.pm_fast_isnull(node_arg(node,3))) then - call trav_stmt_list(coder,cblock,& - node,node_arg(node,3),sym_if_invar) + save_par_state=coder%par_state + if(sym==sym_switch_invar) then + call code_check_invar(coder,cblock,node,top_code(coder),sym_switch_invar) else - call code_null(coder) + coder%par_state=merge(merge(par_state_masked,par_state_cond,& + pm_fast_isnull(node_arg(node,node_numargs(node)))),par_state_none,& + coder%par_state/=par_state_none) endif - call resolve_if_inits(coder,node) - call make_sp_call(coder,cblock,node,sym,3,0) - case(sym_switch) - save_par_state=coder%par_state - call trav_xexpr(coder,cblock,node,& - node_arg(node,1)) var=top_code(coder) - if(save_par_state>par_state_outer) then - if(node_numargs(node)==4) then - if(pm_fast_isnull(node_arg(node,4))) then - coder%par_state=par_state_masked - else - coder%par_state=par_state_cond - endif - else - coder%par_state=par_state_cond - endif - endif - call trav_switch_stmt(coder,cblock,node,2,var,sym_if) + call trav_switch_stmt(coder,cblock,node,2,var,& + merge(sym_if_invar,sym_if,sym==sym_switch_invar)) call drop_code(coder) coder%par_state=save_par_state - case(sym_switch_invar) - if(coder%par_state>=par_state_cond) then - call code_error(coder,node,& - 'Cannot have "switch invar" in a conditional context') - endif - call trav_xexpr(coder,cblock,node,& - node_arg(node,1)) - call code_check_invar(coder,cblock,node,top_code(coder)) - call trav_switch_stmt(coder,cblock,node,2,var,sym_if_invar) - call drop_code(coder) case(sym_while,sym_while_invar) + lex_scope=push_lex_scope(coder) save_par_state=coder%par_state - call make_const(coder,cblock,node,node_arg(node,1)) + coder%par_state=loop_par_state(coder,node,& + sym,sym==sym_while_invar) cblock2=make_cblock(coder,cblock,node,sym_while) - call trav_xexpr(coder,cblock2,node,node_arg(node,2)) - if(sym==sym_while_invar) then - call code_check_invar(coder,cblock2,node,top_code(coder)) - endif + call trav_xexpr(coder,cblock2,node,node_arg(node,1)) call close_cblock(coder,cblock2) - coder%par_state=save_par_state - coder%par_state=par_state_for_loop(coder,node,coder%par_state,& - node_get_num(node,node_args)/=0,sym==sym_while_invar) + coder%lex_scope=lex_scope call trav_stmt_list(coder,cblock,node,& - node_arg(node,3),sym_while) - call make_sp_call(coder,cblock,node,sym_while,4,0) + node_arg(node,2),sym_while) + call get_lex_scope(coder,node) + if(sym/=sym_while) call code_val(coder,coder%var(coder%mask)) + call make_sp_call(coder,cblock,node,sym,merge(4,5,sym==sym_while),0) + call pop_lex_scope(coder) coder%par_state=save_par_state case(sym_until,sym_until_invar) - call make_const(coder,cblock,node,node_arg(node,1)) save_par_state=coder%par_state - coder%par_state=par_state_for_loop(coder,node,coder%par_state,& - node_get_num(node,node_args)/=0,sym==sym_until_invar) + coder%par_state=loop_par_state(coder,node,sym,& + sym==sym_until_invar) + lex_scope=push_lex_scope(coder) cblock2=make_cblock(coder,cblock,node,sym_until) + coder%lex_scope=lex_scope call trav_open_stmt_list(coder,cblock2,node,& - node_arg(node,3)) + node_arg(node,2)) iscomm=cnode_flags_set(top_code(coder),cblock_flags,cblock_is_comm) - call trav_xexpr(coder,cblock2,node,node_arg(node,2)) - if(sym==sym_until_invar) then - call code_check_invar(coder,cblock2,node,top_code(coder)) - endif + call trav_xexpr(coder,cblock2,node,node_arg(node,1)) call close_cblock(coder,cblock2) + call get_lex_scope(coder,node) + if(sym/=sym_until) call code_val(coder,coder%var(coder%mask)) call make_sp_call(coder,cblock,node,& - sym_until,3,0) + sym,merge(3,4,sym==sym_until),0) + call pop_lex_scope(coder) coder%par_state=save_par_state case(sym_do_stmt) - call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_do) - call make_sp_call(coder,cblock,node,sym_do,1,0) - case(sym_after) - call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_do) - call make_sp_call(coder,cblock,node,sym_do,1,0) - call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_do) - call make_sp_call(coder,cblock,node,sym_do,1,0) - case(sym_proceed) - continue - case(sym_mode) - call trav_mode_stmt(coder,cblock,node,sym,.false.) - case(sym_for) - call trav_xexpr(coder,cblock,node,node_arg(node,2),node) + if(node_numargs(node)==1) then + call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_do) + call make_sp_call(coder,cblock,node,sym_do,1,0) + else + call trav_subexpr(coder,cblock,node,node_arg(node,6),xbase,xtop,dtop) + if(xbase>=0) call hide_where_vars(coder,xbase+1,dtop) + call make_block_proc(coder,cblock,node_arg(node,3),& + node_arg(node,1),node_num_arg(node,2),& + node_arg(node,5),node_numargs(node_arg(node,5)),& + node_arg(node,4)) + if(xbase>=0) call reveal_vars(coder,xbase+1,dtop) + call trav_call(coder,cblock,node,node_arg(node,3),0,.true.) + if(xbase>=0) call hide_where_vars(coder,xbase+1,xtop) + endif + case(sym_for,sym_forall) + call trav_for_stmt(coder,cblock,list,node) case(sym_each,sym_foreach_invar) - call trav_xexpr(coder,cblock,node,node_arg(node,1),node) - case(sym_nhd) - call trav_xexpr(coder,cblock,node,node_arg(node,4),node) + call trav_foreach_stmt(coder,cblock,list,node) case(sym_test) if(pm_fast_isnull(node_arg(node,1))) then call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_check) @@ -673,58 +526,38 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& p=node_arg(node,1) call trav_call(coder,cblock,node,p,0,.true.) case(sym_var,sym_const) - call trav_var_no_init(coder,cblock,list,node) - case(sym_with) - base=coder%top - call trav_open_stmt_list(coder,cblock,node,node_arg(node,1)) - j=coder%top - call trav_open_stmt_list(coder,cblock,node,node_arg(node,2)) - call hide_vars(coder,base+1,j) + do j=1,node_numargs(node)-1 + call make_var(coder,cblock,node,node_num_arg(node,j),& + merge(var_is_var,0,sym==sym_var)) + enddo + call push_word(coder,pm_type_new_uninitialised) + call push_word(coder,0) + call push_word(coder,pm_type_new_type) + call push_word(coder,0) + call trav_type(coder,node,node_arg(node,node_numargs(node))) + call make_type(coder,3) + call make_type(coder,3) + call code_num(coder,pop_word(coder)) + call make_sp_call(coder,cblock,node,sym_var,1,node_numargs(node)-1) case(sym_over) call trav_over_stmt(coder,cblock,list,node) - case(sym_define) + case(sym_assign) call trav_assign_define(coder,cblock,list,node) - case(sym_assign_list) - call trav_assign_define_list(coder,cblock,list,node) - case(sym_sync_assign) - call trav_sync_assign(coder,cblock,list,node) - case(sym_where,sym_check,sym_amp) + case(sym_all) + call trav_all_stmt(coder,cblock,list,node) + case(sym_where,sym_split,sym_check,sym_amp) call trav_xexpr(coder,cblock,listp,node) case(sym_sync) - select case(coder%par_state) - case(par_state_cond,par_state_par) - save_par_state=coder%par_state - coder%par_state=par_state_labelled - call check_par_nesting(coder,cblock,node,.false.) - coder%label=node_arg(node,2) - call make_const(coder,cblock,node,& - node_arg(node,2)) - call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_sync) - call make_sp_call(coder,cblock,node,sym_sync,2,0) - coder%par_state=save_par_state - coder%label=coder%default_label - case(par_state_outer) - call code_error(coder,node,& - 'Labelled statement not allowed outside of any parallel statement') - case(par_state_nhd) - call code_error(coder,node,& - 'Labelled statement not allowed in a "nhd" statement') - case(par_state_any) - call code_error(coder,node,& - 'Labelled statement not allowed in an "any" statement') - case(par_state_cond_loop) - call code_error(coder,node,& - 'Labelled statement in unlabelled loop') - case(par_state_for,par_state_loop,par_state_masked,par_state_over,par_state_labelled) - call trav_open_stmt_list(coder,cblock,node,node_arg(node,1)) - case default - write(*,*) 'Par state=',coder%par_state - call pm_panic('Unknown par state (sym_sync)') - end select + call trav_sync_stmt(coder,cblock,list,node) case(sym_par) call trav_par_stmt(coder,cblock,list,node) + case(sym_task) + call trav_task(coder,cblock,list,node) case(sym_any,sym_any_invar) call trav_any_stmt(coder,cblock,list,node,sym) + case(sym_yield) + p=node_arg(node,1) + call trav_call(coder,cblock,node,p,0,.true.) case(sym_ddollar) n=node_num_arg(node,1) select case(n) @@ -752,16 +585,9 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call code_error(coder,node,& '"$$dump" takes one or two arguments',warn=.true.) else - if(coder%par_state/=par_state_outer) then - call make_comm_call_args(coder,cblock,node) - endif call trav_expr(coder,cblock,node,node_arg(node,2)) if(j==3) call trav_expr(coder,cblock,node,node_arg(node,3)) - if(coder%par_state==par_state_outer) then - call make_sys_call(coder,cblock,node,sym_pm_dump,j-1,0) - else - call make_comm_sys_call(coder,cblock,node,sym_pm_dump,j-1,0) - endif + call make_comm_sys_call(coder,cblock,node,sym_pm_dump,j-1,0) endif case default call code_error(coder,node,'Pragma not recognised: $$'//& @@ -771,7 +597,6 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& base=coder%vtop call make_sys_var(coder,cblock,node,node_get_num(node,node_args),& var_is_shadowed) - call set_var_as_shared(coder,top_code(coder)) call dup_code(coder) call make_sys_var(coder,cblock,node,node_get_num(node,node_args+1),& var_is_shadowed) @@ -794,8 +619,6 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call make_sp_call(coder,cblock,node,sym,5,3) call close_cblock(coder,cblock2) endif - call set_var_as_shared(coder,pop_code(coder)) - call check_par_nesting(coder,cblock,node,.false.) if(coder%vtop/=base) call pm_panic('pm_send/recv') case(sym_pm_bcast) call make_sys_var(coder,cblock,node,node_get_num(node,node_args),& @@ -807,7 +630,6 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& call trav_expr(coder,cblock,node,node_arg(node,5)) call trav_stmt_list(coder,cblock,node,node_arg(node,6),sym_caret) call make_sp_call(coder,cblock,node,sym,4,2) - call check_par_nesting(coder,cblock,node,.false.) case(sym_pm_recv_req) call make_sys_var(coder,cblock,node,node_get_num(node,node_args),& var_is_shadowed) @@ -849,9 +671,57 @@ recursive subroutine trav_open_stmt_list(coder,cblock,& enddo call trav_stmt_list(coder,cblock,node,node_arg(node,node_numargs(node)),sym_caret) call make_sp_call(coder,cblock,node,sym,node_numargs(node),0) + case(sym_pm_each_index) + call trav_pm_each_index(coder,cblock,list,node,.false.) + case(sym_pm_context) + call trav_pm_context(coder,cblock,list,node) + case(sym_pm_set_dotdotdot) + call make_sys_var(coder,cblock,list,sym_dotdotdot,var_is_param+var_is_varg) + call trav_expr(coder,cblock,list,node_arg(node,1)) + call make_sp_call(coder,cblock,list,sym_pm_set_dotdotdot,1,1) case(sym_pm_head_node) call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym_caret) call make_sp_call(coder,cblock,node,sym,1,0) + case(sym_pm_over) + call trav_xexpr(coder,cblock,node,node_arg(node,1)) + call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_pm_for) + call make_sp_call(coder,cblock,node,sym,2,0) + case(sym_pm_for) + call trav_xexpr(coder,cblock,node,node_arg(node,1)) + save_par_state=coder%par_state + coder%par_state=par_state_for + call trav_stmt_list(coder,cblock,node,node_arg(node,2),sym_pm_for) + coder%par_state=save_par_state + call make_sp_call(coder,cblock,node,sym,2,0) + case(sym_pm_shared,sym_pm_shared_always,sym_pm_chan,sym_pm_chan_always) + save_par_state=coder%par_state + ! Assumes test correctly separates shared/chan + coder%par_state=merge(par_state_for,par_state_none,sym>=sym_pm_chan) + call trav_stmt_list(coder,cblock,node,node_arg(node,1),sym) + coder%par_state=save_par_state + call make_sp_call(coder,cblock,node,sym,1,0) + case(sym_pm_foreach) + lex_scope=push_lex_scope(coder) + call trav_xexpr(coder,cblock,node,node_arg(node,1)) + coder%lex_scope=lex_scope + save_par_state=coder%par_state + coder%par_state=par_state_masked + call trav_stmt_list(coder,cblock,node,& + node_arg(node,2),sym_pm_foreach) + coder%par_state=save_par_state + call get_lex_scope(coder,node) + call make_sp_call(coder,cblock,node,sym_pm_foreach,3,0) + call pop_lex_scope(coder) + case(sym_pm_ref) + call trav_expr(coder,cblock,node,node_arg(node,2)) + if(cnode_get_kind(top_code(coder))/=cnode_is_var) then + call code_error(coder,node,'Internal error: PM__ref expression does not yield var') + endif + call cnode_set_flags(top_code(coder),var_flags,var_is_var) + call push_var(coder,node_num_arg(node,1),pop_code(coder)) + case(sym_repl_line) + call trav_xexpr(coder,cblock,node,node_arg(node,1)) + call make_sys_call(coder,cblock,node,sym_print,1,0) case default if(sym>0.and.sym=0) call hide_vars(coder,base+1,top) - contains - include 'fisnull.inc' - include 'fisname.inc' - include 'fname.inc' - include 'ftiny.inc' - - subroutine apply_x(nodep,node) - type(pm_ptr),intent(in):: nodep,node - type(pm_ptr):: nodei - integer:: wbase,i,flags,numret - logical:: outer - - wbase=coder%wtop - if(pm_fast_isnull(node)) return - select case(node_sym(node)) - case(sym_define) - call trav_assign_define(coder,cblock,nodep,node) - case(sym_assign_list) - call trav_assign_define_list(coder,cblock,nodep,node) - case(sym_sync_assign) - call trav_sync_assign(coder,cblock,nodep,node) - case(sym_iter) - if(node_sym(stmt)==sym_for) then - call trav_for_stmt(coder,cblock,nodep,node,base,stmt) - else - call trav_foreach_stmt(coder,cblock,nodep,node,base,stmt) - endif - case(sym_nhd) - call trav_nhd_stmt(coder,cblock,nodep,stmt,base) - case(sym_list) - call trav_exprlist(coder,cblock,nodep,node) - case(sym_result) - call push_word(coder,pm_typ_is_tuple) - call push_word(coder,0) - do i=1,node_numargs(node),2 - call trav_expr(coder,cblock,node,node_arg(node,i)) - nodei=node_arg(node,i+1) - if(.not.pm_fast_isnull(nodei)) then - call trav_cast(coder,cblock,node,nodei,sym_const) - call trav_type(coder,node,nodei) - else - call push_word(coder,0) - endif - enddo - call make_type(coder,node_numargs(node)/2+2) - return - case(sym_do) - call trav_call(coder,cblock,node,node_arg(node,1),0,.true.) - case(sym_test) - call make_check(coder,cblock,node,base) - case default - call trav_top_expr(coder,cblock,nodep,node) - end select - if(pm_debug_checks) then - if(coder%wtop/=wbase) then - write(*,*) coder%wtop,wbase - call dump_parse_tree(coder%context,6,node,2) - call pm_panic('xexpr wstack mismatch') - endif - endif - end subroutine apply_x - - end subroutine trav_xexpr - !======================================================== - ! Compile check - !======================================================== - recursive subroutine make_check(coder,cblock,p,base) + function loop_par_state(coder,node,sym,isinvar) result(new_par_state) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,p - integer,intent(in):: base - type(pm_ptr):: mess,cblock2,cblock3 - integer:: i - do i=2,node_numargs(p),2 - mess=node_arg(p,i) - if(pm_fast_isnull(mess)) then - call make_const(coder,cblock,p,coder%check_mess) - call code_null(coder) - elseif(node_sym(mess)==sym_string) then - call make_const(coder,cblock,p,node_arg(mess,1)) - call code_null(coder) - else - call make_sys_var(coder,cblock,p,sym_check,var_is_shadowed) - cblock2=make_cblock(coder,cblock,p,sym_check) - call trav_expr(coder,cblock2,p,mess) - call init_var(coder,cblock2,p,& - coder%vstack(coder%vtop-2)) - call close_cblock(coder,cblock2) + type(pm_ptr),intent(in):: node + integer,intent(in):: sym + logical,intent(in):: isinvar + integer:: new_par_state + integer:: par_state + par_state=coder%par_state + if(par_state==par_state_none) then + if(isinvar) then + call code_error(coder,node,& + '"'//trim(sym_names(sym))//'" cannot be used outside of a parallel context') endif - call make_sys_var(coder,cblock,p,sym_query,var_is_shadowed) - cblock3=make_cblock(coder,cblock,p,sym_check) - call trav_expr(coder,cblock3,p,node_arg(p,i+1)) - call init_var(coder,cblock3,p,coder%vstack(coder%vtop-2)) - call close_cblock(coder,cblock3) - call make_sp_call(coder,cblock,p,sym_check,4,0) - end do - contains - include 'fisnull.inc' - end subroutine make_check + else + if(isinvar) then + if(par_state>=par_state_cond) then + call code_error(coder,node,& + '"'//trim(sym_names(sym))//'" cannot be used in this conditional context') + endif + endif + endif + coder%par_state=merge(par_state,par_state_none,isinvar) + end function loop_par_state !======================================================== ! switch statement - cases and otherwise clause @@ -1031,17 +794,28 @@ recursive subroutine trav_switch_stmt(coder,cblock,stmt,idx,var,sym) type(pm_ptr),intent(in):: stmt,var integer,intent(in):: idx,sym type(pm_ptr):: cblock2 - integer:: base,save_par_state - call make_temp_var(coder,cblock,stmt) - call dup_code(coder) + integer:: base,n,i,lex_scope + lex_scope=push_lex_scope(coder) base=coder%vtop - call code_val(coder,var) + call trav_xexpr(coder,cblock,stmt,node_arg(stmt,idx)) + n=coder%vtop-base + do i=1,n + call code_val(coder,var) + call code_val(coder,coder%vstack(base+i)) + call make_sys_call_rtn(coder,cblock,stmt,& + sym_checkcase,2,1) + if(i>1) then + call make_sys_call_rtn(coder,cblock,stmt,& + sym_or,2,1) + endif + enddo + coder%vstack(base+1)=top_code(coder) + coder%vtop=base+1 if(sym==sym_if_invar) then - call code_check_invar(coder,cblock,stmt,top_code(coder)) + call code_check_invar(coder,cblock,stmt,top_code(coder),sym_switch_invar) endif - call make_sys_call(coder,cblock,stmt,& - sym_checkcase,coder%vtop-base,1) + coder%lex_scope=lex_scope call trav_stmt_list(coder,cblock,stmt,& node_arg(stmt,idx+1),sym_switch) if(idx==node_numargs(stmt)-2) then @@ -1056,61 +830,25 @@ recursive subroutine trav_switch_stmt(coder,cblock,stmt,idx,var,sym) call trav_switch_stmt(coder,cblock2,stmt,idx+2,var,sym) call close_cblock(coder,cblock2) endif - call resolve_if_inits(coder,stmt) - call make_sp_call(coder,cblock,stmt,sym,3,0) + call get_lex_scope(coder,stmt) + call make_sp_call(coder,cblock,stmt,sym,4,0) + call pop_lex_scope(coder) contains include 'fisnull.inc' end subroutine trav_switch_stmt !======================================================== - ! Traverse statement qualified by a mode - !======================================================== - recursive subroutine trav_mode_stmt(coder,cblock,node,nsym,isexpr) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: nsym - logical,intent(in):: isexpr - integer:: sym,save_run_mode,save_run_flags,save_par_state - sym=node_num_arg(node,2) - if(coder%par_state==par_state_outer) then - call code_error(coder,node,'Cannot have "'//& - trim(sym_names(sym))//& - '" statement outside of a parallel context') - elseif(coder%par_state==par_state_nhd) then - call code_error(coder,node,'Cannot have "'//& - trim(sym_names(sym))//& - '" statement in main body of "nhd" statement') - endif - - save_run_mode=coder%run_mode - save_run_flags=coder%run_flags - coder%run_mode=sym - select case(sym) - case(sym_coherent:sym_mirrored) - coder%run_flags=proc_run_complete+proc_run_always - case(sym_shared) - coder%run_flags=proc_run_shared+proc_run_always - end select - if(isexpr) then - call trav_expr(coder,cblock,node,node_arg(node,1)) - else - call trav_open_stmt_list(coder,cblock,node,node_arg(node,1)) - endif - coder%run_mode=save_run_mode - coder%run_flags=save_run_flags - end subroutine trav_mode_stmt - - !======================================================== - ! Traverse "any" statement + ! Traverse "any" statement (sym is "any" or "any invar") !======================================================== recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node integer,intent(in):: sym - integer:: k,i,j,n,flags,start,finish,vb - type(pm_ptr):: cblock2,vlist,v,var - integer:: save_par_state + integer:: flags,start,finish,vb,lex_scope + type(pm_ptr):: cblock2,v,var + lex_scope=push_lex_scope(coder) + if(pm_fast_isnull(node_arg(node,2))) then flags=var_is_shadowed+var_is_var call trav_expr(coder,cblock,node,node_arg(node,1)) @@ -1119,30 +857,26 @@ recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) call trav_xexpr(coder,cblock,node,node_arg(node,2)) endif v=top_code(coder) - save_par_state=coder%par_state - if(sym==sym_any) then - coder%par_state=par_state_any - else - call code_check_invar(coder,cblock,node,v) + if(sym==sym_any_invar) then + call code_check_invar(coder,cblock,node,v,sym_any_invar) endif cblock2=make_cblock(coder,cblock,node,sym_any) - call make_var(coder,cblock,node,node_arg(node_arg(node,1),1),flags) + call make_var(coder,cblock,node,node_num_arg(node_arg(node,1),1),flags) vb=coder%top var=top_code(coder) start=coder%index call swap_code(coder) + coder%lex_scope=lex_scope call trav_open_stmt_list(coder,cblock2,node,node_arg(node,3)) if(cnode_flags_set(var,var_flags,var_is_changed)) then - call make_temp_var(coder,cblock2,node) - call dup_code(coder) call code_val(coder,var) call dup_expr(coder,v) - call make_sys_call(coder,cblock2,node,sym_as,2,1) + call make_sys_call_rtn(coder,cblock2,node,sym_as,2,1) call hide_vars(coder,vb,vb) if(pm_fast_isnull(node_arg(node,2))) then - call make_assignment_noalias(coder,cblock2,node,node_arg(node,1)) + call trav_assign(coder,cblock2,node,node_arg(node,1),pm_null_obj) else - call make_assignment_noalias(coder,cblock2,node,node_arg(node,2)) + call trav_assign(coder,cblock2,node,node_arg(node,2),pm_null_obj) endif call reveal_vars(coder,vb,vb) endif @@ -1150,1632 +884,1544 @@ recursive subroutine trav_any_stmt(coder,cblock,pnode,node,sym) call close_cblock(coder,cblock2) call code_val(coder,v) v=pm_fast_newnc(coder%context,pm_int,2) - coder%temp=v + coder%temp2=v v%data%i(v%offset)=start v%data%i(v%offset+1)=finish - call make_const(coder,cblock,node,coder%temp) - call make_sp_call(coder,cblock,node,sym_any,3,1) + call make_const(coder,cblock,node,coder%temp2) + call get_lex_scope(coder,node) + call make_sp_call(coder,cblock,node,sym_any,4,1) call drop_code(coder) call hide_vars(coder,vb,vb) - coder%par_state=save_par_state + call pop_lex_scope(coder) contains include 'fisnull.inc' include 'fnewnc.inc' end subroutine trav_any_stmt - !======================================================== - ! Traverse a for each statement - ! -- also used for foreach clause of nhd statement - !======================================================== - recursive subroutine trav_foreach_stmt(coder,cblock,listp,list,base,stmt,nhd,nbase,nvars) + subroutine trav_pm_each_index(coder,cblock,nodep,node,isexpr) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,listp,list,stmt - integer,intent(in):: base - type(pm_ptr),intent(in),optional:: nhd - integer,intent(in),optional:: nbase,nvars - type(pm_ptr):: var,vlist - type(pm_ptr):: cblock2,cblock3,cblock4 - type(pm_ptr):: cblock_main - integer:: i,j,k,n,lbase,vbase,xbase,xbasev - integer:: nlist,iter,iter2,sym,rbase,wbase,name,flags,sindex,sbase - integer:: slot1,slot2,while_var,outmode,rflags - integer(pm_p)::flag - type(pm_ptr):: vlhs,procs,sig,xvar,p - integer:: save_par_state,save_run_flags,save_run_mode - type(pm_ptr):: save_loop_cblock - logical:: iscomm,outer,invar,c_invar - sym=node_sym(stmt) - rbase=coder%vtop - wbase=coder%wtop - invar=sym==sym_foreach_invar - c_invar=pm_is_compiling.and.invar - rflags=merge(proc_run_shared+proc_run_always,0,c_invar) - - if(debug_codegen) write(*,*) 'TRAVEACH>' - - ! Process iterator expression - call trav_iter(coder,cblock,list,sym_dims,lbase,vbase,nlist) - - ! Check invariance of for-each-invar expressions - if(invar) then - do i=1,nlist/2 - call code_check_invar(coder,cblock,node_arg(list,i*2),& - coder%vstack(lbase+i)) - enddo + type(pm_ptr),intent(in):: cblock,nodep,node + logical,intent(in):: isexpr + integer:: base,start,finish + type(pm_ptr):: cblock2,v + base=coder%top + if(isexpr) then + call make_temp_var(coder,cblock,node) + call dup_code(coder) endif - - ! Hide any where clauses (may need them later) - if(base>=0) then - call hide_vars(coder,base+1,coder%top) + call trav_expr(coder,cblock,node,node_arg(node,2)) + start=coder%index+1 + cblock2=make_cblock(coder,cblock,node,sym_pm_each_index) + call make_var(coder,cblock2,node,node_num_arg(node,1),0) + call swap_code_1_2(coder) + if(isexpr) then + call trav_expr(coder,cblock2,node,node_arg(node,3)) + else + call trav_open_stmt_list(coder,cblock2,node,node_arg(node,3)) endif + call close_cblock(coder,cblock2) + finish=coder%index + v=pm_fast_newnc(coder%context,pm_int,2) + coder%temp2=v + v%data%i(v%offset)=start + v%data%i(v%offset+1)=finish + call make_const(coder,cblock,node,coder%temp2) + if(isexpr) call swap_code(coder) + coder%temp2=pm_null_obj + call make_sp_call(coder,cblock,node,sym_pm_each_index,& + merge(4,3,isexpr),merge(2,1,isexpr)) + call hide_vars(coder,base+1,base+1) + contains + include 'fnewnc.inc' + end subroutine trav_pm_each_index - if(.not.pm_is_compiling) then - call make_const(coder,cblock,stmt,node_arg(stmt,4)) - endif - - save_par_state=coder%par_state - coder%par_state=par_state_for_loop(coder,stmt,coder%par_state,& - node_get_num(stmt,node_args+3)/=0,sym==sym_foreach_invar) - - ! Start for-each loop - iter=call_start(coder,cblock,list,invar) - - ! Get array/domain elements for first iteration - xbase=coder%top - do i=1,nlist/2 - call make_var(coder,cblock,list,& - node_arg(list,i*2-1),var_is_var) - call code_val(coder,coder%vstack(lbase+i)) - call code_val(coder,coder%var(iter+lv_idx)) - call make_sys_call(coder,cblock,list,sym_get_element,2,1,& - aflags=rflags) - enddo - - ! While clause - if(.not.pm_fast_isnull(node_arg(stmt,2))) then - p=node_arg(stmt,2) - if(node_sym(p)==sym_while) then - call make_temp_var(coder,cblock,stmt) - call dup_code(coder) - call code_val(coder,coder%var(iter+lv_end)) - call trav_xexpr(coder,cblock,p,node_arg(p,1)) - if(invar) then - call code_check_invar(coder,cblock,p,top_code(coder)) - endif - call make_sys_call(coder,cblock,stmt,sym_and,2,1,aflags=rflags) - call make_var_assignment(coder,cblock,stmt,coder%var(iter+lv_end),aflags=rflags) - endif + !==================================================================== + ! Traverse a PM__context statement node + ! Creates new variable entries and runs block with modified + ! values of coder%state_base (start-1 of block of context vars) and + ! coder%mask (location on stack of PM__mask variable) + !==================================================================== + subroutine trav_pm_context(coder,cblock,pnode,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + integer:: save_state_base,save_mask + save_state_base=coder%state_base + save_mask=coder%mask + coder%state_base=coder%top + call trav_name(coder,cblock,node,sym_name,node_num_arg(node,1)) + call push_var(coder,sym_topology,pop_code(coder)) + call trav_name(coder,cblock,node,sym_name,node_num_arg(node,2)) + call push_var(coder,sym_outer,pop_code(coder)) + call trav_name(coder,cblock,node,sym_name,node_num_arg(node,3)) + call push_var(coder,sym_region,pop_code(coder)) + call trav_name(coder,cblock,node,sym_name,node_num_arg(node,4)) + call push_var(coder,sym_subregion,pop_code(coder)) + call trav_name(coder,cblock,node,sym_name,node_num_arg(node,5)) + call push_var(coder,sym_here_in_tile,pop_code(coder)) + call trav_name(coder,cblock,node,sym_name,node_num_arg(node,6)) + call push_var(coder,sym_mask,pop_code(coder)) + coder%mask=coder%top + call trav_open_stmt_list(coder,cblock,node,node_arg(node,7)) + coder%mask=save_mask + coder%state_base=save_state_base + end subroutine trav_pm_context + + !==================================================================== + ! Traverse foreach statement converting to a call to PM__foreach_stmt + !==================================================================== + subroutine trav_foreach_stmt(coder,cblock,pnode,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode,node + type(pm_ptr):: stmts,condition,iter,cblock2,amps + integer:: lex_scope,base,xtop,dtop,sym,call_sym + + amps=coder%iter_amps + iter=node_arg(node,1) + condition=node_arg(node,2) + stmts=node_arg(node,4) + + call trav_subexpr(coder,cblock,node,node_arg(node,3),base,xtop,dtop) + + if(node_sym(condition)==sym_while) then + lex_scope=push_lex_scope(coder) + call trav_xexpr(coder,cblock,node,& + node_arg(condition,1)) + coder%lex_scope=lex_scope + cblock2=make_cblock(coder,cblock,node,sym_each) + else + cblock2=cblock endif + + !!! coder%par_state - ! Loop body - cblock2=make_cblock(coder,cblock,list,sym_each) - call trav_open_stmt_list(coder,cblock2,stmt,node_arg(stmt,3)) - - ! Modify changed array elements - do i=1,nlist/2 - var=coder%var(xbase+i) - if(cnode_flags_set(var,var_flags,var_is_changed)) then - outmode=trav_ref(coder,cblock2,list,& - node_arg(list,i*2),0) - call code_val(coder,var) - call code_val(coder,coder%var(iter+lv_idx)) - call make_assign_call(coder,cblock2,list,sym_set_element,3,0,aflags=rflags) - endif - enddo + if(base>=0) call hide_where_vars(coder,base+1,dtop) - ! Next iteration - if(.not.pm_fast_isnull(node_arg(stmt,2))) then - ! While/until - p=node_arg(stmt,2) - if(node_sym(p)/=sym_while) then - call trav_xexpr(coder,cblock2,stmt,node_arg(p,1)) - if(sym==sym_foreach_invar) then - call code_check_invar(coder,cblock2,p,top_code(coder)) - endif - cblock_main=make_cblock(coder,cblock2,stmt,sym_each) - call make_const(coder,cblock_main,stmt,coder%false) - call make_var_assignment(coder,cblock_main,stmt,& - coder%var(iter+lv_end),aflags=rflags) - call close_cblock(coder,cblock_main) - cblock_main=make_cblock(coder,cblock2,stmt,sym_each) - call call_next(coder,cblock_main,list,iter,invar) - call close_cblock(coder,cblock_main) - call make_sp_call(coder,cblock2,stmt,merge(sym_if_invar,sym_if,c_invar),3,0) - else - call call_next(coder,cblock2,list,iter,invar) - endif + if(pm_fast_isnull(condition)) then + call make_block_proc(coder,cblock2,node_arg(node,1),pm_null_obj,& + int(coder%iter_block_amps%offset),pm_null_obj,0,& + stmts,iter,.true.,.false.) else - call call_next(coder,cblock2,list,iter,invar) + call make_block_proc(coder,cblock2,node_arg(node,1),pm_null_obj,& + int(coder%iter_block_amps%offset),& + node_arg(condition,1),1,stmts,iter,.true.,.false.) endif - ! Get elements for next iteration - call code_val(coder,coder%var(iter+lv_end)) - cblock_main=make_cblock(coder,cblock2,stmt,sym_each) - do i=1,nlist/2 - call make_temp_var(coder,cblock_main,stmt) - call dup_code(coder) - call code_val(coder,coder%vstack(lbase+i)) - call code_val(coder,coder%var(iter+lv_idx)) - call make_sys_call(coder,cblock_main,list,sym_get_element,2,1,aflags=rflags) - call make_var_assignment(coder,cblock_main,stmt,coder%var(xbase+i),aflags=rflags) - enddo - if(.not.pm_fast_isnull(node_arg(stmt,2))) then - p=node_arg(stmt,2) - if(node_sym(p)==sym_while) then - call trav_xexpr(coder,cblock_main,p,node_arg(p,1)) - if(invar) then - call code_check_invar(coder,cblock,p,top_code(coder)) - endif - call make_var_assignment(coder,cblock_main,stmt,& - coder%var(iter+lv_end),aflags=rflags) - endif - endif - call close_cblock(coder,cblock_main) - call code_null(coder) - call make_sp_call(coder,cblock2,stmt,merge(sym_if_invar,sym_if,c_invar),3,0) - call close_cblock(coder,cblock2) + call code_val(coder,find_sys_var(coder,node,sym_block_proc_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_inouts_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_ins_a)) + + if(base>=0) call reveal_vars(coder,base+1,dtop) + + call make_iter_lists(coder,cblock2,iter,node_numargs(iter),.true.,.false.) + + call trav_expr(coder,cblock2,node,node_arg(iter,2)) + call make_comm_sys_call_rtn(coder,cblock2,node,sym_hash,1,1) - ! Build call - call code_val(coder,coder%var(iter+lv_end)) - call make_sp_call(coder,cblock,list,sym_each,3,0) + if(base>=0) call hide_where_vars(coder,base+1,xtop) + + sym=node_sym(node) + if(sym==sym_foreach_invar) then + call_sym=sym_pm_foreach_invar_stmt + else + call_sym=sym_pm_foreach_stmt + endif - ! Clean up - coder%par_state=save_par_state - coder%vtop=rbase + call make_full_sys_call(coder,cblock2,node,call_sym,6,0,amps,pm_null_obj,& + pm_null_obj,proccall_is_comm+proccall_is_general) - call pop_vars_to(coder,vbase) + if(node_sym(condition)==sym_while) then + call close_cblock(coder,cblock2) + call code_null(coder) + call get_lex_scope(coder,node) + call make_sp_call(coder,cblock,node,& + sym_if,4,0) + call pop_lex_scope(coder) + endif contains include 'fisnull.inc' - include 'fisname.inc' - include 'fname.inc' - include 'ftiny.inc' - end subroutine trav_foreach_stmt - !========================================================= - ! Call iter,state,end=first(domain) - ! -- Domain must be variable at top of variable (not value) - ! stack and also must not be shared (cannot import) - !========================================================= - function call_start(coder,cblock,list,invar) result(iter) + !==================================================================== + ! Traverse a for or forall statement node + ! converting to a call to PM__for_stmt / PM__forall_stmt + !==================================================================== + subroutine trav_for_stmt(coder,cblock,pnode,node) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,list - logical,intent(in):: invar - integer:: iter,i - integer:: save_run_flags - - if(invar.and.pm_is_compiling) then - save_run_flags=coder%run_flags - coder%run_flags=proc_run_shared+proc_run_always + type(pm_ptr),intent(in):: cblock,pnode,node + type(pm_ptr):: stmts,iter,amps,keys,keynames + integer:: i,base,xtop,dtop + + amps=coder%iter_amps + iter=node_arg(node,1) + keys=node_arg(node,2) + if(pm_fast_isnull(keys)) then + keynames=pm_null_obj + else + keynames=node_arg(keys,2) + keys=node_arg(keys,1) endif + stmts=node_arg(node,4) + + call trav_subexpr(coder,cblock,node,node_arg(node,3),base,xtop,dtop) + if(base>=0) call hide_where_vars(coder,base+1,dtop) - iter=coder%top + call make_block_proc(coder,cblock,node_arg(node,1),pm_null_obj,& + int(coder%iter_block_amps%offset),pm_null_obj,0,stmts,iter,.true.,.true.) - ! Code iter,state,not_end=first(domain) - call make_temp_var(coder,cblock,list) - call make_temp_var(coder,cblock,list) - call make_temp_var(coder,cblock,list) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%var(iter)) - call make_sys_call(coder,cblock,list,sym_first,1,3) + call code_val(coder,find_sys_var(coder,node,sym_block_proc_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_inouts_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_ins_a)) + + if(base>=0) call reveal_vars(coder,base+1,dtop) - ! Loop end - call define_sys_var(coder,cblock,list,sym_for_stmt,& - var_is_shadowed+var_is_var) - ! State - call define_sys_var(coder,cblock,list,sym_pling,& - var_is_shadowed+var_is_var) - ! Iterator - call define_sys_var(coder,cblock,list,sym_iter,& - var_is_shadowed+var_is_var) + call make_iter_lists(coder,cblock,iter,node_numargs(iter),.true.,.true.) - if(invar) then - do i=coder%top-2,coder%top - call code_val(coder,coder%var(i)) - call code_num(coder,sym_mirrored) - call make_basic_sp_call(coder,cblock,list,sym_set_mode,2,0,coder%par_depth) - enddo - if(pm_is_compiling) then - coder%run_flags=save_run_flags - endif + call trav_expr(coder,cblock,node,node_arg(iter,2)) + call make_comm_sys_call_rtn(coder,cblock,node,sym_hash,1,1) + + if(.not.pm_fast_isnull(keys)) then + call trav_exprlist(coder,cblock,node,keys) + call make_code(coder,keys,cnode_is_arglist,node_numargs(keys)) + keys=pop_code(coder) + coder%temp2=keys ! protect from GC endif + + if(base>=0) call hide_where_vars(coder,base+1,xtop) + + call make_full_sys_call(coder,cblock,node,& + merge(sym_pm_for_stmt,sym_pm_forall_stmt,node_sym(node)==sym_for),& + 7,0,amps,keys,keynames,proccall_is_comm+proccall_is_general) - end function call_start + coder%temp2=pm_null_obj + + contains + include 'fisnull.inc' + end subroutine trav_for_stmt - !======================================================== - ! Code either iter,state,end=next(domain,state,iter) - !======================================================== - subroutine call_next(coder,cblock,list,iter,invar) + + !==================================================================== + ! + !==================================================================== + subroutine trav_par_stmt(coder,cblock,pnode,node) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,list - integer,intent(in):: iter - logical,intent(in):: invar - type(pm_ptr):: dvar,ivar,svar,evar - integer:: save_run_flags + type(pm_ptr),intent(in):: cblock,pnode,node + type(pm_ptr):: stmts,iter,amps,keys,keynames + integer:: i,base,xtop,dtop - if(invar.and.pm_is_compiling) then - save_run_flags=coder%run_flags - coder%run_flags=proc_run_shared+proc_run_always + amps=coder%block_amp + keys=node_arg(node,1) + if(pm_fast_isnull(keys)) then + keynames=pm_null_obj + else + keynames=node_arg(keys,2) + keys=node_arg(keys,1) endif + stmts=node_arg(node,3) + + call trav_subexpr(coder,cblock,node,node_arg(node,2),base,xtop,dtop) + if(base>=0) call hide_where_vars(coder,base+1,dtop) + + call make_block_proc(coder,cblock,node,pm_null_obj,& + int(coder%comm_amp%offset),pm_null_obj,0,stmts) + + call code_val(coder,find_sys_var(coder,node,sym_block_proc_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_inouts_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_ins_a)) + + if(base>=0) call reveal_vars(coder,base+1,dtop) - dvar=coder%var(iter) - ivar=coder%var(iter+lv_idx) - svar=coder%var(iter+lv_state) - evar=coder%var(iter+lv_end) - call make_temp_var(coder,cblock,list) - call make_temp_var(coder,cblock,list) - call make_temp_var(coder,cblock,list) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,dvar) - call code_val(coder,svar) - call code_val(coder,ivar) - call make_sys_call(coder,cblock,list,sym_next,3,3) - call make_var_assignment(coder,cblock,list,evar) - call make_var_assignment(coder,cblock,list,svar) - call make_var_assignment(coder,cblock,list,ivar) - - if(invar.and.pm_is_compiling) then - coder%run_flags=save_run_flags + call make_long_const(coder,cblock,node,int((node_numargs(node_arg(stmts,1))-1)/2,pm_ln)) + + if(.not.pm_fast_isnull(keys)) then + call trav_exprlist(coder,cblock,node,keys) + call make_code(coder,keys,cnode_is_arglist,node_numargs(keys)) + keys=pop_code(coder) + coder%temp2=keys ! protect from GC endif - end subroutine call_next + if(base>=0) call hide_where_vars(coder,base+1,xtop) + + call make_full_sys_call(coder,cblock,node,& + sym_pm_par_stmt,4,0,amps,keys,keynames,& + proccall_is_comm+proccall_is_general) - !======================================================== - ! Code a check if value is invariant - !======================================================== - subroutine code_check_invar(coder,cblock,node,val) + coder%temp2=pm_null_obj + + contains + include 'fisnull.inc' + end subroutine trav_par_stmt + + recursive subroutine trav_task(coder,cblock,pnode,node) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node,val - if(var_private(coder,val)) then - call code_val(coder,val) - call make_sp_call(coder,cblock,node,sym_invar,1,0,flags=call_is_no_touch) - endif - end subroutine code_check_invar + type(pm_ptr),intent(in):: cblock,pnode,node + integer:: i,n,save_par_state + type(pm_ptr):: arg,cblock2 + n=node_numargs(node) + do i=2,n,2 + arg=node_arg(node,i) + call make_var(coder,cblock,arg,node_num_arg(arg,1),0) + call make_long_const(coder,cblock,arg,int(i/2,pm_ln)) + call make_sys_call(coder,cblock,arg,sym_clone,1,1) + enddo + call trav_open_stmt_list(coder,cblock,node,node_arg(node,1)) + save_par_state=coder%par_state + coder%par_state=par_state_par + do i=3,n,2 + arg=node_arg(node,i) + call make_temp_var(coder,cblock,node) + call dup_code(coder) + cblock2=make_cblock(coder,cblock,node,sym_task) + call swap_code(coder) + call make_long_const(coder,cblock2,arg,int((i-1)/2,pm_ln)) + call make_comm_sys_call(coder,cblock2,arg,sym_check_task,1,1) + call close_cblock(coder,cblock2) + call trav_stmt_list(coder,cblock,node,arg,sym_task) + enddo + coder%par_state=save_par_state + call make_sp_call(coder,cblock,node,sym_task,3*(n/2),0) + end subroutine trav_task + !======================================================== - ! Iteration clause ' x in A, y in B ' + ! Traverse "all" assignment !======================================================== - recursive subroutine trav_iter(coder,cblock,list,shape_sym,lbase,vbase,nlist) + recursive subroutine trav_all_stmt(coder,cblock,pnode,node) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,list - integer,intent(out):: nlist,lbase,vbase - integer,intent(in):: shape_sym - integer:: i + type(pm_ptr),intent(in):: cblock,pnode,node + integer:: base,xtop + type(pm_ptr):: var,arg1,arg3 + integer:: sym1,sym3 + if(coder%par_state==par_state_none) then + call code_error(coder,node,& + 'Cannot have an "all" statement outside of a parallel context') + elseif(coder%par_state==par_state_cond.or.coder%par_state==par_state_par) then + call code_error(coder,node,& + 'In a conditional statement, an "all" statement must be enclosed by a "sync" statement') + endif - ! Expressions to iterate over - nlist=node_numargs(list) - lbase=coder%vtop - do i=2,nlist,2 - call trav_expr(coder,cblock,list,node_arg(list,i)) - enddo + arg1=node_arg(node,1) + sym1=node_sym(arg1) + arg3=node_arg(node,3) + sym3=node_sym(arg3) - vbase=coder%top - - ! Check that all elements conform - do i=2,nlist/2 - if(node_get_num(list,(i-1)*2+node_args)>0) then - call repl_expr(coder,lbase+1) - call repl_expr(coder,lbase+i) - call make_sys_call(coder,cblock,list,& - sym_check_conform,2,0) - endif - enddo + call trav_subexpr(coder,cblock,node,node_arg(node,4),base,xtop) + call trav_ref_to_var(coder,cblock,node,node_num_arg(node,1),.true.) + var=top_code(coder) - ! Calculate common iteration domain from 1st element in list - call make_temp_var(coder,cblock,list) - call dup_code(coder) - call repl_expr(coder,lbase+1) - call make_sys_call(coder,cblock,list,shape_sym,1,1) - call define_sys_var(coder,cblock,list,sym_for,var_is_shadowed) - end subroutine trav_iter + call trav_expr(coder,cblock,node,node_arg(node,2)) + call trav_expr(coder,cblock,node,arg3) - !=================================================================== - ! Work out the parallel state within a sequential loop - !=================================================================== - function par_state_for_loop(coder,node,oldstate,labelled,invar) result(newstate) + if(node_sym(arg1)==sym_reference) then + !call trav_comm_ref(coder,cblock,node,arg1,.true.,.true.,var) + call make_comm_sys_call(coder,cblock,node,sym_all_stmt,3+node_numargs(arg1),0) + else + call make_comm_sys_call(coder,cblock,node,sym_all_stmt,3,0) + endif + if(base>=0) call hide_where_vars(coder,base+1,xtop) + + end subroutine trav_all_stmt + + + !======================================================== + ! Traverse over statement + !======================================================== + recursive subroutine trav_over_stmt(coder,cblock,pnode,node) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: node - integer,intent(in):: oldstate - logical,intent(in):: labelled,invar - integer:: newstate - if(invar.and.oldstate==par_state_outer) then + type(pm_ptr),intent(in):: cblock,pnode,node + integer:: base,xtop,vbase + type(pm_ptr):: keynames,keys + + if(coder%par_state==par_state_none) then call code_error(coder,node,& - 'Cannot have "invar" loop outside of a parallel context') - elseif(invar.and.oldstate==par_state_nhd) then + 'Cannot have an "over" statement outside of a parallel context') + elseif(coder%par_state>=par_state_masked) then call code_error(coder,node,& - 'Cannot have "invar" loop in the main body of a "nhd" statement') + 'Cannot have an "over" statement inside a conditional statement') endif - if(invar.and.labelled) then - call code_error(coder,node,& - 'An "invar" loop cannot be labelled') + keys=node_arg(node,2) + if(pm_fast_isnull(keys)) then + keynames=pm_null_obj + else + keynames=node_arg(keys,2) + keys=node_arg(keys,1) endif - newstate=oldstate - if(oldstate>=par_state_cond.and.& - oldstate<=par_state_par) then - if(labelled) then - newstate=par_state_cond - else - newstate=par_state_cond_loop - endif - elseif(oldstate==par_state_for) then - newstate=par_state_loop - elseif(labelled) then - if(oldstate==par_state_outer) then - call code_error(coder,node,& - 'Cannot have labelled loop outside of any parallel context') - elseif(oldstate==par_state_nhd) then - call code_error(coder,node,& - 'Cannot have labelled loop in the main body of a "nhd" statement') - elseif(oldstate==par_state_cond_loop) then - call code_error(coder,node,& - 'Cannot have labelled loop inside unlabelled loop within conditional context') - endif + + call trav_subexpr(coder,cblock,node,node_arg(node,3),base,xtop) + + if(.not.pm_fast_isnull(keys)) then + call trav_exprlist(coder,cblock,node,keys) + call make_code(coder,keys,cnode_is_arglist,node_numargs(keys)) + keys=pop_code(coder) + coder%temp2=keys ! protect from GC endif - end function par_state_for_loop - - !============================== - ! Traverse a nhd statement - !============================== - recursive subroutine trav_nhd_stmt(coder,cblock,pnode,node,base) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - integer,intent(in):: base - type(pm_ptr):: list,namelist,loop,cblock2,cblock3,edges - integer:: i,j,k,iter,var,nlist,nvars - integer:: stmt_base,nhd_base,join_base,expr_base,env_base - integer:: nvar_base,block_base,bounds_base,over_base - integer:: save_par_state - ! node for nhd statement is - ! (nhd (name expr)*)*,bounds,attr,subexp,block + call trav_expr(coder,cblock,node,node_arg(node,1)) + vbase=coder%vtop - ! Last variable outside statement - stmt_base=coder%top + if(base>=0) call hide_where_vars(coder,base+1,xtop) + + call make_block_proc(coder,cblock,node,& + pm_null_obj,& + int(coder%comm_amp%offset),pm_null_obj,0,& + node_arg(node,4)) + call code_val(coder,find_sys_var(coder,node,sym_block_proc_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_inouts_a)) + call code_val(coder,find_sys_var(coder,node,sym_block_ins_a)) + call code_val(coder,coder%vstack(vbase)) + call make_full_sys_call(coder,cblock,node,sym_pm_over_stmt,4,0,& + coder%block_amp,keys,keynames,& + proccall_is_comm+proccall_is_general) + call drop_code(coder) + coder%temp2=pm_null_obj + contains + include 'fisnull.inc' + end subroutine trav_over_stmt + + !================================================================================= + ! Create code to create up to three lists of values + ! derived from expressions in an iterator node: + ! [ amp_values ] values [ star_values ] + ! relating to &x in Y, x in Y and *x in Y iterator entries respectively + ! + ! Also codes any necessary alias checks between "&" items and other items + !================================================================================== + subroutine make_iter_lists(coder,cblock,node,n,may_have_amp,may_have_star) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: n + logical,intent(in):: may_have_amp,may_have_star + type(pm_ptr):: arg,arg2 + integer:: i,j,k,kind,m,sym,name,base,base2,nalias - ! Traverse bounds - call trav_expr(coder,cblock,node,node_arg(node_arg(node,2),1)) - call define_sys_var(coder,cblock,node,sym_bounds,var_is_shadowed) - bounds_base=coder%top - - ! Check bounds - call make_comm_call_args(coder,cblock,node) - call dup_expr(coder,coder%var(bounds_base)) - call make_comm_sys_call(coder,cblock,node_arg(node,2),sym_check_bounds,1,0) - - ! Traverse block attribute - call trav_expr(coder,cblock,node,node_arg(node_arg(node,3),1)) - call define_sys_var(coder,cblock,node,sym_sub,var_is_shadowed) - block_base=coder%top - - ! Traverse nhd expressions - ! Leave nhd descriptors on vstack above nhd_base - nhd_base=coder%vtop - list=node_arg(node,1) - nlist=node_numargs(list) - do i=1,nlist,2 - call make_temp_var(coder,cblock,list) - call dup_code(coder) - call make_comm_call_args(coder,cblock,node) - call trav_expr(coder,cblock,list,node_arg(list,i)) - call code_val(coder,coder%var(bounds_base)) - call make_comm_sys_call(coder,cblock,list,sym_pm_nhd,2,1) - enddo + base=coder%vtop - ! Compute the envelope of the NHDs - call dup_expr(coder,coder%vstack(nhd_base+1)) - if(nlist<=3) then - call make_temp_var(coder,cblock,node) - call swap_and_dup_code(coder) - call make_sys_call(coder,cblock,node,sym_envelope,1,1,& - aflags=merge(proc_run_shared+proc_run_always+call_inline_when_compiling,& - 0,pm_is_compiling)) - else - do i=1,nlist/3 - call make_temp_var(coder,cblock,node) - call swap_and_dup_code(coder) - call dup_expr(coder,coder%vstack(nhd_base+i)) - call make_sys_call(coder,cblock,node,sym_envelope,2,1,& - aflags=merge(proc_run_shared+proc_run_always+call_inline_when_compiling,& - 0,pm_is_compiling)) + ! Check for any potential aliases + if(may_have_amp) then + do i=1,n,2 + if(node_sym(node_arg(node,i))==sym_amp) then + arg=node_arg(node,i+1) + name=node_num_arg(arg,1) + kind=node_sym(arg) + do j=1,n,2 + if(j/=i) then + arg2=node_arg(node,j+1) + k=node_sym(arg2) + if(k==sym_name.or.k==sym_reference) then +!!$ call check_aliased(coder,cblock,arg,arg2,& +!!$ '"&" item aliases with another item') + endif + endif + enddo + endif enddo endif - call define_sys_var(coder,cblock,node,sym_envelope,var_is_shadowed) - env_base=coder%top - - ! Compute active area taking account of boundaries - call make_sys_var(coder,cblock,node,sym_nhd_active,var_is_shadowed) - call code_val(coder,coder%var(coder%par_base+lv_dom)) - call code_val(coder,coder%var(env_base)) - call code_val(coder,coder%var(bounds_base)) - call make_sys_call(coder,cblock,node,sym_nhd_active,3,1,aflags=proc_run_shared+proc_run_always) - ! Traverse expressions - expr_base=coder%vtop - do i=1,nlist,2 - namelist=node_arg(list,i+1) - do j=1,node_numargs(namelist),2 - call trav_expr(coder,cblock,node,node_arg(namelist,j+1)) - enddo - enddo - - ! Hide any where clauses - if(base>=0) then - call hide_vars(coder,base+1,coder%top) - endif - - - ! Create extended tile variables - nvar_base=coder%top - nvars=0 - do i=1,nlist,2 - namelist=node_arg(list,i+1) - do j=1,node_numargs(namelist),2 - nvars=nvars+1 - call make_var(coder,cblock,namelist,node_arg(node_arg(namelist,j),1),var_is_shadowed) - call make_comm_call_args(coder,cblock,node) - call code_val(coder,coder%vstack(expr_base+nvars)) - call code_val(coder,coder%vstack(nhd_base+(i+2)/2)) - call code_val(coder,coder%var(coder%par_base+lv_index)) - call code_val(coder,coder%var(coder%par_base+lv_here)) - call make_comm_sys_call(coder,cblock,node_arg(namelist,j),sym_nhd_var,4,1) + ! Now evaluate each value + if(may_have_amp) then + do i=1,n,2 + arg=node_arg(node,i+1) + k=node_sym(arg) + if(k==sym_name.or.k==sym_reference) then + call trav_reference(coder,cblock,node,arg,& + node_sym(node_arg(node,i))==sym_amp,.true.,.false.) + else + call trav_expr(coder,cblock,node,node_arg(node,i+1)) + endif enddo - enddo - - ! Initialise extended tile variables - k=1 - do i=1,nlist,2 - namelist=node_arg(list,i+1) - do j=1,node_numargs(namelist),2 - call make_comm_call_args(coder,cblock,node) - call code_val(coder,coder%var(nvar_base+k)) - call code_val(coder,coder%vstack(expr_base+k)) - call make_comm_sys_call(coder,cblock,node_arg(namelist,j),sym_set_nhd,2,0,assign=.true.) - k=k+1 + else + do i=1,n,2 + call trav_expr(coder,cblock,node,node_arg(node,i+1)) enddo + endif + + ! Create conformity checks + call dup_expr(coder,coder%vstack(base+1)) + call make_sys_call(coder,cblock,node,check_fn(node_arg(node,1)),1,0) + do i=2,n/2 + call dup_expr(coder,coder%vstack(base+i)) + call dup_expr(coder,coder%vstack(base+1)) + call make_sys_call(coder,cblock,node,check_fn(node_arg(node,i*2-1)),2,0) enddo - ! join extended tile variables in each nhd into a list for each nhd - join_base=coder%vtop - k=1 - do i=1,nlist,2 - namelist=node_arg(list,i+1) + ! Finally create the lists + base2=coder%vtop + + if(may_have_amp) then call make_temp_var(coder,cblock,node) call dup_code(coder) - call code_val(coder,coder%var(k+nvar_base)) - call make_sys_call(coder,cblock,node,sym_nhd_join,1,1,& - aflags=proc_run_shared+proc_run_always+call_ignore_rules+call_inline_when_compiling) - k=k+1 - do j=3,node_numargs(namelist),2 - call make_temp_var(coder,cblock,node) - call swap_and_dup_code(coder) - call code_val(coder,coder%var(k+nvar_base)) - call make_sys_call(coder,cblock,node,sym_nhd_join,2,1,& - aflags=proc_run_shared+proc_run_always+call_ignore_rules+call_inline_when_compiling) - k=k+1 + m=0 + do i=1,n,2 + if(node_sym(node_arg(node,i))==sym_amp) then + call code_val(coder,coder%vstack(base+(i+1)/2)) + m=m+1 + endif enddo - enddo - - ! Send intersecting boundaries - do i=1,nlist/2 - call make_comm_call_args(coder,cblock,node) - call code_val(coder,coder%vstack(join_base+i)) - call code_val(coder,coder%vstack(nhd_base+i)) - call code_val(coder,coder%var(bounds_base)) - call make_comm_sys_call(coder,cblock,node,sym_send_nhd,3,0,assign=.true.) - enddo - - call make_const(coder,cblock,node,coder%true) - call define_sys_var(coder,cblock,node,sym_in_interior,var_is_shadowed) - var=coder%top - - ! Check we are in an acceptable parallel context - if(coder%par_state==par_state_outer) then - call code_error(coder,node,& - 'Cannot have "nhd" statement outside of any parallel context') - elseif(coder%par_state==par_state_nhd) then - call code_error(coder,node,& - 'Cannot have "nhd" statement in the main body of another "nhd" statement') - elseif(coder%par_state>=par_state_cond) then - call code_error(coder,node,& - 'Cannot have "nhd" statement in a conditional context') + call make_basic_sp_call(coder,cblock,node,sym_pm_list,m,1) endif - save_par_state=coder%par_state - coder%par_state=par_state_nhd - - ! Get shape of chunks to iterate over call make_temp_var(coder,cblock,node) call dup_code(coder) - call code_val(coder,coder%var(coder%par_base+lv_tile)) - call code_val(coder,coder%var(env_base)) - call make_sys_call(coder,cblock,node,sym_chunks,2,1,aflags=proc_run_shared+proc_run_always) - call define_sys_var(coder,cblock,node,sym_for,var_is_shadowed) - iter=call_start(coder,cblock,list,.true.) - - ! Run code block over chunk[0] -- interior of tile - call make_sys_var(coder,cblock,node,sym_subregion,var_is_shadowed) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - over_base=coder%top - call make_comm_call_args(coder,cblock,node) - call make_temp_var(coder,cblock,node) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - call dup_code(coder) - call code_val(coder,coder%var(coder%par_base+lv_tile)) - call code_val(coder,coder%var(env_base)) - call code_val(coder,coder%var(iter+lv_idx)) - call code_val(coder,coder%var(env_base+1)) - call make_sys_call(coder,cblock,node,sym_get_chunk,4,1,aflags=proc_run_shared+proc_run_always) - call code_val(coder,coder%var(block_base)) - call make_comm_sys_call(coder,cblock,node_arg(node,5),sym_pm_over,2,1) - call make_do_over(coder,cblock,node,node,node_arg(node,5),over_base) - - call code_val(coder,coder%var(var)) - - ! RECV intersecting boundaries - do i=1,nlist/2 - call make_comm_call_args(coder,cblock,node) - call code_val(coder,coder%vstack(join_base+i)) - call code_val(coder,coder%vstack(nhd_base+i)) - call code_val(coder,coder%var(bounds_base)) - call make_comm_sys_call(coder,cblock,node,sym_recv_nhd,3,0,assign=.true.) + m=0 + do i=1,n,2 + sym=node_sym(node_arg(node,i)) + if(sym/=sym_amp.and.sym/=sym_mult) then + call code_val(coder,coder%vstack(base+(i+1)/2)) + m=m+1 + endif enddo + call make_basic_sp_call(coder,cblock,node,sym_pm_list,m,1) + if(may_have_star) then + call make_temp_var(coder,cblock,node) + call dup_code(coder) + m=0 + do i=1,n,2 + if(node_sym(node_arg(node,i))==sym_mult) then + call code_val(coder,coder%vstack(base+(i+1)/2)) + m=m+1 + endif + enddo + call make_basic_sp_call(coder,cblock,node,sym_pm_list,m,1) + endif - ! Sync messages - do i=1,nlist/2 - call code_val(coder,coder%vstack(join_base+i)) - call make_basic_sys_call(coder,cblock,node,sym_sync_messages,1,0,coder%par_depth,0) + ! Copy lists back down + j=coder%vtop + coder%vtop=base + do i=base2+1,j + coder%vtop=coder%vtop+1 + coder%vstack(coder%vtop)=coder%vstack(i) enddo - ! Bcast boundaries - do i=1,nlist/2 - call make_comm_call_args(coder,cblock,node) - call code_val(coder,coder%vstack(join_base+i)) - call code_val(coder,coder%vstack(nhd_base+i)) - call code_val(coder,coder%var(env_base+1)) - call make_comm_sys_call(coder,cblock,node,sym_bcast_nhd,3,0,assign=.true.) - enddo + contains - call call_next(coder,cblock,list,iter,.true.) + function check_fn(node) result(fn) + type(pm_ptr),intent(in):: node + integer:: fn + integer:: k + k=node_sym(node) + if(k==sym_amp) then + fn=sym_check_iter_amp + elseif(k==sym_mult) then + fn=sym_check_iter_star + else + fn=sym_check_iter + endif + end function check_fn + + end subroutine make_iter_lists - if(pm_is_compiling) then - call make_sys_var(coder,cblock,node,sym_while,& - var_is_shadowed) + !============================================================================ + ! Create code to extract variables defined by iter node (node) from named + ! list variable PM__amp_iter_args, PM__iter_args and PM__star iter args as + ! appropriate depending on whether iter entry is &x in Y, x in Y or *x in Y + !=========================================================================== + subroutine extract_iter_lists(coder,cblock,node,may_have_amp,may_have_star) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + logical,intent(in):: may_have_amp,may_have_star + integer:: i,m,n,sym + type(pm_ptr)::p,avar + n=node_numargs(node) + if(may_have_amp) then + avar=find_sys_var(coder,node,sym_amp_iter_args) + m=1 + do i=1,n,2 + p=node_arg(node,i) + if(node_sym(p)==sym_amp) then + call make_var(coder,cblock,node,node_num_arg(p,1),var_is_var+var_is_ref) + call extract_var(coder,cblock,node,pop_code(coder),avar,m) + m=m+1 + endif + enddo + endif + avar=find_sys_var(coder,node,sym_iter_args) + m=1 + do i=1,n,2 + p=node_arg(node,i) + sym=node_sym(p) + if(sym/=sym_amp.and.sym/=sym_mult) then + call make_var(coder,cblock,node,int(p%offset),0) + call extract_var(coder,cblock,node,pop_code(coder),avar,m) + m=m+1 + endif + enddo + if(may_have_star) then + avar=find_sys_var(coder,node,sym_star_iter_args) + m=1 + do i=1,n,2 + if(node_sym(node_arg(node,i))==sym_mult) then + call make_var(coder,cblock,node,node_num_arg(p,1),0) + call extract_var(coder,cblock,node,pop_code(coder),avar,m) + m=m+1 + endif + enddo + endif + end subroutine extract_iter_lists + + !====================================================================================== + ! Turns a block (stmtlist) into a procedure + ! Pushes 3 elements onto vstack + ! procedure value defining block + ! list of changed variables + ! list of accessed variables + ! Parameter list for block procedure starts with + ! PM__inouts_a PM__ins_a + ! - code is added to the start of the procedure body to disaggregate these + ! parameters from lists back into changed and accessed variables respectively + ! If iters is not present + ! - The remaining block-procedure parameters are defined by (namelist,amps) + ! If iters is present + ! -the remaining block-procedure parameters are + ! [ & PM__amp_iter_args ] PM__iter_args [ PM__star_iter_args ] + ! and namelist (but not amps) is disregarded + ! Extra disaggregation code for iter parameters is added inside the block + !====================================================================================== + subroutine make_block_proc(coder,cblock,node,namelist,amps,rtns,nret,stmtlist,iters,iter_amps,iter_stars) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node,namelist,rtns,stmtlist + integer,intent(in):: amps,nret + type(pm_ptr),intent(in),optional:: iters + logical,intent(in),optional:: iter_amps,iter_stars + + type(pm_ptr):: cblock2,cblock3,proc + integer:: nargs,base,i,partype,restype,flags,vbase + logical:: varargs + integer:: save_index,save_ncalls,save_state_base,save_mask,save_par_state + integer:: name,signo,flags0,args(1) + character(len=15):: namestr + + if(present(iters)) then + nargs=1+merge(1,0,iter_amps)+merge(1,0,iter_stars) else - call code_null(coder) + nargs=node_numargs(namelist) endif + + varargs=node_sym(namelist)==sym_dotdotdot + flags=proccall_is_comm+proccall_is_general - ! Run code block over each edge chunk - cblock2=make_cblock(coder,cblock,node,sym_nhd) - call code_val(coder,coder%var(over_base)) - call make_comm_call_args(coder,cblock2,node) - call make_temp_var(coder,cblock2,node) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - call dup_code(coder) - call code_val(coder,coder%var(coder%par_base+lv_tile)) - call code_val(coder,coder%var(env_base)) - call code_val(coder,coder%var(iter+lv_idx)) - call code_val(coder,coder%var(env_base+1)) - call make_sys_call(coder,cblock2,node,sym_get_chunk,4,1,aflags=proc_run_shared+proc_run_always) - call code_val(coder,coder%var(block_base)) - call make_comm_sys_call(coder,cblock2,node_arg(node,5),sym_pm_over,2,1) - call make_do_over(coder,cblock2,node,node,node_arg(node,5),over_base) - call call_next(coder,cblock2,list,iter,.true.) - call code_val(coder,coder%var(iter+lv_end)) - call close_cblock(coder,cblock2) - call make_sp_call(coder,cblock,node,sym_each,3,0) - - ! Clean up - coder%vtop=nhd_base - coder%par_state=save_par_state + ! Parameter type + call push_word(coder,merge(pm_type_new_vtuple,pm_type_new_tuple,varargs)) + call push_word(coder,amps) + do i=1,nargs+8 + call push_word(coder,0) + enddo + call make_type(coder,nargs+10) + partype=pop_word(coder) - call pop_vars_to(coder,stmt_base) - contains - include 'fisnull.inc' - end subroutine trav_nhd_stmt + ! Result type + call push_word(coder,pm_type_is_undef_result) + call push_word(coder,nret) + call make_type(coder,2) + restype=pop_word(coder) + ! Create block proc name + coder%block_id=coder%block_id+1 + namestr='PM__block'//trim(pm_int_as_string(coder%block_id)) + name=pm_name2(coder%context,sym_block,pm_name_entry(coder%context,namestr)) - !************************************************** - ! PARALLEL STATEMENTS - !************************************************** - - !======================================================== - ! Traverse a for statement - !======================================================== - recursive subroutine trav_for_stmt(coder,cblock,listp,list,base,stmt) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,listp,list,stmt - integer,intent(in):: base - type(pm_ptr):: var,vlist - type(pm_ptr):: cblock2,cblock3,cblock4 - type(pm_ptr):: cblock_main,cblock_pre,cblock_post - integer:: i,j,k,n,lbase,vbase - integer:: nlist,iter,iter2,sym,rbase,wbase,name,flags,sindex,sbase - integer:: slot1,slot2,outmode - integer(pm_p)::flag - type(pm_ptr):: vlhs,procs,sig,xvar,p - integer:: save_par_base,save_over_base,save_par_state,save_run_mode - type(pm_ptr):: save_loop_cblock - logical:: iscomm,outer,is_conc - - sym=node_sym(stmt) - is_conc=node_get_num(stmt,node_args+2)==sym_conc - rbase=coder%vtop - wbase=coder%wtop - - call trav_iter(coder,cblock,list,sym_hash,lbase,vbase,nlist) - - save_par_base=coder%par_base - save_over_base=coder%over_base - save_loop_cblock=coder%loop_cblock - save_par_state=coder%par_state - save_run_mode=coder%run_mode + call make_sys_var(coder,cblock,node,sym_block_proc_a,var_is_shadowed) - ! Start parallel loop call - iter=code_par_scope_start(coder,cblock,stmt,coder%var(coder%top),& - node_arg(stmt,1),& - cblock_main,cblock_pre,sym_for_stmt,.false.) - - slot1=coder%index + ! Create proc object + call code_num(coder,partype) + call code_num(coder,restype) + call code_num(coder,nargs) + call code_num(coder,nret) + call code_num(coder,flags) + call code_num(coder,amps) + call code_num(coder,name) + cblock2=make_cblock(coder,cblock,stmtlist,sym_do_stmt) + call code_num(coder,0) + call code_num(coder,0) + coder%id=coder%id+1 + call code_num(coder,coder%id) + call code_num(coder,0) + call code_null(coder) + call code_null(coder) + call code_null(coder) + call code_null(coder) + call code_null(coder) + call make_code(coder,node,cnode_is_proc,pr_node_size) + proc=top_code(coder) + + ! Create one-element signature + call make_code(coder,node,cnode_is_callsig,1) + + args(1)=name + signo=pm_idict_add(coder%context,coder%sig_cache,& + args,1,pop_code(coder)) - ! Hide any where clauses (may need them later) - if(base>=0) then - call hide_vars(coder,base+1,coder%top) - endif + ! Create procedure value type + call push_word(coder,pm_type_new_proc) + call push_word(coder,name) + call push_word(coder,pm_type_new_proc_sig) + call push_word(coder,sym_dash) + call push_word(coder,partype) + call push_word(coder,restype) + call make_type(coder,4) + call make_type(coder,3) - sindex=iter+lv_here - - ! Create array/domain element variables for this iteration - sbase=coder%top - do i=1,nlist,2 - var=node_arg(list,i) - if(node_sym(var)==sym_mult) then - call make_var(coder,cblock_main,list,& - node_arg(var,1),var_is_var) - else - call make_var(coder,cblock_main,list,& - var,var_is_var) - endif - enddo - - ! Get array/domain elements for this iteration - do i=1,nlist/2 - if(node_sym(node_arg(list,i*2-1))==sym_mult) then - call code_val(coder,coder%var(sbase+i)) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - call code_val(coder,coder%vstack(lbase+i)) - if(pm_is_compiling) then - call make_sys_call(coder,cblock_main,list,sym_make_dollar,1,1,& - aflags=call_ignore_rules+proc_run_shared+proc_run_always) - else - call make_basic_sys_call(coder,cblock_main,list,sym_make_dollar,1,1,& - coder%par_depth-1,call_ignore_rules) - endif - else - call code_val(coder,coder%var(sbase+i)) - call code_val(coder,coder%var(iter+lv_distr)) - call code_val(coder,coder%var(coder%over_base)) - call code_val(coder,coder%var(iter+lv_here)) - call code_val(coder,coder%vstack(lbase+i)) - call code_val(coder,coder%var(iter+lv_index)) - call code_val(coder,coder%var(sindex)) - call make_comm_sys_call(coder,cblock_main,list,sym_for_get_element,3,1) - call code_val(coder,coder%var(sbase+i)) - call make_sp_call(coder,cblock_main,list,sym_coherent,1,0) - endif - enddo - - ! Main body - coder%par_state=par_state_for - coder%run_mode=sym_complete - call trav_open_stmt_list(coder,cblock_main,stmt,node_arg(stmt,4)) - - if(base>=0) call reveal_vars(coder,base,vbase) - - ! Export variables that have changed - do i=1,nlist/2 - var=coder%var(sbase+i) - if(cnode_flags_set(var,var_flags,var_is_changed)) then - call code_val(coder,coder%var(iter+lv_distr)) - call code_val(coder,coder%var(coder%over_base)) - call code_val(coder,coder%var(iter+lv_here)) - outmode=trav_ref(coder,cblock_main,node_arg(list,i*2),& - node_arg(list,i*2),ref_ignores_rules) - call code_val(coder,var) - call code_val(coder,coder%var(iter+lv_index)) - call code_val(coder,coder%var(sindex)) - call make_comm_sys_call(coder,cblock_main,stmt,& - sym_for_set_element,4,0,assign=.true.,& - aflags=call_is_comm+call_inline_when_compiling) - endif - enddo - slot2=coder%index - - ! Complete parallel for call - call code_par_scope_end(coder,iter,list,cblock,& - cblock_main,cblock_pre,save_par_base,slot1,slot2,is_conc,.false.) - - coder%par_base=save_par_base - coder%over_base=save_over_base - coder%loop_cblock=save_loop_cblock - coder%par_state=save_par_state - coder%run_mode=save_run_mode - - if(base>=0) call hide_vars(coder,base,sbase) - - ! Clean up - coder%vtop=rbase - - call pop_vars_to(coder,vbase) + call make_const(coder,cblock,node,& + pm_fast_name(coder%context,name),pop_word(coder)) + call make_sys_call(coder,cblock,node,sym_clone,1,1) + save_index=coder%index + save_ncalls=coder%proc_ncalls + coder%index=0 + coder%proc_ncalls=0 - contains - include 'fisnull.inc' - include 'fisname.inc' - include 'fname.inc' - include 'ftiny.inc' - end subroutine trav_for_stmt - + call push_block_scope(coder,cblock2) - !======================================================== - ! Traverse par { } - !======================================================== - recursive subroutine trav_par_stmt(coder,cblock,pnode,node) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - type(pm_ptr):: let,clause,cblock_main,cblock_pre,cblock_post - type(pm_ptr):: vlist,save_loop_cblock - integer:: i,j,k,iter,istart,vstart,base,rbase,m - integer:: save_par_base,save_over_base,save_par_state - integer:: slot1,slot2 - integer:: name,flags - - vstart=coder%vtop - save_loop_cblock=coder%loop_cblock - save_par_base=coder%par_base - save_over_base=coder%over_base - save_par_state=coder%par_state - base=coder%top + vbase=coder%vtop - if(node_numargs(node)==4) then - call code_error(coder,node,'"par" statement has only one branch') - coder%vtop=vstart - return - endif + save_state_base=coder%state_base + save_mask=coder%mask + coder%state_base=coder%top - ! Variable sym_for - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call make_long_const(coder,cblock,node,& - int((node_numargs(node)-2)/2,pm_ln)) - call make_sys_call(coder,cblock,node,sym_array,1,1) - call define_sys_var(coder,cblock,node,sym_for,var_is_shadowed) + ! Create state variable parameters + call make_sys_var(coder,cblock2,node,sym_topology,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,node,sym_outer,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,node,sym_region,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,node,sym_subregion,var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,node,sym_here_in_tile,& + var_is_param+var_is_shadowed) + call make_sys_var(coder,cblock2,node,sym_mask,var_is_param+var_is_shadowed) + + ! Create variables for block imports and exports + call make_sys_var(coder,cblock2,node,& + sym_block_inouts,var_is_param+var_is_ref+var_is_var+var_is_shadowed) + call make_sys_var(coder,cblock2,node,& + sym_block_ins,var_is_param+var_is_shadowed) + + ! Remaining parameter variables + if(present(iters)) then + flags0=var_is_maybe_not_private + if(iter_amps) then + call make_sys_var(coder,cblock2,node,& + sym_amp_iter_args,flags0+var_is_param+var_is_ref+var_is_var+var_is_shadowed) + endif + call make_sys_var(coder,cblock2,node,& + sym_iter_args,flags0+var_is_param+var_is_shadowed) + if(iter_stars) then + call make_sys_var(coder,cblock2,node,& + sym_star_iter_args,flags0+var_is_param+var_is_shadowed) + endif + call make_basic_sp_call(coder,cblock2,node,& + sym_open,coder%vtop-vbase,0) + else + call trav_params(coder,cblock2,namelist,amps,1,8) + endif + call code_val(coder,coder%var(base+4)) + cblock3=make_cblock(coder,cblock2,stmtlist,sym_do_stmt) + coder%lex_scope=push_lex_scope(coder) - ! Partition the domain across processors - iter=code_par_scope_start(coder,cblock,node,coder%var(coder%top),& - node_arg(node,1),cblock_main,cblock_pre,sym_also,.false.) + if(present(iters)) then + call extract_iter_lists(coder,cblock3,iters,iter_amps,iter_stars) + endif - slot1=coder%index + save_par_state=coder%par_state + coder%par_state=par_state_comm_proc - do i=3,node_numargs(node),2 - call make_long_const(coder,cblock_main,node,int((i-2)/2,pm_ln)) - call make_definition(coder,cblock_main,node,node_arg(node,i),0) - enddo + call trav_open_stmt_list(coder,cblock3,node,stmtlist) + + call trav_xexpr(coder,cblock3,node,rtns) + call make_sp_call(coder,cblock3,node,sym_result,nret,0) - coder%par_state=par_state_for + coder%par_state=save_par_state - ! statements before any branch - call trav_open_stmt_list(coder,cblock_main,node,node_arg(node,2)) - - coder%par_state=par_state_par + call pop_lex_scope(coder) + call close_cblock(coder,cblock3) - ! branches - call branch(cblock_main,3) + call extract_block_vars(coder,cblock2,node,coder%var(base+7),.true.) + call extract_block_vars(coder,cblock2,node,coder%var(base+8),.false.) + + call make_sp_call(coder,cblock2,node,sym_pct,2,0) - slot2=coder%index - ! Build parallel statement call - call code_par_scope_end(coder,iter,node,cblock,cblock_main,& - cblock_pre,& - save_par_base,slot1,slot2,.false.,.false.) + call cnode_set_num(proc,pr_max_index,coder%index) + call cnode_set_num(proc,pr_ncalls,coder%proc_ncalls) + coder%index=save_index + coder%proc_ncalls=save_ncalls + coder%state_base=save_state_base + coder%mask=save_mask - coder%vtop=vstart - coder%loop_cblock=save_loop_cblock - coder%par_base=save_par_base - coder%over_base=save_over_base - call pop_vars_to(coder,base) + call close_cblock(coder,cblock2) + + ! This also pushes lists of changed and accessed variables + call pop_block_scope(coder,cblock,node,present(iters)) + contains include 'fisnull.inc' - include 'ftiny.inc' - - recursive subroutine branch(cblock,i) - type(pm_ptr),intent(in):: cblock - integer,intent(in):: i - type(pm_ptr):: cblock4,cblock5 - type(pm_ptr):: prc_test_var - - ! Is this branch running on this processor? - call make_temp_var(coder,cblock,node) - prc_test_var=top_code(coder) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call make_long_const(coder,cblock,node,int((i-2)/2,pm_ln)) - call make_sys_call(coder,cblock,node,sym_tuple,1,1) - call code_val(coder,coder%var(iter+lv_here)) - call make_sys_call(coder,cblock,node,sym_eq,2,1) - - if(i/=cnode_numargs(node)-1) then - cblock4=make_cblock(coder,cblock,node,sym_also) - call drop_code(coder) - else - cblock4=cblock - endif - - ! do clause - call trav_open_stmt_list(coder,cblock4,node,node_arg(node,i+1)) - - if(i/=node_numargs(node)-1) then - ! If statment (if running_here then ... endif) - call close_cblock(coder,cblock4) - call code_val(coder,prc_test_var) - call code_val(coder,cblock4) - cblock5=make_cblock(coder,cblock,node,sym_also) - call branch(cblock5,i+2) - call close_cblock(coder,cblock5) - call make_sp_call(coder,cblock,node,sym_if,3,0) - endif - end subroutine branch - - end subroutine trav_par_stmt + include 'fname.inc' + end subroutine make_block_proc - !======================================================== - ! traverse { : } expression - !======================================================== - recursive subroutine trav_par_expr(coder,cblock,node) + !=============================================================== + ! Create code to disaggregate variables from list variable avar + ! Variables are obtained from the access/change list + ! for current block scope and only included if their change + ! status (modified=> true) is equal to access + !=============================================================== + subroutine extract_block_vars(coder,cblock,node,avar,access) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node - integer:: iter,slot1,slot2,lbase,vbase,nlist,base - integer:: sbase,i,save_par_base,save_over_base,save_par_state - type(pm_ptr):: rvar,var,cblock_main,cblock_pre,list,save_loop_cblock + type(pm_ptr),intent(in):: cblock,node,avar + logical,intent(in):: access - list=node_arg(node,2) -!!$ if(.not.pm_is_compiling) call make_temp_var(coder,cblock,node) - call make_temp_var(coder,cblock,node) - base=coder%vtop - rvar=top_code(coder) - - call trav_iter(coder,cblock,list,sym_hash,lbase,vbase,nlist) + type(pm_ptr):: p,var + integer:: index,i - save_par_base=coder%par_base - save_loop_cblock=coder%loop_cblock - save_par_state=coder%par_state - save_over_base=coder%over_base - - iter=code_par_scope_start(coder,cblock,node,coder%var(coder%top),pm_null_obj,& - cblock_main,cblock_pre,sym_for_stmt,.false.) - slot1=coder%index - - ! Get array/domain elements - sbase=coder%top - do i=1,nlist,2 - var=node_arg(list,i) - if(node_sym(var)==sym_mult) var=node_arg(var,1) - call make_var(coder,cblock_main,node,& - var,0) - enddo - do i=1,nlist/2 - if(node_sym(node_arg(list,i*2-1))==sym_mult) then - call code_val(coder,coder%var(sbase+i)) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - call code_val(coder,coder%vstack(lbase+i)) - if(pm_is_compiling) then - call make_sys_call(coder,cblock_main,list,sym_make_dollar,1,1,& - aflags=call_ignore_rules+proc_run_shared+proc_run_always) - else - call make_basic_sys_call(coder,cblock_main,list,sym_make_dollar,1,1,& - coder%par_depth-1,call_ignore_rules) - endif - else - call code_val(coder,coder%var(sbase+i)) - call code_val(coder,coder%var(iter+lv_distr)) - call code_val(coder,coder%var(coder%over_base)) - call code_val(coder,coder%var(iter+lv_here)) - call code_val(coder,coder%vstack(lbase+i)) - call code_val(coder,coder%var(iter+lv_index)) - call code_val(coder,coder%var(iter+lv_index)) - call make_comm_sys_call(coder,cblock_main,node,sym_for_get_element,3,1) + index=coder%wstack(coder%block_entry+3) + p=coder%vstack(index) + i=1 + do while(.not.pm_fast_isnull(p)) + index=p%data%ptr(p%offset)%offset + var=coder%var(index) + if(iand(cnode_get_num(var,var_flags),var_is_changed)/=0.eqv.access) then + call extract_var(coder,cblock,node,coder%var(index),avar,i) + i=i+1 endif + p=p%data%ptr(p%offset+1) enddo - coder%par_state=par_state_for - call code_val(coder,rvar) - if(.not.pm_is_compiling) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - endif - call make_comm_call_args(coder,cblock,node) - if(pm_is_compiling) then - call make_temp_var(coder,cblock_main,node) - call dup_code(coder) - endif + contains + include 'fisnull.inc' + end subroutine extract_block_vars - call trav_expr(coder,cblock_main,node,node_arg(node,1)) - - if(pm_is_compiling) then - call make_sys_call(coder,cblock_main,node,sym_dup,1,1,aflags=call_ignore_rules) - endif - call dup_code(coder) - call code_num(coder,sym_chan) - call make_basic_sp_call(coder,cblock_main,node,sym_set_mode,2,0,coder%par_depth) - call make_comm_sys_call(coder,cblock_main,node,sym_make_array,1,1) - if(.not.pm_is_compiling) then - call make_basic_sp_call(coder,cblock_main,node,sym_export_as_new,& - 1,1,coder%par_depth) - endif - - slot2=coder%index - call code_par_scope_end(coder,iter,node,cblock,cblock_main,& - cblock_pre,save_par_base,slot1,slot2,.true.,.false.) - coder%par_base=save_par_base - coder%over_base=save_over_base - coder%par_state=save_par_state - coder%loop_cblock=save_loop_cblock - call pop_vars_to(coder,vbase) -!!$ if(.not.pm_is_compiling) then -!!$ call make_basic_sys_call(coder,cblock,node,sym_correct_array,1,1,coder%loop_depth,0) -!!$ endif - coder%vtop=base - end subroutine trav_par_expr + !=========================================================== + ! Make code to extract index'th element of list avar to var + !=========================================================== + subroutine extract_var(coder,cblock,node,var,avar,index) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node,var,avar + integer,intent(in):: index + call code_val(coder,var) + call code_val(coder,avar) + call make_long_const(coder,cblock,node,int(index,pm_ln)) + call make_basic_sp_call(coder,cblock,node,sym_dot,2,1) +!!$ call make_comm_sys_call(coder,cblock,node,sym_elem_at_index,2,1,& +!!$ aflags=proccall_is_ref+proccall_is_general,assign=.true.) + end subroutine extract_var !======================================================== - ! Over statement + ! Push a new block scope record onto wstack and vstack !======================================================== - recursive subroutine trav_over_stmt(coder,cblock,pnode,node) + subroutine push_block_scope(coder,cblock) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - integer:: base,save_par_state,save_over_base - integer:: save_run_mode,save_run_flags - type(pm_ptr):: p,stmt_list,attr,cblock2 - logical:: ok - - if(coder%par_state==par_state_outer)then - call code_error(coder,node,& - 'Cannot have "over" statement outside of a parallel context') - elseif(coder%par_state/=par_state_for.and.coder%par_state/=par_state_over.and.& - coder%par_state/=par_state_nhd) then - if(coder%par_state==par_state_any) then - call code_error(coder,node,& - 'Cannot have "over" statement in a (non-"invar") "any" statement') - elseif(coder%par_state==par_state_par) then - call code_error(coder,node,& - 'Cannot have "over" statement in "par task"') - else - call code_error(coder,node,& - 'Cannot have "over" statement in a conditional context') - endif - endif - save_par_state=coder%par_state - coder%par_state=par_state_for - call make_sys_var(coder,cblock,node,sym_subregion,var_is_shadowed) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - base=coder%top - call hide_vars(coder,base,base) - call make_comm_call_args(coder,cblock,node) - save_run_mode=coder%run_mode - save_run_flags=coder%run_flags - coder%run_mode=sym_shared - coder%run_flags=proc_run_shared+proc_run_always - call trav_xexpr(coder,cblock,node,node_arg(node,1)) - coder%run_mode=save_run_mode - coder%run_flags=save_run_flags - attr=node_arg(node,2) - call trav_expr(coder,cblock,node,node_arg(attr,1)) - call make_comm_sys_call(coder,cblock,node,sym_make_over,2,1) - call reveal_vars(coder,base,base) - stmt_list=node_arg(node,3) - call make_do_over(coder,cblock,pnode,node,stmt_list,base) - coder%par_state=save_par_state + type(pm_ptr),intent(in):: cblock + integer:: base + base=coder%wtop+1 + call push_word(coder,coder%block_entry) + call push_word(coder,coder%top) + call push_word(coder,coder%lex_scope+1) + call code_null(coder) + call push_word(coder,coder%vtop) + call code_val(coder,cblock) + coder%block_base=coder%top + coder%block_entry=base + end subroutine push_block_scope + + ! ================================================================ + ! Import a variable into a block scope + ! - creates new variable linked to the old one + ! - change local symbol table to point to new variable + ! ================================================================ + recursive subroutine import_to_block_scope(coder,index,var,block_entry) + type(code_state),intent(inout):: coder + integer,intent(in):: index,block_entry + type(pm_ptr),intent(inout):: var + integer:: var_scope,block_scope,block_links + + if(block_entry==0) return + var_scope=cnode_get_num(var,var_lex_scope) + block_scope=coder%wstack(block_entry+2) + block_links=coder%wstack(block_entry+3) + if(var_scope>=block_scope) return + if(debug_more_codegen) then + write(*,*) 'import_to_block_scope',block_entry,var_scope,block_scope,& + trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))) + endif + call make_var(coder,& + coder%vstack(block_links+1),& + pm_null_obj,& + cnode_get_num(var,var_name),& + ior(cnode_get_num(var,var_flags),var_is_imported),& + extra_info=var) + var=pop_code(coder) + call cnode_set_num(var,var_lex_scope,coder%wstack(block_entry+2)) + if(debug_more_codegen) then + write(*,*) 'lex scope now',coder%wstack(block_entry+2) + write(*,*) 'index now',cnode_get_num(var,var_index) + endif + call add_to_change_list(coder,coder%vstack(block_links),& + pm_fast_tinyint(coder%context,index)) contains include 'fisnull.inc' - end subroutine trav_over_stmt - - !================================= - ! Body of an over statement - ! (also used by nhd statements) - !================================= - recursive subroutine make_do_over(coder,cblock,pnode,node,statlist,base) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node,statlist - integer,intent(in):: base - integer:: save_par_state,save_over_base - type(pm_ptr):: cblock2 - - save_par_state=coder%par_state - save_over_base=coder%over_base - - coder%over_base=base - if(coder%par_state/=par_state_nhd) coder%par_state=par_state_over - if(pm_is_compiling) then - cblock2=make_cblock(coder,cblock,node,sym_using) - call make_sys_var(coder,cblock2,node,sym_nested_loop,var_is_shadowed) - call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - call dup_code(coder) - call code_val(coder,coder%var(base)) - call code_val(coder,coder%var(coder%par_base+lv_distr)) - call make_basic_sys_call(coder,cblock2,node,sym_do_over,2,1,& - coder%par_depth-1,call_inline_when_compiling+proc_run_shared+proc_run_always) - call make_basic_sys_call(coder,cblock2,node,sym_nested_loop,1,0,& - coder%par_depth-1,call_inline_when_compiling) - call close_cblock(coder,cblock2) - call trav_stmt_list(coder,cblock,node,statlist,sym_over) - call make_sp_call(coder,cblock,node,sym_over,2,0) - else - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call make_comm_call_args(coder,cblock,node) - call code_val(coder,coder%var(base)) - call make_comm_sys_call(coder,cblock,node,sym_do_over,1,1) - call trav_stmt_list(coder,cblock,node,statlist,sym_over) - call code_null(coder) - call make_sp_call(coder,cblock,node,sym_if,3,0) - endif - coder%par_state=save_par_state - coder%over_base=save_over_base - end subroutine make_do_over - - !======================================================== - ! Start a new parallel scope - ! - leaves quite a bit on the vstack - ! - this needs to be there until scope closes - ! (protection against GC) - !======================================================== - function code_par_scope_start(coder,cblock,stmt,var,using,& - cblock_main,cblock_pre,sym,is_tile) result(iter) + include 'ftiny.inc' + end subroutine import_to_block_scope + + ! ====================================================== + ! Pop block scope from top of wstack & vstack + ! - pop any imported variables back to their originals + ! via their link + ! + ! Push two list values onto vstack for variables + ! respectively changed and accessed in the block + ! + ! Also check for aliasing with call arguments/iterator + ! (call or iterator must be passed as node) + ! ====================================================== + subroutine pop_block_scope(coder,cblock,node,iter) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,stmt,var,using - type(pm_ptr),intent(out):: cblock_main,cblock_pre - integer,intent(in):: sym - logical,intent(in):: is_tile - integer:: iter - integer:: n,i,vbase - type(pm_ptr):: loop_cblock - - call make_sys_var(coder,cblock,stmt,sym_proc,var_is_shadowed) - call make_sys_var(coder,cblock,stmt,sym_region,var_is_shadowed) - call make_sys_var(coder,cblock,stmt,sym_in,var_is_shadowed) - iter=coder%top - call make_sys_var(coder,cblock,stmt,sym_pling,var_is_shadowed) - call make_sys_var(coder,cblock,stmt,sym_hash,var_is_shadowed) - call var_set_par_depth(coder,coder%var(iter+lv_numz),coder%par_depth+1) - !@call cnode_set_num(coder%var(iter+lv_numz),var_par_depth,coder%par_depth+1) - - ! sym_in,region,schedule := partition(sym_proc,sym_for,using...) - vbase=coder%vtop - cblock_pre=make_cblock(coder,cblock,stmt,sym_using) - call make_temp_var(coder,cblock_pre,stmt) - call make_temp_var(coder,cblock_pre,stmt) - call make_temp_var(coder,cblock_pre,stmt) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%vstack(coder%vtop-2)) - call code_val(coder,coder%var(iter+lv_prc)) - call code_val(coder,var) - - if(.not.pm_fast_isnull(using)) then - n=node_numargs(using) - do i=1,n - call trav_expr(coder,cblock_pre,using,node_arg(using,i)) - enddo - do i=n+1,num_using_clauses - call make_const(coder,cblock,using,pm_null_obj) - enddo - call make_sys_call(coder,cblock_pre,using,& - sym_partition,& - 2+num_using_clauses,3) - else - call make_sys_call(coder,cblock_pre,stmt,sym_partition,2,3) - endif - - ! Init variables: tile, region - call code_val(coder,coder%vstack(vbase+2)) - call init_var(coder,cblock_pre,stmt,coder%var(iter+lv_tile)) - call code_val(coder,coder%vstack(vbase+3)) - call init_var(coder,cblock_pre,stmt,coder%var(iter+lv_distr)) - - ! Variable sym_pling set to number of elements in domain - call make_temp_var(coder,cblock_pre,stmt) - call dup_code(coder) - call code_val(coder,coder%var(iter+lv_distr)) - call make_sys_call(coder,cblock_pre,stmt,sym_num_elements,1,1) - call init_var(coder,cblock_pre,stmt,coder%var(iter+lv_num)) - - ! Alias the region variable - call make_var_tab_entry(coder,sym_region,coder%var(iter+lv_distr)) - - ! Create the subregion variable - call make_sys_var(coder,cblock,stmt,sym_subregion,var_is_shadowed) - call code_val(coder,coder%vstack(vbase+4)) - call init_var(coder,cblock_pre,stmt,coder%var(coder%top)) - coder%over_base=coder%top - - ! Outer code block (contains imports/exports) - loop_cblock=make_cblock(coder,cblock,stmt,sym) - call push_par_scope(coder,loop_cblock) - coder%loop_cblock=loop_cblock - coder%par_base=iter - - ! Inner block - contains statements - cblock_main=make_cblock(coder,loop_cblock,stmt,sym_for) + type(pm_ptr),intent(in):: cblock,node + logical,intent(in):: iter + type(pm_ptr):: list + type(pm_ptr)::p,var + integer:: index,nwrites,nreads,base + logical:: changed - if(.not.is_tile) then - - ! Variable here_in_tile set to local iteration indices in this thread - call make_sys_var(coder,cblock_main,stmt,sym_here_in_tile,var_is_shadowed) - if(pm_is_compiling) then - call make_temp_var(coder,cblock_main,stmt) - call var_set_par_depth(coder,coder%var(iter+lv_index),coder%par_depth-1) - call dup_code(coder) - endif - call code_val(coder,coder%var(iter+lv_distr)) - call code_val(coder,coder%var(iter+lv_numz)) - call code_val(coder,coder%var(coder%over_base)) - if(pm_is_compiling) then - call make_sys_call(coder,cblock_main,stmt,& - sym_generate,3,1,& - call_inline_when_compiling+proc_run_shared+call_ignore_rules+proc_run_always) - call make_basic_sys_call(coder,cblock_main,stmt,& - sym_generate,1,1,coder%par_depth-1,0) - else - call make_basic_sys_call(coder,cblock_main,stmt,& - sym_generate,3,1,coder%par_depth-1,& - call_inline_when_compiling) + ! Check we are aligned with block scope records on vstack and wstack + if(pm_debug_checks) then + if(coder%wtop/=coder%block_entry+3) then + call pm_panic("pop_block_scope: wstack") endif - call var_set_par_depth(coder,coder%var(iter+lv_index),coder%par_depth) - - ! Get element [here_in_tile] from tile to yield here - call make_sys_var(coder,cblock_main,stmt,sym_here,& - var_is_shadowed) - call code_val(coder,coder%var(iter+lv_tile)) - call code_val(coder,coder%var(iter+lv_index)) - call make_sys_call(coder,cblock_main,stmt,sym_get_element,2,1) - - if(coder%top/=iter+7) then - do i=iter,coder%top - write(*,*) pm_name_as_string(coder%context,coder%stack(i)) - enddo - write(*,*) coder%top,iter,coder%top-iter - call pm_panic('push_par_scope') + if(coder%vtop-1/=coder%wstack(coder%block_entry+3)) then + call pm_panic("pop_block_scope: vstack") endif - endif - - contains - - include 'fname.inc' - include 'fisnull.inc' - - end function code_par_scope_start - - !============================================================================ - ! Complete current parallel scope - ! - iter, cblock_main -- as returned by code_par_scope_start - ! - cblock_post -- must be allocated as a code block if not "conc" - ! - old_par_base -- no longer used - ! - slot1,slot2 -- range of indices (coder%index) covered by this statement - !============================================================================ - subroutine code_par_scope_end(coder,iter,node,& - cblock,cblock_main,cblock_pre,old_par_base,slot1,slot2,is_conc,is_tile) - type(code_state),intent(inout):: coder - integer,intent(in):: iter - type(pm_ptr),intent(in):: node,cblock,cblock_main,cblock_pre - integer,intent(in):: old_par_base,slot1,slot2 - logical,intent(in):: is_conc,is_tile - type(pm_ptr):: p - ! Inner call to for - call close_cblock(coder,cblock_main) - call code_val(coder,cblock_main) - call make_sp_call(coder,coder%loop_cblock,node,sym_for,1,0) + ! Pop the block scope record from wstack and vstack + list=coder%vstack(coder%vtop-1) + coder%temp2=list ! Protect list from the gc + coder%block_entry=coder%wstack(coder%block_entry) + coder%block_base=coder%wstack(coder%block_entry+1) + coder%vtop=coder%vtop-2 + coder%wtop=coder%wtop-4 - call code_val(coder,coder%var(coder%par_base+lv_distr)) - call make_sys_call(coder,coder%loop_cblock,node,sym_pop_node,1,0,& - aflags=call_ignore_rules+merge(0,proc_run_shared+proc_run_always,pm_is_compiling)) + base=coder%wtop - ! Close loop cblock - call close_cblock(coder,coder%loop_cblock) - call pop_par_scope(coder,coder%loop_cblock,node) + ! Now pop each variable + p=list + do while(.not.pm_fast_isnull(p)) + index=p%data%ptr(p%offset)%offset + var=coder%var(index) + changed=cnode_flags_set(var,var_flags,var_is_changed) + var=cnode_get(var,var_extra_info) + ! May need to re-import into current scope + call import_to_block_scope(coder,index,var,coder%block_entry) + call access_var(coder,var,changed) + coder%var(index)=var + ! Flag changed variables with a -ve index + if(changed) p%data%ptr(p%offset)%offset=-index + p=p%data%ptr(p%offset+1) + enddo + + ! Create list of all changed variables + p=list + nwrites=0 + call make_sys_var(coder,cblock,node,sym_block_inouts_a,& + var_is_shadowed+var_is_var+var_is_ref) + do while(.not.pm_fast_isnull(p)) + index=p%data%ptr(p%offset)%offset + ! Changed variables have -ve index + if(index<0) then + call code_val(coder,coder%var(-index)) + call push_word(coder,cnode_get_num(coder%var(-index),var_name)) + nwrites=nwrites+1 + endif + p=p%data%ptr(p%offset+1) + enddo + call make_basic_sp_call(coder,cblock,node,sym_pm_list,nwrites,1) - ! Close cblock_pre - call close_cblock(coder,cblock_pre) + ! Create a list of all accessed variables + p=list + nreads=0 + call make_sys_var(coder,cblock,node,sym_block_ins_a,& + var_is_shadowed+var_is_var) + do while(.not.pm_fast_isnull(p)) + index=p%data%ptr(p%offset)%offset + ! Unchanged (but accessed) variables have a +ve index + if(index>0) then + call code_val(coder,coder%var(index)) + call push_word(coder,cnode_get_num(coder%var(index),var_name)) + nreads=nreads+1 + endif + p=p%data%ptr(p%offset+1) + enddo + call make_basic_sp_call(coder,cblock,node,sym_pm_list,nreads,1) - ! Build par-loop call - ! #, sym_prc = main_block,pre_block,post_block, $, is_conc, slots - call code_val(coder,coder%var(iter+lv_numz)) - call code_val(coder,coder%var(iter+lv_prc)) - - call code_val(coder,coder%loop_cblock) - call code_val(coder,cblock_pre) - call code_val(coder,pm_null_obj) !!!@ Legacy - need to remove - call code_val(coder,coder%var(iter+lv_num)) - if(is_conc) then - call make_const(coder,cblock,node,pm_null_obj) + ! Check for alias with iter or argument list + if(.not.iter) then + call check_call_block_alias(coder,cblock,node,base,nreads,nwrites) else - call make_const(coder,cblock,node,coder%true) + call check_iter_block_alias(coder,cblock,node,base,nreads,nwrites) endif - ! Two-integer entry giving range of slots used by statement - p=pm_fast_newnc(coder%context,pm_int,2) - call make_const(coder,cblock,node,p) - p%data%i(p%offset)=slot1 - p%data%i(p%offset+1)=slot2 - - ! Code parallel statement call - call make_sp_call(coder,cblock,node,sym_for_stmt,6,2) - - ! Adjust par_depth of result - call var_set_par_depth(coder,coder%var(iter+lv_numz),coder%par_depth+1) - + ! Clean up + coder%wtop=base + coder%temp2=pm_null_obj contains - include 'fnewnc.inc' include 'fisnull.inc' - end subroutine code_par_scope_end - - !======================================================== - ! Push a parallel scope level - !======================================================== - subroutine push_par_scope(coder,cblock) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock - integer:: depth, kk - depth=coder%par_depth - if(depth==max_par_depth) & - call pm_panic('Program too complex (nested loops)') - depth=depth+1 - coder%imports(depth)=& - pm_dict_new(coder%context,32_pm_ln) - coder%import_cblock(depth)=cblock - coder%par_depth=depth - end subroutine push_par_scope + end subroutine pop_block_scope - !======================================================== - ! Pop down parallel scope level - !======================================================== - subroutine pop_par_scope(coder,cblock,node) + !=================================================================== + ! Check variables used as arguments to call to those + ! accessed/modified by block (whose names must be pushed on wstack) + ! above base (nwrites writes followed by nreads reads) + !=================================================================== + subroutine check_call_block_alias(coder,cblock,node,base,nreads,nwrites) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node - integer:: depth - depth=coder%par_depth - coder%imports(depth)=pm_null_obj - coder%par_depth=coder%par_depth-1 + integer,intent(in):: base,nreads,nwrites + type(pm_ptr):: args,amp,arg + integer:: i,j,k,name,sym + args=node_arg(node,2) + amp=pm_name_val(coder%context,node_num_arg(node,3)) + if(pm_fast_isnull(amp)) then + do i=1,node_numargs(args) + arg=node_arg(args,i) + sym=node_sym(arg) + if(sym==sym_reference.or.sym==sym_name) then + name=root_name(arg) + do j=1,nwrites + if(coder%wstack(base+i)==name) then + call code_error(coder,arg,& + 'Variable is modified by the block that is also used by an argument: ',& + node_num_arg(arg,1)) + endif + enddo + endif + enddo + else + k=0 + do i=1,node_numargs(args) + arg=node_arg(args,i) + if(amp%data%i(amp%offset+k)==i) then + name=node_num_arg(arg,1) + do j=1,nwrites+nreads + if(coder%wstack(base+i)==name) then + if(j<=nwrites) then + call code_error(coder,arg,& + 'Variable is modified by the block that is also modified as an argument: ',& + node_num_arg(arg,1)) + else + call code_error(coder,arg,& + 'Variable is accessed by the block that is also modified as an argument: ',& + node_num_arg(arg,1)) + endif + endif + enddo + k=min(k+1,pm_fast_esize(amp)) + else + if(node_sym(arg)==sym_amp) then + name=node_num_arg(arg,1) + do j=1,nwrites + if(coder%wstack(base+i)==name) then + call code_error(coder,arg,& + 'Variable is modified by the block that is also used by an argument: ',& + node_num_arg(arg,1)) + endif + enddo + endif + endif + enddo + endif contains include 'fisnull.inc' - end subroutine pop_par_scope + include 'fesize.inc' + end subroutine check_call_block_alias - !======================================================== - ! Import argument list for a call - ! - returns parallel depth of call - ! Also returns export information for return values - ! at vstack locations base..vtop - !======================================================== - subroutine import_args(coder,cblock,node,narg,nret,nkey,amps,flags,base) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node,amps - integer,intent(in)::narg,nret,nkey,flags - integer,intent(out):: base - integer:: depth - integer:: i,j,top,totsize,nextra - logical:: isamp,export,iscomm - type(pm_ptr):: amp - top=coder%vtop + !=================================================================== + ! Check variables defined in iterator against variables + ! accessed/modified by block (whose names must be pushed on wstack) + ! above base (nwrites writes followed by nreads reads) + !=================================================================== + subroutine check_iter_block_alias(coder,cblock,node,base,nreads,nwrites) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: base,nreads,nwrites + integer:: i,j,name,sym + type(pm_ptr):: arg + do i=1,node_numargs(node),2 + arg=node_arg(node,i+1) + sym=node_sym(arg) + if(sym==sym_name.or.sym==sym_reference) then + name=root_name(arg) + do j=1,merge(nwrites+nreads,nreads,node_sym(node_arg(node,i))==sym_amp) + if(coder%wstack(base+j)==name) then + if(j<=nwrites) then + call code_error(coder,arg,'Block modifies variable that is used by iterator: ',& + node_num_arg(arg,1)) + else + call code_error(coder,arg,'Block uses variable which is modified by iterator: ',& + node_num_arg(arg,1)) + endif + endif + enddo + endif + enddo + end subroutine check_iter_block_alias + + function root_name(arg) result(name) + type(pm_ptr),intent(in):: arg + integer:: name + integer:: sym + sym=node_sym(arg) + if(sym==sym_name) then + name=node_num_arg(arg,1) + else !! reference + name=node_num_arg(node_arg(arg,1),1) + endif + end function root_name - iscomm=iand(flags,call_is_comm)/=0 - if(iscomm) then - depth=coder%par_depth-1 - export=.false. - elseif(iand(flags,proc_run_shared+proc_run_local)/=0) then - depth=coder%par_depth-1 - export=.true. - else - depth=coder%par_depth - export=.false. + + !================================================ + ! Create a new lexical scope (used to identify + ! variables defined outside the statement that + ! are accessed or modified within it) + ! Pushes small record on vstack + !================================================ + function push_lex_scope(coder) result(new_lex_scope) + type(code_state),intent(inout):: coder + integer:: new_lex_scope + call code_num(coder,coder%lex_scope) + call code_null(coder) + call code_null(coder) + new_lex_scope=coder%vtop + end function push_lex_scope + + !=========================================== + ! Push change lists of current lexical scope + ! as a changelist cnode + !=========================================== + subroutine get_lex_scope(coder,node) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: node + call code_val(coder,coder%vstack(coder%lex_scope)) + call code_val(coder,coder%vstack(coder%lex_scope-1)) + call make_code(coder,node,cnode_is_changelist,2) + end subroutine get_lex_scope + + !=================================== + ! Exit lexical scope + ! Pops record off the top of vstack + !=================================== + subroutine pop_lex_scope(coder) + type(code_state),intent(inout):: coder + coder%lex_scope=coder%vstack(coder%vtop-2)%offset + call drop_code(coder) + call drop_code(coder) + call drop_code(coder) + end subroutine pop_lex_scope + + !========================================== + ! Record read or write (if modify is true) + ! access to a variable + !=========================================== + subroutine access_var(coder,var,modify) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(inout):: var + logical,intent(in):: modify + if(debug_more_codegen) then + if(coder%block_base>0) write(*,*) 'access var',modify,& + trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name))),& + cnode_get_num(var,var_index) endif - if(pm_fast_isnull(amps)) then - do i=top+1-narg-nkey,top - call import_arg(i,.false.) - enddo + if(modify) then + call cnode_set_flags(var,var_flags,var_is_changed) else - amp=pm_name_val(coder%context,int(amps%offset)) - do i=top+1-narg-nkey,top-narg - call import_arg(i,.false.) - enddo - j=0 - do i=top+1-narg,top - isamp=amp%data%i(amp%offset+j)==i-(top-narg) - if(isamp.and.j=0) call hide_vars(coder,base+1,xtop) + end subroutine trav_xexpr + + !============================================================== + ! Traverse extended expression: expr [check expr] { where ...} + !============================================================== + recursive subroutine trav_subexpr(coder,cblock,exprp,exprn,base,top,dtop) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,exprp,exprn + integer,intent(out):: base,top + integer,intent(out),optional:: dtop + type(pm_ptr)::p,ass,arg + integer:: i,j,wbase,name + logical:: ok + p=exprn + base=-1 + top=-2 + if(pm_fast_isnull(p)) return + if(node_sym(p)==sym_where) then + base=coder%top + do + ass=node_arg(p,2) + do i=1,node_numargs(ass) + call trav_assign_define(coder,cblock,ass,node_arg(ass,i)) + enddo + p=node_arg(p,1) + if(node_sym(p)/=sym_where) exit enddo + top=coder%top + if(present(dtop)) dtop=coder%top + endif + if(node_sym(p)==sym_check) then + call apply_x(p,node_arg(p,1)) + call make_check(coder,cblock,p,0) + else + call apply_x(exprp,p) endif - contains - include 'fvkind.inc' include 'fisnull.inc' - include 'fesize.inc' - - subroutine import_arg(index,modify) - integer,intent(in):: index - logical,intent(in):: modify - type(pm_ptr):: var,nvar - integer:: vdepth - var=coder%vstack(index) - if(pm_fast_vkind(var)/=pm_pointer) return - if(cnode_get_kind(var)/=cnode_is_var) return - !write(*,*) 'IMPORT>',trim(pm_name_as_string(coder%context,cnode_get_name(var,var_name))) - if(iscomm.and.index<=top+2-narg) return - if(cnode_flags_set(var,var_flags,var_is_no_import_export)) then - coder%vstack(index)=cnode_get(var,var_extra_info) + include 'fisname.inc' + include 'fname.inc' + include 'ftiny.inc' + + recursive subroutine apply_x(nodep,node) + type(pm_ptr),intent(in):: nodep,node + type(pm_ptr):: nodei + integer:: wbase,i,nsym + wbase=coder%wtop + if(pm_fast_isnull(node)) return + select case(node_sym(node)) + case(sym_assign) + call trav_assign_define(coder,cblock,nodep,node) + case(sym_list) + call trav_exprlist(coder,cblock,nodep,node) + case(sym_result) + call push_word(coder,pm_type_is_tuple) + call push_word(coder,0) + do i=1,node_numargs(node),2 + nodei=node_arg(node,i) + call trav_expr(coder,cblock,node,nodei) + nsym=node_sym(nodei) + if(nsym==sym_name.or.nsym==sym_reference) then + nodei=find_var(coder,root_name(nodei)) + if(.not.pm_fast_isnull(nodei)) then + if(cnode_flags_set(nodei,var_flags,var_is_param)) then + call make_sys_call_rtn(coder,cblock,node,sym_clone,1,1) + endif + endif + endif + nodei=node_arg(node,i+1) + if(.not.pm_fast_isnull(nodei)) then + call trav_cast(coder,cblock,node,nodei,sym_const) + call trav_type(coder,node,nodei) + else + call push_word(coder,0) + endif + enddo + call make_type(coder,node_numargs(node)/2+2) return + case(sym_do) + call trav_call(coder,cblock,node,node_arg(node,1),0,.true.) + case(sym_test) + call make_check(coder,cblock,node,base) + case default + call trav_top_expr(coder,cblock,nodep,node) + end select + if(pm_debug_checks) then + if(coder%wtop/=wbase) then + write(*,*) coder%wtop,wbase + call dump_parse_tree(coder%context,6,node,2) + call pm_panic('xexpr wstack mismatch') + endif endif - vdepth=par_depth(coder,var) - if(modify.and.vdepthdepth.and.export) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call cnode_set_flags(top_code(coder),var_flags,var_is_imported) - call code_val(coder,var) - call make_basic_sp_call(coder,cblock,node,sym_export_as_new,& - 1,1,coder%par_depth) - call var_set_par_depth(coder,top_code(coder),depth) - nvar=pop_code(coder) - else - nvar=var - endif - coder%vstack(index)=nvar - end subroutine import_arg - - end subroutine import_args + end subroutine apply_x + end subroutine trav_subexpr !======================================================== - ! Import a variable into a parallel scope at given depth + ! Compile check !======================================================== - function import_to_par_scope(coder,cblock,node,var,depth,modify) result(ivar) + recursive subroutine make_check(coder,cblock,p,base) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node,var - integer,intent(in):: depth - logical,intent(in):: modify - type(pm_ptr):: ivar - type(pm_ptr):: jvar,kvar,iblock - integer:: i,j,vdepth,vcdepth,name - ivar=var - if(pm_fast_vkind(var)/=pm_pointer) return - if(cnode_get_kind(var)/=cnode_is_var) return - if(cnode_flags_set(var,var_flags,var_is_no_import_export)) then - ivar=cnode_get(var,var_extra_info) - return - endif - vdepth=cnode_get_num(var,var_par_depth)+coder%proc_par_depth - vcdepth=cnode_get_num(var,var_create_depth)+coder%proc_par_depth - if(debug_codegen) then - write(*,*) 'IMPORT TO:',& - trim(pm_name_as_string(coder%context,& - cnode_get_num(var,var_name))),& - depth,vdepth,coder%par_depth,modify - endif - if(depth==0) then - ivar=var - elseif(vdepth>depth) then - ivar=var - elseif(vdepth==depth) then - ivar=var - elseif(modify.and.vdepth=coder%par_depth) then - iblock=cblock - else - iblock=coder%import_cblock(j) - endif - name=cnode_get_num(jvar,var_name) - if(name/=0) name=pm_name2(coder%context,sym_gt,name) - call make_sys_var(coder,iblock,node,& - name,var_is_shadowed+var_is_imported) - kvar=top_code(coder) - call cnode_set_num(kvar,var_par_depth,i-coder%proc_par_depth) - call code_val(coder,jvar) - - if(cnode_flags_set(jvar,var_flags,var_is_varg)) then - call cnode_set_flags(kvar,var_flags,var_is_varg) - call make_basic_sp_call(coder,iblock,node,& - sym_import_varg,1,1,i+1) - else - call code_val(coder,coder%var(coder%par_base+lv_distr)) - call make_basic_sp_call(coder,iblock,node,& - sym_import_val,2,1,i+1) - endif - if(debug_codegen) then - write(*,*) 'IMPORT VAL> ',& - trim(pm_name_as_string(coder%context,& - cnode_get_num(var,var_name))),i - endif - ! Note cannot cache import to current level - ! - shared variable may change - ! - import may be in code that does not run - ! if 'false or similar - if(ipar_state_masked) then + call code_error(coder,node,'Cannot have "'//trim(sym_names(sym))//'"'//& + ' inside this conditional context') + endif + endif + call code_val(coder,val) + call make_sp_call(coder,cblock,node,sym_invar,1,0,flags=call_is_no_touch) + end subroutine code_check_invar + + !************************************************** + ! PARALLEL STATEMENTS + !************************************************** + - subroutine check_par_nesting(coder,list_head,node,cond_is_ok) +!!$ !======================================================== +!!$ ! Traverse par { } +!!$ !======================================================== +!!$ recursive subroutine trav_par_stmt(coder,cblock,pnode,node) +!!$ type(code_state),intent(inout):: coder +!!$ type(pm_ptr),intent(in):: cblock,pnode,node +!!$ type(pm_ptr):: let,clause,cblock_main,cblock_pre,cblock_post +!!$ type(pm_ptr):: vlist,save_loop_cblock +!!$ integer:: i,j,k,iter,istart,vstart,base,rbase,m +!!$ integer:: save_par_base,save_over_base,save_par_state +!!$ integer:: slot1,slot2 +!!$ integer:: name,flags +!!$ +!!$ vstart=coder%vtop +!!$ save_loop_cblock=coder%loop_cblock +!!$ save_par_base=coder%par_base +!!$ save_over_base=coder%over_base +!!$ save_par_state=coder%par_state +!!$ +!!$ base=coder%top +!!$ +!!$ if(node_numargs(node)==4) then +!$ call code_error(coder,node,'"par" statement has only one branch') +!!$ coder%vtop=vstart +!!$ return +!!$ endif +!!$ +!!$ ! Variable sym_for +!!$ call make_long_const(coder,cblock,node,& +!!$ int((node_numargs(node)-2)/2,pm_ln)) +!!$ call make_sys_call_rtn(coder,cblock,node,sym_array,1,1) +!!$ call define_sys_var(coder,cblock,node,sym_for,var_is_shadowed) +!!$ +!!$ ! Partition the domain across processors +!!$ iter=code_par_scope_start(coder,cblock,node,coder%var(coder%top),& +!!$ node_arg(node,1),cblock_main,cblock_pre,sym_also,.false.) +!!$ +!!$ slot1=coder%index +!!$ +!!$ do i=3,node_numargs(node),2 +!!$ call make_long_const(coder,cblock_main,node,int((i-2)/2,pm_ln)) +!!$ call make_definition(coder,cblock_main,node,node_arg(node,i),0) +!!$ enddo +!!$ +!!$ coder%par_state=par_state_for +!!$ +!!$ ! statements before any branch +!!$ call trav_open_stmt_list(coder,cblock_main,node,node_arg(node,2)) +!!$ +!!$ coder%par_state=par_state_par +!!$ +!!$ ! branches +!!$ call branch(cblock_main,3) +!!$ +!!$ slot2=coder%index +!!$ +!!$ ! Build parallel statement call +!!$ call code_par_scope_end(coder,iter,node,cblock,cblock_main,& +!!$ cblock_pre,& +!!$ save_par_base,slot1,slot2,.false.,.false.) +!!$ +!!$ coder%vtop=vstart +!!$ coder%loop_cblock=save_loop_cblock +!!$ coder%par_base=save_par_base +!!$ coder%over_base=save_over_base +!!$ call pop_vars_to(coder,base) +!!$ contains +!!$ include 'fisnull.inc' +!!$ include 'ftiny.inc' +!!$ +!!$ recursive subroutine branch(cblock,i) +!!$ type(pm_ptr),intent(in):: cblock +!!$ integer,intent(in):: i +!!$ type(pm_ptr):: cblock4,cblock5 +!!$ type(pm_ptr):: prc_test_var +!!$ integer:: n +!!$ +!!$ ! Is this branch running on this processor? +!!$ call make_temp_var(coder,cblock,node) +!!$ prc_test_var=top_code(coder) +!!$ call make_long_const(coder,cblock,node,int((i-2)/2,pm_ln)) +!!$ call make_sys_call_rtn(coder,cblock,node,sym_tuple,1,1) +!!$ call code_val(coder,coder%var(iter+lv_here)) +!!$ call make_sys_call(coder,cblock,node,sym_eq,2,1) +!!$ +!!$ if(i/=cnode_numargs(node)-1) then +!!$ ! If statment (if running_here then ... endif) +!!$ coder%lex_scope=push_lex_scope(coder) +!!$ call code_val(coder,prc_test_var) +!!$ cblock4=make_cblock(coder,cblock,node,sym_also) +!!$ ! task clause +!!$ call trav_open_stmt_list(coder,cblock4,node,node_arg(node,i+1)) +!!$ call close_cblock(coder,cblock4) +!!$ cblock5=make_cblock(coder,cblock,node,sym_also) +!!$ ! remaining task clauses +!!$ call branch(cblock5,i+2) +!!$ call close_cblock(coder,cblock5) +!!$ call get_lex_scope(coder,node) +!!$ call make_sp_call(coder,cblock,node,sym_if,4,0) +!!$ call pop_lex_scope(coder) +!!$ else +!!$ ! task clause +!!$ call trav_open_stmt_list(coder,cblock,node,node_arg(node,i+1)) +!!$ endif +!!$ +!!$ end subroutine branch +!!$ +!!$ end subroutine trav_par_stmt + + !======================================================== + ! Traverse "sync" statement + !======================================================== + recursive subroutine trav_sync_stmt(coder,cblock,pnode,node) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: list_head,node - logical,intent(in):: cond_is_ok - type(pm_ptr):: list - integer:: i + type(pm_ptr),intent(in):: cblock,pnode,node + integer:: save_par_state,base,sym + type(pm_ptr):: label,body + label=node_arg(node,1) + body=node_arg(node,2) select case(coder%par_state) - case(par_state_for,par_state_loop,par_state_masked,par_state_over,& - par_state_labelled) - continue - case(par_state_outer) - call code_error(coder,node,& - 'Cannot have communicating operation outside of any parallel statement') - return - case(par_state_nhd) + case(par_state_none) call code_error(coder,node,& - 'Cannot have communicating operation in the main body of a "nhd" statement') - return - case(par_state_any) - if(.not.cond_is_ok) then - call code_error(coder,node,& - 'Cannot have active communicating operation in an "any" statement') - endif - case(par_state_cond) - if(.not.cond_is_ok) then - call code_error(coder,node,& - 'Unlabelled communicating operation in conditional statement') - endif - case(par_state_cond_loop) - if(.not.cond_is_ok) then + 'Cannot have a "sync" statement outside of a parallel context') + case(par_state_for,par_state_comm_proc,par_state_masked) + if(.not.pm_fast_isnull(label)) then call code_error(coder,node,& - 'Communicating operation in unlabelled loop') + 'Can only have "sync(...)" statements inside a conditional statement'//& + ' with more than one none-empty branch') endif - case(par_state_par) - if(.not.cond_is_ok) then - call code_error(coder,node,& - 'Unlabelled communicating operation in par statement') - endif - case default - write(*,*) 'Par state=',coder%par_state - call pm_panic('Unknown par state') end select - - list=list_head - i=cnode_get_num(list,cblock_sym) - do - call cnode_set(coder,list,cblock_last_loop_call,& - cnode_get(list,cblock_last_call)) - if(i==sym_for.or.i==sym_for_stmt.or.i==sym_nhd) then - exit - endif - if(cnode_flags_set(list,cblock_flags,cblock_is_comm)) exit - call cnode_set_flags(list,cblock_flags,cblock_is_comm) + save_par_state=coder%par_state + coder%par_state=par_state_masked - - list=cnode_get(list,cblock_parent) - if(pm_fast_isnull(list)) then - call code_error(coder,node,& - 'communicating operation outside of "for"/"par" statement') - return - endif - i=cnode_get_num(list,cblock_sym) - enddo + sym=node_sym(body) + if(sym==sym_open) then + call trav_call(coder,cblock,node,body,0,.true.) + elseif(sym==sym_assign) then + call trav_assign(coder,cblock,node,node_arg(body,1),node_arg(body,2),is_sync=.true.) + else + call trav_stmt_list(coder,cblock,node,body,sym_sync,open_scope=.true.) + endif + if(.not.pm_fast_isnull(label)) then + call code_val(coder,label) + call make_sp_call(coder,cblock,node,sym_sync,2,0) + endif + coder%par_state=save_par_state contains include 'fisnull.inc' - end subroutine check_par_nesting - + end subroutine trav_sync_stmt + !***************************************************** ! ASSIGNMENTS AND VARIABLE DEFINITIONS !***************************************************** - + !======================================================== - ! Traverse single assignment or var/const definition + ! Traverse assignments, var/const definitions !======================================================== recursive subroutine trav_assign_define(coder,cblock,pnode,node) type(code_state),intent(inout):: coder @@ -2786,104 +2432,146 @@ recursive subroutine trav_assign_define(coder,cblock,pnode,node) lhs=node_arg(node,1) rhs=node_arg(node,2) sym=node_sym(lhs) - n=node_numargs(lhs) - if(sym/=sym_define) n=n-1 - call trav_rhs(coder,cblock,node,rhs,n) - call trav_lhs(coder,cblock,node,lhs,rhs) + n=lhs_size(lhs) + if(n==1.and.sym==sym_assign) then + call trav_assign(coder,cblock,node,node_arg(lhs,1),rhs) + else + call trav_rhs(coder,cblock,node,rhs,n) + call trav_lhs(coder,cblock,node,lhs) + endif coder%vtop=base end subroutine trav_assign_define - !======================================================== - ! Traverse multiple assignments, var/const definitions - !======================================================== - recursive subroutine trav_assign_define_list(coder,cblock,pnode,node) + !============================================================== + ! Traverse assignment giving: + ! $call_sym(var,expr,subs...) + ! $call_sym_op(var,op,expr,subs...) - for op= + ! $call_sym_ref(ref,ref) - for non-aliased refs + ! + ! If rhs is null then rhs value must by on top of vstack + !============================================================== + subroutine trav_assign(coder,cblock,node,alhs,rhs,is_sync) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - type(pm_ptr):: assn,lhs,rhs - integer:: i,n,sym,base + type(pm_ptr),intent(in):: cblock,node,alhs,rhs + logical,intent(in),optional:: is_sync + integer:: base,n,is_op,sym + logical:: hard_alias + type(pm_ptr):: temp,lhs + + sym=node_sym(alhs) + if(sym==sym_open_brace) then + lhs=node_arg(alhs,1) + is_op=1 + else + lhs=alhs + is_op=0 + endif + + if(is_op==0.and..not.pm_fast_isnull(rhs)) then + if(node_sym(rhs)==sym_reference) then + if(is_aliased(lhs,rhs,hard_alias)) then + if(hard_alias) then + call code_error(coder,node,& + 'Left and right hand sides of assignment are identical') + return + endif + else + call trav_reference(coder,cblock,node,lhs,.true.,.false.,.false.) + call trav_reference(coder,cblock,node,rhs,.false.,.false.,.false.) + if(coder%par_state==par_state_none) then + call make_sys_call(coder,cblock,node,sym_pm_assign_ref,2,0,& + assign=.true.) + else + call make_comm_sys_call(coder,cblock,node,sym_pm_assign_ref,2,0,& + assign=.true.) + endif + return + endif + endif + endif + if(.not.pm_fast_isnull(rhs)) then + call trav_expr(coder,cblock,node,rhs) + endif base=coder%vtop - do i=1,node_numargs(node) - assn=node_arg(node,i) - lhs=node_arg(assn,1) - sym=node_sym(lhs) - n=node_numargs(lhs) - if(sym/=sym_define) n=n-1 - rhs=node_arg(assn,2) - call trav_rhs(coder,cblock,node,rhs,n) - enddo - do i=node_numargs(node),1,-1 - assn=node_arg(node,i) - lhs=node_arg(assn,1) - rhs=node_arg(assn,2) - call trav_lhs(coder,cblock,node,lhs,rhs) - enddo - coder%vtop=base - end subroutine trav_assign_define_list + if(is_op/=0) then + call trav_expr(coder,cblock,node,node_arg(alhs,1)) + endif + call trav_reference(coder,cblock,node,lhs,.true.,.true.,.false.,call_n=n) + ! Swap rhs-expr with lhs-variable in argument list + temp=coder%vstack(base) + coder%vstack(base)=coder%vstack(base+is_op+1) + coder%vstack(base+is_op+1)=temp + if(present(is_sync)) then + call make_comm_sys_call(coder,cblock,node,& + merge(sym_pm_assign_op,sym_pm_assign,is_op/=0),n+2+is_op,0,assign=.true.) + else + call make_sys_call(coder,cblock,node,& + merge(sym_pm_assign_op,sym_pm_assign,is_op/=0),n+2+is_op,0,assign=.true.) + endif + contains + include 'fisnull.inc' + end subroutine trav_assign + + !======================================================== + ! Number of elements in LHS node + !======================================================== + recursive function lhs_size(lhs) result(n) + type(pm_ptr),intent(in):: lhs + integer:: n + integer:: sym,i + n=node_numargs(lhs) + sym=node_sym(lhs) + if(sym==sym_assign_list) then + n=0 + do i=1,node_numargs(lhs) + n=n+lhs_size(node_arg(lhs,i)) + enddo + elseif(sym/=sym_assign.and.sym/=sym_where) then + n=n-2 + endif + end function lhs_size + !======================================================== ! Traverse left hand side of assignment or definition ! Computes these in *reverse* order assuming RHS has ! stacked them one after the other. !======================================================== - subroutine trav_lhs(coder,cblock,node,lhs,rhs) + recursive subroutine trav_lhs(coder,cblock,node,lhs) type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,lhs,rhs + type(pm_ptr),intent(in):: cblock,node,lhs integer:: i,n,sym - type(pm_ptr):: rhs_val + type(pm_ptr):: lhs_val,rhs_val n=node_numargs(lhs) sym=node_sym(lhs) select case(sym) case(sym_var,sym_const) - do i=n-1,1,-1 - call trav_cast(coder,cblock,lhs,node_arg(lhs,n),sym) - call make_definition(coder,cblock,lhs,node_arg(lhs,i),& - merge(0,var_is_var,sym==sym_const)) - enddo - case(sym_define) - if(node_sym(rhs)==sym_define) then - rhs_val=node_arg(rhs,1) - else - rhs_val=rhs - endif - do i=n,1,-1 - call trav_single_lhs(coder,cblock,lhs,node_arg(lhs,i),rhs_val) - enddo - end select - end subroutine trav_lhs - - !============================================================= - ! Traverse single element of the left hand side of assignment - ! or definition (simple "=", not var or const) - !============================================================= - subroutine trav_single_lhs(coder,cblock,node,lhs,rhs) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,lhs,rhs - type(pm_ptr):: var - type(pm_ptr):: name - integer:: rsym - if(pm_fast_isname(lhs)) then - name=lhs - elseif(node_sym(lhs)==sym_name) then - name=node_arg(lhs,1) - elseif(node_sym(lhs)==sym_lt) then - call make_op_assignment_noalias(coder,cblock,lhs,node_arg(lhs,1),node_arg(lhs,2)) - return - else - call make_assignment(coder,cblock,node,lhs,rhs) - return - endif - var=find_var(coder,name) - if(pm_fast_isnull(var)) then - call make_definition(coder,cblock,node,lhs,0) - elseif(cnode_flags_set(var,var_flags,var_is_not_inited)) then - call var_init_in_cblock(coder,cblock,node,var,0) - else - call make_assignment(coder,cblock,node,lhs,rhs,var) - endif - contains - include 'fisname.inc' - include 'fisnull.inc' - end subroutine trav_single_lhs + do i=n-2,1,-1 + lhs_val=node_arg(lhs,i) + if(node_sym(lhs_val)==sym_dotdotdot) then + call make_definition(coder,cblock,lhs,node_arg(lhs_val,1),& + merge(0,var_is_var,sym==sym_const),node_arg(lhs,n),& + mode=node_num_arg(lhs,n-1),dotdotdot=.true.) + else + call make_definition(coder,cblock,lhs,lhs_val,& + merge(0,var_is_var,sym==sym_const),node_arg(lhs,n),& + mode=node_num_arg(lhs,n-1)) + endif + enddo + case(sym_where) + do i=n,1,-1 + call make_definition(coder,cblock,lhs,node_arg(lhs,i),var_is_where) + enddo + case(sym_assign) + do i=n,1,-1 + call trav_assign(coder,cblock,lhs,node_arg(lhs,i),pm_null_obj) + enddo + case(sym_assign_list) + do i=n,1,-1 + call trav_lhs(coder,cblock,lhs,node_arg(lhs,i)) + enddo + end select + end subroutine trav_lhs !======================================================== ! Traverse right hand side of assignment or definition @@ -2896,11 +2584,23 @@ subroutine trav_rhs(coder,cblock,node,rhs,n) integer:: i,rsym,base rsym=node_sym(rhs) base=coder%vtop - if(rsym==sym_define) then + if(rsym==sym_assign) then call trav_top_expr(coder,cblock,node,node_arg(rhs,1)) do i=2,n call dup_expr(coder,top_code(coder)) enddo + elseif(rsym==sym_do_stmt) then + do i=1,n + call make_temp_var(coder,cblock,node) + enddo + call make_block_proc(coder,cblock,node_arg(rhs,3),& + node_arg(rhs,1),node_num_arg(rhs,2),& + node_arg(rhs,5),node_numargs(node_arg(rhs,5)),& + node_arg(rhs,4)) + do i=1,n + call code_val(coder,coder%vstack(base+i)) + enddo + call trav_call(coder,cblock,node,node_arg(rhs,3),n,.true.) elseif(n>1) then do i=1,n call make_temp_var(coder,cblock,node) @@ -2914,1026 +2614,407 @@ subroutine trav_rhs(coder,cblock,node,rhs,n) endif end subroutine trav_rhs - !======================================================== - ! Traverse sync lhs = rhs - !======================================================== - subroutine trav_sync_assign(coder,cblock,pnode,node) - type(code_state):: coder + !================================================================ + ! Traverse a reference leaving an object or object reference + ! on vstack + ! If isalias is true then a second element on the stack is a + ! list of reference elements to be used in alias checking + !================================================================ + subroutine trav_reference(coder,cblock,pnode,node,islhs,skipdot,isalias,call_n) + type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node - integer:: save_par_state,n,base - n=node_numargs(node) - base=coder%top - ! Make a shadow variable to prevent access to LHS var on RHS - ! or subscripts - ! This keeps a link to the node to ensure that we can still - ! access variable in the one place we need to - call make_var(coder,cblock,node,node_arg(node_arg(node,1),1),& - var_is_shadowed+var_is_sync+var_is_var,extra_info=node_arg(node,1)) - call drop_code(coder) - call trav_expr(coder,cblock,node,node_arg(node,n)) - call check_par_nesting(coder,cblock,pnode,.false.) - save_par_state=coder%par_state - coder%in_sync=.true. - if(n==3) then - call make_assignment_noalias(coder,cblock,node,node_arg(node,2)) - else - call make_op_assignment_noalias(coder,cblock,node,node_arg(node,2),node_arg(node,3)) + logical,intent(in):: islhs,skipdot,isalias + integer,intent(out),optional:: call_n + type(pm_ptr):: arg,list,base_var + integer:: i,j,n,sym,start,base,vbase,abase,atop,last_caret + logical:: iscomm,isvar + + sym=node_sym(node) + if(sym==sym_name) then + call trav_ref_to_var(coder,cblock,node,node_num_arg(node,1),islhs) + if(present(call_n)) call_n=0 + return endif - ! Null out link to node to prevent retaining link to module - call cnode_set(coder,coder%var(base+1),var_extra_info,pm_null_obj) - call pop_vars_to(coder,base) - coder%par_state=save_par_state - end subroutine trav_sync_assign - !======================================================== - ! Assign expression on top of stack to lhs in node - ! Need to also provide rhs node (which has already been - ! traversed) to enable alias checking - !======================================================== - recursive subroutine make_assignment(coder,cblock,pnode,lhs,rhs,avar) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,pnode,lhs,rhs - type(pm_ptr),intent(in),optional:: avar - integer:: rsym,lsym,rbase,lbase,i - logical:: ok - type(pm_ptr):: rname,lname,cblock1,cblock2 - rsym=node_sym(rhs) - lsym=node_sym(lhs) - if(rsym==sym_sub.and.lsym==sym_sub) then - rbase=coder%vtop - ok=get_ref_pattern(coder,rhs,rname) - lbase=coder%vtop - ok=get_ref_pattern(coder,lhs,lname) - if(lname%offset/=rname%offset) then - coder%vtop=rbase - call make_assignment_noalias(coder,cblock,pnode,lhs,avar) - elseif(match_ref_names(coder,cblock,pnode,rbase,lbase)) then - coder%vtop=rbase - call make_assignment_noalias(coder,cblock,pnode,lhs,avar) - else - ! Code if : else: - call match_ref_pattern(coder,cblock,pnode,rbase,lbase,test=.true.) - coder%vstack(rbase+1)=coder%vstack(coder%vtop) - coder%vtop=rbase+1 - cblock1=make_cblock(coder,cblock,pnode,sym_if) - call code_val(coder,coder%vstack(rbase)) - call make_assignment_noalias(coder,cblock1,pnode,lhs,avar,alias=.true.) - call close_cblock(coder,cblock1) - cblock2=make_cblock(coder,cblock,pnode,sym_if) - call code_val(coder,coder%vstack(rbase)) - call make_assignment_noalias(coder,cblock2,pnode,lhs,avar) - call close_cblock(coder,cblock2) - call make_sp_call(coder,cblock,pnode,sym_if,3,0) - endif - else - call make_assignment_noalias(coder,cblock,pnode,lhs,avar) - endif - end subroutine make_assignment - - !============================================================ - ! Assign expression on top of stack to lhs in node - ! LHS must not alias RHS - ! (unless alias is present in which case LHS must alias RHS) - !============================================================ - recursive subroutine make_assignment_noalias(coder,cblock,pnode,node,avar,alias) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - type(pm_ptr),intent(in),optional:: avar - logical,intent(in),optional:: alias - integer:: n,i,sym,flags,mode,depth,outmode - type(pm_ptr):: v,w - logical:: outer,shared - if(present(avar)) then - call trav_ref_to_var(coder,cblock,pnode,node,0,avar) - call assign_call(pnode,outer,& - cnode_flags_clear(top_code(coder),var_flags,var_is_ref),.false.) - elseif(node_sym(node)==sym_underscore) then - call drop_code(coder) - return - elseif(pm_fast_isname(node)) then - call trav_ref_to_var(coder,cblock,pnode,node,0) - call assign_call(pnode,outer,& - cnode_flags_clear(top_code(coder),var_flags,var_is_ref),.false.) + arg=node_arg(node,1) + if(node_sym(arg)==sym_name) then + call trav_ref_to_var(coder,cblock,arg,node_num_arg(arg,1),islhs) + isvar=.true. else - sym=node_sym(node) - select case(sym) - case(sym_sub,sym_dot_sub,sym_dot,sym_get_dot,sym_at) - outmode=trav_ref(coder,cblock,pnode,node,0) - call assign_call(node,outer,.false.,iand(outmode,ref_has_at)/=0) - case(sym_name) - call trav_ref_to_var(coder,cblock,node,node_arg(node,1),0) - call assign_call(node,outer,& - cnode_flags_clear(top_code(coder),var_flags,var_is_ref),& - .false.) - case default - !write(*,*) sym_names(sym) - call code_error(coder,pnode,& - 'Cannot assign to expression') - call drop_code(coder) - end select + call trav_expr(coder,cblock,node,arg) + isvar=.false. endif - contains - include 'fisname.inc' - include 'fisnull.inc' - include 'ftiny.inc' - subroutine assign_call(pnode,outer,simple,has_pling) - type(pm_ptr),intent(in):: pnode - logical,intent(in):: outer,simple - logical,intent(in):: has_pling - type(pm_ptr):: v,w - if(.not.coder%in_sync) then - call swap_code(coder) - call make_assign_call(coder,cblock,pnode,& - merge(sym_aliased_assign,& - merge(sym_assign_var,sym_assignment,simple),& - present(alias)),& - 2,0,aflags=call_is_assign_call) - else - v=pop_code(coder) - w=pop_code(coder) - call make_comm_call_args(coder,cblock,pnode) - call code_val(coder,v) - call code_val(coder,w) - call make_static_bool_const(coder,cblock,pnode,has_pling) - call check_par_nesting(coder,cblock,pnode,.true.) - call make_comm_sys_call(coder,cblock,pnode,& - merge(sym_aliased_assign,sym_assignment,present(alias)),& - 3,0,assign=.true.) - endif - end subroutine assign_call + base_var=top_code(coder) - end subroutine make_assignment_noalias - - !======================================================== - ! Assign expression on top of stack to lhs in node - !======================================================== - recursive subroutine make_op_assignment_noalias(coder,cblock,pnode,node,op) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,pnode,node,op - integer:: n,i,sym,flags,mode,depth,outmode - type(pm_ptr):: v,w - logical:: outer,shared - if(node_sym(node)==sym_underscore) then - call drop_code(coder) - return - endif - outmode=trav_ref(coder,cblock,pnode,node,0) - if(coder%in_sync) then - v=pop_code(coder) - w=pop_code(coder) - call make_comm_call_args(coder,cblock,pnode) - call code_val(coder,v) - call code_val(coder,w) - if(node_sym(op)==sym_proc.and.node_sym(node_arg(op,1))==sym_minus) then - call make_temp_var(coder,cblock,pnode) - call swap_and_dup_code(coder) - call make_sys_call(coder,cblock,pnode,sym_minus,1,1) - endif - call trav_expr(coder,cblock,pnode,op) - call make_static_bool_const(coder,cblock,pnode,& - iand(outmode,ref_has_at)/=0) - call check_par_nesting(coder,cblock,pnode,.true.) - call make_comm_sys_call(coder,cblock,pnode,& - sym_assignment,4,0,assign=.true.) - call check_par_nesting(coder,cblock,pnode,.false.) + start=2 + arg=node_arg(node,start) + sym=node_sym(arg) + abase=coder%vtop + if(sym==sym_pling) then + call make_comm_sys_call_rtn(coder,cblock,node,sym_pm_pling,1,1) + iscomm=.true. + start=3 + elseif(sym==sym_at) then + call make_comm_sys_call_rtn(coder,cblock,node,sym_pm_at,1,merge(2,1,isalias)) + iscomm=.true. + start=3 else - call swap_code(coder) - if(node_sym(op)==sym_proc.and.node_sym(node_arg(op,1))==sym_minus) then - call make_temp_var(coder,cblock,pnode) - call swap_and_dup_code(coder) - call make_sys_call(coder,cblock,pnode,sym_minus,1,1) - endif - call trav_expr(coder,cblock,pnode,op) - call make_assign_call(coder,cblock,pnode,sym_assignment,3,0) - endif - end subroutine make_op_assignment_noalias - - !=============================================================== - ! Traverse var or const definition with no immediate definition - !=============================================================== - subroutine trav_var_no_init(coder,cblock,pnode,node) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - integer:: n,flags,i - type(pm_ptr):: tnode - n=node_numargs(node)-1 - tnode=node_arg(node,n+1) - flags=var_is_not_inited - if(node_sym(node)==sym_var) flags=ior(flags,var_is_var) - do i=1,n - call make_var(coder,cblock,node,node_arg(node,i),flags,tnode) - call cache_var_init(coder,cblock,node,top_code(coder)) - if(pm_is_compiling) then - call make_sp_call(coder,cblock,node,sym_init_var,1,0) - else - call drop_code(coder) - endif - enddo - end subroutine trav_var_no_init - - !================================================================== - ! Initialise a variable in a nested block (relative to definition) - !================================================================== - subroutine var_init_in_cblock(coder,cblock,node,var,flags) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,var - integer,intent(in):: flags - type(pm_ptr):: p,def_block,tnode - logical:: has_if - - def_block=cnode_get(var,var_parent) - has_if=.false. - p=cblock - do while(.not.p==def_block) - select case(cnode_get_num(p,cblock_sym)) - case(sym_for) - call code_error(coder,node,& - 'Cannot intialise a "var" or "const" inside a nested "for" or "par"statement') - call cnode_error(coder,var,& - 'Variable definition incorrectly intialised by the above') - case(sym_if,sym_if_invar,sym_switch) - if(var_init_cached(coder,p,var)) then - if(.not.has_if) then - call code_error(coder,node,& - 'Cannot initialise variable twice: ',& - cnode_get(var,var_name)) - endif - exit + arg=top_code(coder) + if(cnode_get_kind(arg)==cnode_is_var) then + if(isvar) then + iscomm=cnode_flags_set(arg,var_flags,var_is_maybe_not_private) else - call cache_var_init(coder,p,node,var) - has_if=.true. + iscomm=coder%par_state/=par_state_none endif - case(sym_while,sym_until,sym_each) - call code_error(coder,node,& - 'Cannot initialise a variable defined outside '//& - 'of a sequential loop within that loop: ',& - cnode_get(var,var_name)) - call cnode_error(coder,var,& - 'Variable definition incorrectly intialised by the above') - case(sym_any) - call code_error(coder,node,& - 'Cannot initialise a variable defined outside '//& - 'of an "any" statement within that statement: ',& - cnode_get(var,var_name)) - call cnode_error(coder,var,& - 'Variable definition incorrectly intialised by the above') - end select - p=cnode_get(p,cblock_parent) - enddo - if(.not.has_if) then - call cnode_clear_flags(var,var_flags,var_is_not_inited) - endif - call trav_cast(coder,cblock,node,& - cnode_get(var,var_extra_info),& - merge(sym_var,sym_const,cnode_flags_set(var,var_flags,var_is_var))) - call init_var(coder,cblock,node,var) - contains - include 'fisnull.inc' - include 'fvkind.inc' - end subroutine var_init_in_cblock - - !======================================================== - ! Check 2 cblocks (or null) on the top of the - ! vstack to see if initialisations match - !======================================================== - subroutine resolve_if_inits(coder,node) - type(code_state):: coder - type(pm_ptr),intent(in):: node - type(pm_ptr):: cblock1,cblock2,cache1,cache2 - logical:: empty1,empty2 - integer:: i - cblock1=coder%vstack(coder%vtop-1) - cblock2=coder%vstack(coder%vtop) - cache1=cnode_get(cblock1,cblock_var_inits) - if(pm_fast_isnull(cblock2)) then - cache2=pm_null_obj - else - cache2=cnode_get(cblock2,cblock_var_inits) - endif - empty1=pm_fast_isnull(cache1) - empty2=pm_fast_isnull(cache2) - if(empty1.and.empty2) then - return - elseif(.not.(empty1.or.empty2)) then - if(pm_dict_size(coder%context,cache1)>& - pm_dict_size(coder%context,cache2)) then - call compare(cache1,cache2) else - call compare(cache2,cache1) - endif - else - if(empty1) cache1=cache2 - do i=1,pm_dict_size(coder%context,cache1) - call error(cache1,i) - enddo - endif - contains - include 'fisnull.inc' - - ! Compare larger cache1 to cache2 - subroutine compare(cache1,cache2) - type(pm_ptr),intent(in):: cache1,cache2 - type(pm_ptr):: var,dblock,p - integer:: i - - outer: do i=1,pm_dict_size(coder%context,cache1) - if(pm_fast_isnull(pm_dict_lookup(coder%context,cache2,& - pm_dict_key(coder%context,cache1,int(i,pm_ln))))) then - call error(cache1,i) - endif - ! Check if variable is now completely initialised - ! (true if not still nested in any conditional statement) - var=pm_dict_val(coder%context,cache1,int(i,pm_ln)) - dblock=cnode_get(var,var_parent) - p=cnode_get(cblock1,cblock_parent) - do while(.not.p==dblock) - select case(cnode_get_num(p,cblock_sym)) - case(sym_if,sym_if_invar) - cycle outer - end select - p=cnode_get(p,cblock_parent) - enddo - call cnode_clear_flags(var,var_flags,var_is_not_inited) - enddo outer - end subroutine compare - - subroutine error(cache,j) - type(pm_ptr):: cache - integer:: j - call code_error(coder,node,& - 'Variable is only intialised in one branch of this if statement: ',& - cnode_get(pm_dict_val(coder%context,cache,int(j,pm_ln)),var_name)) - end subroutine error - - end subroutine resolve_if_inits - - !==================================================================== - ! Check if variable initialisation is in the cache for a given block - !==================================================================== - function var_init_cached(coder,cblock,var) result(iscached) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,var - logical:: iscached - type(pm_ptr):: index,cache - index=cnode_get(var,var_index) - cache=cnode_get(cblock,cblock_var_inits) - if(pm_fast_isnull(cache)) then - iscached=.false. - else - iscached=.not.pm_fast_isnull(pm_dict_lookup(coder%context,& - cache,index)) - endif - contains - include 'fisnull.inc' - end function var_init_cached - - !======================================================== - ! Add a variable initialisation to the cache for a block - !======================================================== - subroutine cache_var_init(coder,cblock,node,var) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,var - type(pm_ptr):: index,cache,tnode2 - logical:: ok - integer(pm_ln):: i - index=cnode_get(var,var_index) - cache=cnode_get(cblock,cblock_var_inits) - if(pm_fast_isnull(cache)) then - cache=pm_dict_new(coder%context,8_pm_ln) - call pm_ptr_assign(coder%context,cblock,& - int(cblock_var_inits,pm_ln),& - cache) - endif - call pm_dict_set(coder%context,cache,index,var,.true.,.false.,ok) - if(.not.ok) then - call code_error(coder,node,& - 'Cannot re-initialise variable: ',& - cnode_get(var,var_name)) - endif - contains - include 'fisnull.inc' - include 'ftiny.inc' - end subroutine cache_var_init - - !=================================================================== - ! Use expression on top of stack to create new variable or constant - !=================================================================== - recursive subroutine make_definition(coder,cblock,node,vname,flags) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node,vname - integer,intent(in):: flags - integer:: junk,depth - type(pm_ptr):: name,pnode,expr,var - - if(node_sym(vname)==sym_name) then - name=node_arg(vname,1) - pnode=vname - else - name=vname - pnode=node - endif - if(pm_fast_isname(name)) then - var=find_var(coder,name) - call make_var(coder,cblock,pnode,name,flags) - var=top_code(coder) - call swap_code(coder) - call make_sys_call(coder,cblock,pnode,& - sym_dup,1,1,aflags=coder%run_flags) - call make_var_mode(coder,cblock,node,var) - elseif(node_sym(name)==sym_underscore) then - call drop_code(coder) - else - call code_error(coder,node,& - 'Left hand side of definition must be variable name') - endif - contains - include 'fisname.inc' - include 'fvkind.inc' - include 'fisnull.inc' - end subroutine make_definition - - !======================================================== - ! Reference to a variable - !======================================================== - subroutine trav_ref_to_var(coder,cblock,pnode,name,mode,avar) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,name - integer,intent(in):: mode - type(pm_ptr),intent(in),optional:: avar - type(pm_ptr):: var - integer:: depth,flags,var_index - if(present(avar)) then - var=avar - else - var=find_var_and_entry(coder,name,var_index) - if(pm_fast_isnull(var)) then - call code_error(coder,pnode,& - 'Variable has not been defined: ',name) - call make_temp_var(coder,cblock,pnode) - return + iscomm=.false. endif endif - flags=cnode_get_num(var,var_flags) - if(iand(flags,var_is_sync)/=0) then - if(.not.(cnode_get(var,var_extra_info)==pnode)) then - call code_error(coder,pnode,& - 'Cannot access "sync" left-hand-side variable in right-hand-side expression or subscript') - endif - call hide_vars(coder,var_index,var_index) - var=find_var(coder,name) - if(pm_fast_isnull(var)) then - call code_error(coder,pnode,& - 'Variable has not been defined: ',name) - call make_temp_var(coder,cblock,pnode) - return - endif - flags=cnode_get_num(var,var_flags) - call reveal_vars(coder,var_index,var_index) - endif + vbase=coder%vtop + base=coder%vtop-start+1 - if(iand(flags,var_is_aliased)/=0) then - coder%aliased=.true. - var=cnode_get(var,var_extra_info) - endif - if(.not.iand(mode,ref_is_val)/=0) then - if(iand(flags,var_is_var)==0) then - call code_error(coder,pnode,& - 'Cannot assign to constant: ',name) - else - call cnode_set_flags(var,var_flags,var_is_changed) - endif - endif - if(iand(flags,var_is_not_inited)/=0) then - call code_error(coder,pnode,& - 'Cannot assign to a non-initialised variable: ',name) - endif - if(iand(mode,ref_is_val)/=0) then - var=import_to_par_scope(coder,cblock,pnode,var,coder%par_depth,& - .false.) - endif - call code_val(coder,var) - if(iand(mode,ref_is_val)==0) then - if(coder%par_state>par_state_outer.and..not.coder%in_sync& - .and.iand(mode,ref_ignores_rules)==0) then - if(par_depth(coder,var)=par_state_cond.and.& - coder%par_state<=par_state_par) then - call code_val(coder,var) - call make_basic_sp_call(coder,cblock,pnode,& - sym_assignment,1,0,coder%par_depth) - endif - endif - contains - include 'fisnull.inc' - end subroutine trav_ref_to_var - - !======================================================== - ! Traverse a reference value - !======================================================== - recursive function trav_ref(coder,cblock,pnode,node,mode) result(outmode) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,pnode,node - integer,intent(in):: mode - integer:: outmode - logical:: outer - integer:: newmode,sym,n,m,flags,depth,save_run_flags - logical:: d_index - integer:: aflags,acall - type(pm_ptr):: p,q - outer=.false. - if(pm_fast_isname(node)) then - call trav_ref_to_var(coder,cblock,pnode,node,mode) - outmode=0 - else if(pm_fast_vkind(node)==pm_pointer) then - sym=node_sym(node) + n=node_numargs(node) + last_caret=0 + do i=start,n + arg=node_arg(node,i) + sym=node_sym(arg) select case(sym) - case(sym_sub,sym_dot_sub) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - p=node_arg(node,2) - d_index=trav_index_list(coder,cblock,p,iand(mode,ref_is_val)/=0) - newmode=trav_ref(coder,cblock,node,node_arg(node,1),& - merge(ior(mode,ref_is_dollar),mode,d_index)) - p=pop_code(coder) - q=pop_code(coder) - aflags=call_inline_when_compiling - if(iand(mode,ref_is_val)/=0) then - acall=merge(sym_make_noderef,sym_make_subref,sym==sym_dot_sub) - else - if(iand(mode,ref_is_amp)/=0) then - acall=merge(sym_make_nodelhs_amp,sym_make_sublhs_amp,sym==sym_dot_sub) - !call code_error(coder,node,'Cannot have "[]" in "&" argument') - else - acall=merge(sym_make_nodelhs,sym_make_sublhs,sym==sym_dot_sub) - endif - endif - if(coder%in_sync.or.& - coder%par_state>par_state_outer.and.iand(mode,ref_is_val)/=0) then - call make_comm_call_args(coder,cblock,pnode) - call code_val(coder,p) - call code_val(coder,q) - call make_comm_sys_call(coder,cblock,node,acall,2,1,& - aflags=aflags) - call check_par_nesting(coder,cblock,node,.true.) - else - if(sym==sym_dot_sub) then - if(iand(mode,ref_is_val)/=0) then - call code_error(coder,node,& - 'Cannot have a ".[]" subscript outside of a parallel context') - else - call code_error(coder,node,& - 'Cannot assign to a ".[]" subscript outside of a "sync" statement') - endif - call drop_code(coder) - else - call code_val(coder,p) - call code_val(coder,q) - call make_sys_call(coder,cblock,node,acall,2,1,aflags=ior(aflags,call_ignore_rules)) - endif - endif - outmode=ior(outmode,merge(ref_is_dollar+ref_is_subscripted,& - ref_is_subscripted,d_index)) case(sym_dot) - call make_temp_var(coder,cblock,pnode) - call dup_code(coder) - outmode=trav_ref(coder,cblock,node,node_arg(node,1),mode) - depth=par_depth(coder,top_code(coder)) - call make_const(coder,cblock,node,node_arg(node,2)) - call make_basic_sp_call(coder,cblock,node,& - merge(sym_dot,sym_dot_ref,& - iand(mode,ref_is_val)/=0),2,1,depth) - call var_set_par_depth(coder,top_code(coder),depth) - case(sym_get_dot) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - outmode=trav_ref(coder,cblock,node,node_arg(node,1),mode) - call trav_expr(coder,cblock,node,node_arg(node,2)) - call make_basic_sp_call(coder,cblock,node,& - merge(sym_get_dot,sym_get_dot_ref,& - iand(mode,ref_is_val)/=0),2,1,coder%par_depth) - case(sym_get_dot_ref) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - outmode=trav_ref(coder,cblock,node,node_arg(node,1),mode) - call trav_expr(coder,cblock,node,node_arg(node,2)) - call make_basic_sp_call(coder,cblock,node,& - sym_get_dot_ref,2,1,coder%par_depth) - case(sym_caret) - save_run_flags=coder%run_flags - coder%run_flags=ior(coder%run_flags,call_inline_when_compiling) - call trav_expr(coder,cblock,pnode,node_arg(node,1)) - coder%run_flags=save_run_flags - outmode=0 - case(sym_at) - if(iand(mode,ref_is_val+ref_ignores_rules)==0.and..not.coder%in_sync) then - call code_error(coder,node,& - 'Cannot change value of "@" expression outside of a "sync" statement') - endif - call check_par_nesting(coder,cblock,node,.false.) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call make_comm_call_args(coder,cblock,node) - outmode=ior(trav_ref(coder,cblock,node,node_arg(node,1),mode),& - ref_has_at) - call make_comm_sys_call(coder,cblock,node,sym_make_array,1,1,aflags=proc_run_complete) - !call var_set_par_depth(coder,top_code(coder),coder%par_depth-1) - call dup_code(coder) - call code_num(coder,sym_shared) - call make_basic_sp_call(coder,cblock,node,sym_set_mode,2,0,coder%par_depth) - call check_par_nesting(coder,cblock,node,.true.) - case(sym_name) - call trav_ref_to_var(coder,cblock,node,node_arg(node,1),mode) - outmode=0 - case default - if(iand(mode,ref_is_val)==0) then - call code_error(coder,pnode,& - 'Cannot indirectly assign to expression - value is updated') - call make_temp_var(coder,cblock,pnode) + call make_name_value(coder,cblock,arg,node_num_arg(arg,1)) + case(sym_open_brace) + call trav_expr(coder,cblock,arg,node_arg(arg,1)) + call make_sp_call_rtn(coder,cblock,arg,sym_open_brace,1,1) + case(sym_sub) + call trav_expr(coder,cblock,arg,node_arg(arg,1)) + case(sym_open) + call trav_expr(coder,cblock,arg,node_arg(arg,1)) + call trav_expr(coder,cblock,arg,node_arg(arg,2)) + call make_sp_call_rtn(coder,cblock,node,sym_list,2,1) + case(sym_caret) + last_caret=i + end select + enddo + + atop=coder%vtop + + call make_var(coder,cblock,node,0,var_is_reference,extra_info=base_var) + call dup_code(coder) + call code_val(coder,coder%vstack(vbase)) + + i=start + + if(skipdot) then + arg=node_arg(node,i) + sym=node_sym(arg) + do while(sym==sym_dot.or.sym==sym_open_brace.or.sym==sym_caret) + if(sym==sym_caret) then + if(node_numargs(arg)>1) then + list=node_arg(arg,2) + call trav_exprlist(coder,cblock,arg,list) + call make_sys_call(coder,cblock,arg,node_num_arg(arg,1),& + node_numargs(list)+1,merge(1,-1,i==n)) + else + call make_sys_call(coder,cblock,arg,node_num_arg(arg,1),& + 1,merge(1,-1,i==n)) + endif else - call trav_expr(coder,cblock,pnode,node) + call code_val(coder,coder%vstack(base+i)) + call make_sp_call(coder,cblock,arg,merge(sym_dot_ref,sym_dot,islhs),2,& + merge(1,-1,i==n)) endif - end select - else - call code_error(coder,pnode,& - 'Cannot make reference') - call make_temp_var(coder,cblock,pnode) + i=i+1 + if(i>n) exit + arg=node_arg(node,i) + sym=node_sym(arg) + enddo endif - contains - include 'fvkind.inc' - include 'fisname.inc' - include 'fisnull.inc' - include 'ftiny.inc' - end function trav_ref - !========================================================== - ! Create alias checks for argument #j in argument list/amp - ! Will raise an error if alias is detectable at compile time - ! Will code run-time checks if needed - ! Will set vstack[argbase+i] to a tiny int value - ! (or increment existing tiny int value) - ! if argument #i definitely does not alias argument #j - !========================================================== - subroutine trav_alias_checks(coder,cblock,list,amp,j,argbase) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,list,amp - integer,intent(in):: j,argbase - integer:: i,k,base1,base2 - logical:: finished - type(pm_ptr):: p,name,name2,var - p=node_arg(list,j) - p=node_arg(p,1) - base1=coder%vtop - name=pm_null_obj - finished=get_ref_pattern(coder,p,name) - if(pm_fast_isnull(name)) return - k=0 - do i=1,node_numargs(list) - p=node_arg(list,i) - if(amp%data%i(amp%offset+k)==i) then - k=min(pm_fast_esize(amp),k+1) - if(node_sym(p)==sym_amp) then - if(i>=j) cycle - p=node_arg(p,1) - base2=coder%vtop - finished=get_ref_pattern(coder,p,name2) - if(.not.pm_fast_isnull(name2)) then - call match_ref_pattern(coder,cblock,p,base1,base2,& - j,i,list) - endif + if(last_caret>=i) then + call code_error(coder,node,'Internal Error: ".^" not immediately resolved') + endif + + if(i<=n) then + + if(present(call_n)) then + if(vbase+1/=base+i) then + do j=i,n + coder%vstack(vbase+j-i+1)=coder%vstack(base+j) + enddo + endif + coder%vtop=vbase+n-i+1 + call_n=n-i+1 + if(isalias) call pm_panic('Alias reference (call_n)') + return + else + do j=i,n + call code_val(coder,coder%vstack(base+j)) + enddo + if(.not.iscomm) then + call make_sys_call(coder,cblock,node,& + merge(sym_lhs,sym_get_ref,islhs),n-i+2,1) else - cycle + call make_comm_sys_call(coder,cblock,node,& + merge(sym_lhs,sym_get_ref,islhs),n-i+2,1) endif - elseif(node_sym(p)==sym_dot.or.node_sym(p)==sym_sub) then - base2=coder%vtop - finished=get_ref_pattern(coder,p,name2) - if(.not.pm_fast_isnull(name2)) then - if(match_ref_names(coder,cblock,p,base1,base2)) then - if(pm_fast_vkind(coder%vstack(argbase+i))==pm_tiny_int) then - coder%vstack(argbase+i)%offset=& - coder%vstack(argbase+i)%offset+1 - else - coder%vstack(argbase+i)=pm_fast_tinyint(coder%context,1) - endif + endif + else + if(present(call_n)) call_n=0 + end if + + if(isalias) then + call dup_expr(coder,coder%vstack(vbase)) + do j=abase+1,atop + call dup_expr(coder,coder%vstack(base+j)) + enddo + call make_sp_call_rtn(coder,cblock,node,sym_list,atop-abase+1,1) + coder%vstack(vbase)=coder%vstack(coder%vtop-1) + coder%vstack(vbase+1)=coder%vstack(coder%vtop) + coder%vtop=vbase+1 + else + coder%vstack(vbase)=coder%vstack(coder%vtop) + coder%vtop=vbase + endif + + end subroutine trav_reference + + !======================================================== + ! Reference to a variable + !======================================================== + subroutine trav_ref_to_var(coder,cblock,pnode,name,islhs,avar) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,pnode + integer,intent(in):: name + logical,intent(in):: islhs + type(pm_ptr),intent(in),optional:: avar + type(pm_ptr):: var + integer:: flags,var_index + if(present(avar)) then + var=avar + else + var=find_var_and_entry(coder,name,var_index) + if(pm_fast_isnull(var)) then + if(.not.islhs) then + var=find_param(coder,cblock,pnode,name) + if(pm_fast_isnull(var)) then + call code_error(coder,pnode,& + 'Variable, constant or parameter has not been defined: ',name) + call make_temp_var(coder,cblock,pnode) + return endif + call code_val(coder,var) + return endif + call code_error(coder,pnode,& + 'Variable or constant has not been defined: ',name) + call make_temp_var(coder,cblock,pnode) + return endif - enddo - var=find_var(coder,name) - if(pm_fast_isnull(var)) then - call make_temp_var(coder,cblock,list) - var=pop_code(coder) endif - if(cnode_flags_clear(var,var_flags,var_is_aliased)) then - call make_var(coder,cblock,p,name,& - var_is_var+var_is_aliased+var_is_shadowed,var) + + if(islhs) then + if(cnode_get_kind(var)==cnode_is_var) then + flags=cnode_get_num(var,var_flags) + if(iand(flags,var_is_var)==0) then + call code_error(coder,pnode,& + 'Cannot assign to constant: ',name) + else + call access_var(coder,var,.true.) + endif + else + call code_error(coder,pnode,& + 'Cannot assign to constant: ',name) + endif + else + if(cnode_get_kind(var)==cnode_is_var) then + call access_var(coder,var,.false.) + endif endif - coder%vtop=base1 + call code_val(coder,var) contains - include 'fesize.inc' include 'fisnull.inc' - include 'ftiny.inc' - include 'fvkind.inc' - end subroutine trav_alias_checks - - !============================================================ - ! Get the pattern of .name and [] subscripts in a reference - ! -- truncated after @ - !============================================================ - recursive function get_ref_pattern(coder,node,name) result(finished) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: node - type(pm_ptr),intent(inout):: name - logical:: finished - integer:: sym - sym=node_sym(node) - select case(sym) - case(sym_sub) - finished=get_ref_pattern(coder,node_arg(node,1),name) - if(.not.finished) call code_val(coder,node) - case(sym_dot) - finished=get_ref_pattern(coder,node_arg(node,1),name) - if(.not.finished) call code_val(coder,node_arg(node,2)) - case(sym_at) - finished=get_ref_pattern(coder,node_arg(node,1),name) - finished=.true. - case(sym_name) - name=node_arg(node,1) - call code_val(coder,name) - finished=.false. - case default - finished=.true. - end select - contains - include 'fname.inc' - end function get_ref_pattern - - !======================================================================= - ! Match reference patterns in coder%vstack(base1+1..base2) and - ! coder%vstack(base2+1..coder%vtop) coding runtime checks when needed - ! Either - ! Compile alias checking of arguments (provide idx1,idx2,list) - ! Or - ! Compile alias check between two references (provide test) - !======================================================================= - subroutine match_ref_pattern(coder,cblock,node,base1,base2,idx1,idx2,list,test) + end subroutine trav_ref_to_var + + function check_aliased(coder,node1,node2,str) result(aliased) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: base1,base2 - integer,intent(in),optional:: idx1,idx2 - type(pm_ptr),intent(in),optional:: list - logical,intent(in),optional:: test - type(pm_ptr):: p1,p2 - integer:: i,j,n1,n2,m,vbase - logical:: has_dollar - - n1=base2-base1 - n2=coder%vtop-base2 - if(n1==0.or.n2==0) return - - if(.not.present(test)) then - ! Check is cross matching of .name proves no alias is possible - if(match_ref_names(coder,cblock,node,base1,base2)) return + type(pm_ptr),intent(in):: node1,node2 + character(len=*):: str + logical:: aliased + logical:: hard_aliased + aliased=is_aliased(node1,node2,hard_aliased) + if(hard_aliased) then + call code_error(coder,node1,str) + call code_error(coder,node2,'Corresponding variable access for the above error') + endif + end function check_aliased + + function is_aliased(node1,node2,hard_aliased) result(aliased) + type(pm_ptr),intent(in):: node1,node2 + logical,intent(out),optional:: hard_aliased + logical:: aliased + integer:: i,start,ds1,ds2,sym1,sym2 + type(pm_ptr):: arg1,arg2 + + arg1=node_arg(node1,1) + sym1=node_sym(arg1) + arg2=node_arg(node2,1) + sym2=node_sym(arg2) + if(sym1/=sym_name.or.sym2/=sym_name) then + aliased=.false. + if(present(hard_aliased)) hard_aliased=.false. + return + else + if(node_num_arg(arg1,1)/=node_num_arg(arg2,1)) then + aliased=.false. + if(present(hard_aliased)) hard_aliased=.false. + return + endif endif - ! May alias - code any required run-time subscript checks - if(present(test)) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call dup_expr(coder,coder%vstack(base1)) - m=1 - else - call make_int_const(coder,cblock,node,idx1) - call make_int_const(coder,cblock,node,idx2) - m=2 + start=2 + sym1=node_sym(node_arg(node1,2)) + sym2=node_sym(node_arg(node2,2)) + if(sym1==sym_pling.or.sym2==sym_pling) then + if(sym1/=sym2) then + aliased=.true. + if(present(hard_aliased)) hard_aliased=.true. + return + endif + start=3 endif - i=1 - j=1 - do while(i<=n1.and.j<=n2) - p1=coder%vstack(base1+i) - p2=coder%vstack(base2+j) + + ds1=merge(1,0,sym1==sym_at) + ds2=merge(1,0,sym2==sym_at) - ! Check for matching "[]" in both arguments - if(.not.pm_fast_isname(p1).and..not.pm_fast_isname(p2)) then - - ! Code subscript in 1st argument - has_dollar=trav_index_list(coder,cblock,node_arg(p1,2),.true.) - - ! Check for and consolidate subsequent subscripts - i=i+1 - if(i<=n1) then - p1=coder%vstack(base1+i) - if(.not.pm_fast_isname(p1)) then - call make_temp_var(coder,cblock,node) - call swap_and_dup_code(coder) - vbase=coder%vtop-1 - do while(.not.pm_fast_isname(p1)) - has_dollar=trav_index_list(coder,cblock,node_arg(p1,2),.true.) - i=i+1 - if(i>n1) exit - p1=coder%vstack(base1+i) - enddo - call make_sys_call(coder,cblock,node,sym_combine_indices,& - coder%vtop-vbase,1) - endif - endif - - ! Code subscript in 2nd argument - has_dollar=trav_index_list(coder,cblock,node_arg(p2,2),.true.) - - ! Check for and consolidate subsequent subscripts - j=j+1 - if(j<=n2) then - p2=coder%vstack(base2+j) - if(.not.pm_fast_isname(p2)) then - call make_temp_var(coder,cblock,node) - call swap_and_dup_code(coder) - vbase=coder%vtop-1 - do while(.not.pm_fast_isname(p2)) - has_dollar=trav_index_list(coder,cblock,node_arg(p2,2),.true.) - j=j+1 - if(j>n2) exit - p2=coder%vstack(base2+j) - enddo - call make_sys_call(coder,cblock,node,sym_combine_indices,& - coder%vtop-vbase,1) - endif + do i=start,min(node_numargs(node1),node_numargs(node2)) + arg1=node_arg(node1,i+ds1) + arg2=node_arg(node2,i+ds2) + if(node_sym(arg1)==sym_dot.and.node_sym(arg2)==sym_dot) then + if(node_num_arg(arg1,1)/=node_num_arg(arg2,1)) then + aliased=.false. + if(present(hard_aliased)) hard_aliased=.false. + return endif - - ! Now have 2 more arguments for alias checker - m=m+2 - elseif(pm_fast_isname(p1).and.pm_fast_isname(p2)) then - ! Matching .name in both arguments - just skip - i=i+1 - j=j+1 else - ! Matching .name with [] - ! This situation cannot occur with type-correct code - ! So quit here - a type error will be raised later, - ! while an alias error would be confusing - coder%vtop=coder%vtop-m + aliased=.true. + if(present(hard_aliased)) hard_aliased=.false. return endif enddo - if(m<=2) then - if(.not.present(test)) then - ! There were no subscripts, so clash can be confirmed at compile time - call code_error(coder,node_arg(list,idx2),& - 'Argument aliased by "&" argument') - call code_error(coder,node_arg(list,idx1),& - 'Argument causing the alias') - endif - coder%vtop=coder%vtop-2 - else - ! Code call to check for subscript aliasing - call make_sys_call(coder,cblock,node,sym_check_alias,m,& - merge(1,0,present(test))) - endif - contains - include 'fisname.inc' - include 'fvkind.inc' - end subroutine match_ref_pattern - + aliased=.true. + if(present(hard_aliased)) hard_aliased=.true. + end function is_aliased - !======================================================================= - ! Match reference patterns in coder%vstack(base1+1..base2) and - ! coder%vstack(base2+1..coder%vtop) to compare presence of .name - ! qualifiers to see if mismatch proves no aliasing is possible - !======================================================================= - function match_ref_names(coder,cblock,node,base1,base2) & - result(differ) + subroutine make_name_value(coder,cblock,node,name) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: base1,base2 - logical:: differ - type(pm_ptr):: p1,p2 - integer:: i,j,n1,n2,m,vbase - logical:: has_dollar - differ=.false. - n1=base2-base1 - n2=coder%vtop-base2 - if(n1==0.or.n2==0) return - i=1 - j=1 - do while(i<=n1.and.j<=n2) - p1=coder%vstack(base1+i) - p2=coder%vstack(base2+j) - if(pm_fast_isname(p1).and.pm_fast_isname(p2)) then - ! Compare "." names - if(p1%offset/=p2%offset) then - differ=.true. - return - endif - i=i+1 - j=j+1 + integer,intent(in):: name + call make_const(coder,cblock,node,& + pm_name_val(coder%context,name),& + pm_new_name_type(coder%context,name)) + end subroutine make_name_value + + !=================================================================== + ! Use expression on top of stack to create new variable or constant + !=================================================================== + recursive subroutine make_definition(coder,cblock,node,vname,flags,vtype,mode,dotdotdot) + type(code_state):: coder + type(pm_ptr),intent(in):: cblock,node,vname + integer,intent(in):: flags + type(pm_ptr),intent(in),optional:: vtype + integer,intent(in),optional:: mode + logical,intent(in),optional:: dotdotdot + type(pm_ptr):: pnode,var + integer:: name,has_type + integer:: vcall,vflags + logical:: has_mode + + if(node_sym(vname)==sym_name.or.pm_fast_isname(vname)) then + if(pm_fast_isname(vname)) then + name=vname%offset + pnode=node else - ! Skip past "[]" subscripts - if(.not.pm_fast_isname(p1)) then - i=i+1 - endif - if(.not.pm_fast_isname(p2)) then - j=j+1 + name=node_num_arg(vname,1) + pnode=vname + endif + has_mode=present(mode) + if(has_mode) has_mode=mode>0 + vflags=flags + if(has_mode) vflags=ior(vflags,var_is_maybe_not_private) + if(iand(flags,var_is_var)==0) then + var=top_code(coder) + if(cnode_get_kind(var)==cnode_is_var) then + if(cnode_flags_set(var,var_flags,var_is_maybe_not_private)) then + vflags=ior(vflags,var_is_maybe_not_private) + endif endif endif - enddo - contains - include 'fisname.inc' - end function match_ref_names - - !======================================================== - ! Subscripts (including dollar subscripts) - !======================================================== - recursive function trav_index_list(coder,cblock,node,is_val) result(has_dollar) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node - logical,optional,intent(in):: is_val - logical:: has_dollar - integer:: n,flags - integer:: i,j,save_subs_index,max_idx - logical:: replicated - integer:: which(0:8) - type(pm_ptr):: p - logical:: has_underscore_error - has_underscore_error=.false. - flags=0 - n=node_numargs(node) - if(n>1.or.node_sym(node)==sym_dotdotdot) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - endif - save_subs_index=coder%subs_index - which=0 - replicated=.false. - max_idx=0 - do i=1,n - coder%subs_index=0 - p=node_arg(node,i) - if(node_sym(p)==sym_underscore) then - p=find_param(coder,cblock,node,& - pm_fast_name(coder%context,sym_stretch_dim)) - if(pm_fast_isnull(p)) call pm_panic('Cant find stretch dim') - call code_val(coder,p) - if(.not.present(is_val).and..not.has_underscore_error) then - call code_error(coder,node_arg(node,i),& - 'Cannot have "_" in a left-hand-side subscript') - has_underscore_error=.true. + if(present(dotdotdot)) then + var=find_var(coder,name) + if(pm_fast_isnull(var)) then + call code_error(coder,vname,& + 'Variable being intialised with "..." has not been previously defined') + call make_temp_var(coder,cblock,node) + var=top_code(coder) + else + if(cnode_flags_set(var,var_flags,var_is_var).neqv.iand(flags,var_is_var)/=0) then + if(iand(flags,var_is_var)/=0) then + call code_error(coder,node,& + '"let..." cannot be intialised using "var ...="') + else + call code_error(coder,node,& + '"var..." cannot be intialised using "let ...="') + endif + endif + call code_val(coder,var) endif else - call trav_expr(coder,cblock,& - node,node_arg(node,i)) + call make_var(coder,cblock,pnode,name,vflags) + var=top_code(coder) endif - j=coder%subs_index - replicated=replicated.or.(which(j)>0.and.j>0) - which(j)=i - max_idx=max(max_idx,j) - enddo - if(node_sym(node)==sym_dotdotdot) then - flags=call_is_vararg - endif - if(which(1)>0.and.n/=1) then - call code_error(coder,node,& - 'Cannot use "$" without ".dimension" in subscript with more than one argument') - endif - if(n>1.or.node_sym(node)==sym_dotdotdot) then - call make_sys_call(coder,cblock,node,sym_tuple,n,1,& - aflags=flags) - endif - if(max_idx>0) then - if(coder%par_state==par_state_outer) then - call code_error(coder,node,'Cannot have "$" index outside of any parallel context') + call swap_code(coder) + has_type=0 + if(present(vtype)) then + if(.not.pm_fast_isnull(vtype)) then + has_type=1 + call trav_type_constraint(coder,node,vtype) + call make_const(coder,cblock,node,& + pm_fast_tinyint(coder%context,pop_word(coder))) + call make_sp_call_rtn(coder,cblock,node,sym_type_val,1,1) + endif endif - coder%temp2=pop_code(coder) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call code_val(coder,coder%temp2) - coder%temp2=pm_null_obj - if(max_idx>1.and.all(which(2:max_idx)>0)) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - do i=2,max_idx - if(which(i)>0) then - call make_static_long_const(coder,cblock,node,int(which(i),pm_ln)) - else - call make_const(coder,cblock,node,pm_null_obj) - endif - end do - call make_sys_call(coder,cblock,node,sym_tuple,max_idx-1,1) - call make_sys_call(coder,cblock,node,sym_make_dtuple,2,1) + vcall=merge(sym_make_var,sym_make_const,iand(flags,var_is_var)/=0) + if(present(dotdotdot)) then + vcall=merge(sym_init_var,sym_init_const,iand(flags,var_is_var)/=0) + call code_val(coder,var) + call make_sp_call_rtn(coder,cblock,pnode,sym_dotdotdot,1,1) + call update_change_lists(coder,var,.true.) + has_type=1 + endif + if(coder%par_state>par_state_none) then + ! Assumes cannot have "const" in a mode statement + if(has_mode) vcall=vcall+mode-sym_chan+1 + call make_comm_sys_call(coder,cblock,pnode,vcall,1+has_type,1) else - call make_sys_call(coder,cblock,node,sym_make_dtuple,1,1) + if(has_mode) call code_error(coder,node,'Cannot have a "'//& + trim(sym_names(mode))//' var" definition outside of a parallel context') + call make_sys_call(coder,cblock,pnode,vcall,1+has_type,1) endif + elseif(node_sym(vname)==sym_underscore) then + call drop_code(coder) + else + call code_error(coder,node,& + 'Left hand side of definition must be variable name') endif - coder%subs_index=save_subs_index - has_dollar=max_idx>0 + contains - include 'fname.inc' + include 'fisname.inc' + include 'fvkind.inc' include 'fisnull.inc' - end function trav_index_list + include 'ftiny.inc' + end subroutine make_definition + !======================================================== ! Create a new system variable from expr on top of stack @@ -3943,13 +3024,12 @@ subroutine define_sys_var(coder,cblock,node,name,flags) type(pm_ptr),intent(in):: cblock,node integer,intent(in):: name integer,intent(in):: flags - integer:: junk type(pm_ptr):: var call make_sys_var(coder,cblock,node,name,flags) var=top_code(coder) call swap_code(coder) - call make_sys_call(coder,cblock,node,sym_dup,1,1,aflags=call_ignore_rules) - call make_var_mode(coder,cblock,node,var) + call make_comm_sys_call(coder,cblock,node,& + merge(sym_make_var,sym_make_const,iand(flags,var_is_var)/=0),1,1) end subroutine define_sys_var !======================================================== @@ -3960,63 +3040,11 @@ subroutine init_var(coder,cblock,node,var) type(pm_ptr),intent(in):: cblock,node,var call code_val(coder,var) call swap_code(coder) - call make_sys_call(coder,cblock,node,sym_dup,1,1,aflags=call_ignore_rules) - call make_var_mode(coder,cblock,node,var) + call make_comm_sys_call(coder,cblock,node,& + merge(sym_make_var,sym_make_const,cnode_flags_set(var,var_flags,var_is_var)),& + 1,1) end subroutine init_var - !======================================================== - ! Set the mode (and maybe depth) of a variable - !======================================================== - subroutine make_var_mode(coder,cblock,node,var) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node - type(pm_ptr),intent(in)::var - if(coder%run_flags==0) then - if(iand(cnode_get_num(var,var_flags),var_is_var)/=0) then - call code_val(coder,var) - call make_basic_sp_call(coder,cblock,node,& - merge(sym_partial,sym_coherent,coder%par_state>=par_state_cond),& - 1,0,coder%par_depth) - endif - else - call code_val(coder,var) - call code_num(coder,coder%run_mode) - if(iand(coder%run_flags,proc_run_shared+proc_run_local)/=0) then - call var_set_par_depth(coder,var,coder%par_depth-1) - call make_basic_sp_call(coder,cblock,node,& - sym_var_set_mode,2,0,coder%par_depth-1) - else - call make_basic_sp_call(coder,cblock,node,& - sym_var_set_mode,2,0,coder%par_depth) - endif - endif - end subroutine make_var_mode - - !======================================================== - ! Assign top of stack to a given variable - !======================================================== - subroutine make_var_assignment(coder,cblock,node,var,aflags) - type(code_state):: coder - type(pm_ptr),intent(in):: cblock,node - type(pm_ptr),intent(in)::var - integer,intent(in),optional:: aflags - type(pm_ptr):: v - integer:: flags - flags=call_ignore_rules - if(present(aflags)) then - flags=ior(flags,aflags) - endif - call code_val(coder,var) - v=var - call swap_code(coder) - if(cnode_flags_set(v,var_flags,var_is_ref)) then - call make_assign_call(coder,cblock,node,sym_set_ref,2,0,aflags=flags) - else - call make_assign_call(coder,cblock,node,sym_assignment,2,0,aflags=flags) - endif - call cnode_set_flags(v,var_flags,var_is_changed) - end subroutine make_var_assignment - !*************************************************** ! EXPRESSIONS @@ -4042,7 +3070,6 @@ end subroutine trav_exprlist recursive subroutine trav_top_expr(coder,cblock,pnode,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node - integer:: save_par_state if(node_sym(node)==sym_open) then call make_temp_var(coder,cblock,pnode) call dup_code(coder) @@ -4074,51 +3101,48 @@ end subroutine trav_closed_expr recursive subroutine trav_expr(coder,cblock,pnode,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node - integer:: sym,i,n,m,nsym,base,flags,outmode - logical:: outer,shared,isproc,ischan,save_fixed - type(pm_ptr):: list,name,p,q,save_sub_array - integer:: save_par_state,loop_flags - + integer:: sym,i,n,base,outmode + logical:: save_fixed + type(pm_ptr):: list,p,q + integer:: loop_flags + sym=node_sym(node) loop_flags=0 select case(sym) case(sym_true) - call make_const(coder,cblock,pnode,coder%true) + if(coder%fixed) then + call make_const(coder,cblock,pnode,coder%true,coder%true_fix) + else + call make_const(coder,cblock,pnode,coder%true) + endif case(sym_false) - call make_const(coder,cblock,pnode,coder%false) - case(sym_null) - call make_const(coder,cblock,pnode,pm_null_obj) - case(sym_arg,sym_name,sym_use) - call trav_name(coder,cblock,node,sym,node_arg(node,1)) - case(sym_proc) - if(node_numargs(node)==1) then - call proc_const(coder,cblock,node,node_arg(node,1)) + if(coder%fixed) then + call make_const(coder,cblock,pnode,coder%false,coder%false_fix) else - p=find_imported_decl(coder,node,& - node_arg(node,1),node_arg(node,2),modl_proc) - if(pm_fast_isnull(p)) then - call make_temp_var(coder,cblock,node) - else - call proc_const_from_decl(coder,cblock,node,p) - endif + call make_const(coder,cblock,pnode,coder%false) endif - return + case(sym_null) + call make_const(coder,cblock,pnode,pm_null_obj,int(pm_null)) + case(sym_dotdotdot,sym_name,sym_use) + call trav_name(coder,cblock,node,sym,node_num_arg(node,1)) + case(sym_proc) + call proc_const(coder,cblock,pnode,node) case(sym_param) if(node_numargs(node)==2) then - p=find_param(coder,cblock,node,node_arg(node,1),& - node_arg(node,2)) + p=find_param(coder,cblock,node,node_num_arg(node,1),& + node_num_arg(node,2)) if(pm_fast_isnull(p)) then call code_error(coder,node,'Cannot find parameter: ',& - node_arg(node,1)) + node_num_arg(node,1)) call make_temp_var(coder,cblock,node) else call code_val(coder,p) endif else - p=find_param(coder,cblock,node,node_arg(node,1)) + p=find_param(coder,cblock,node,node_num_arg(node,1)) if(pm_fast_isnull(p)) then call code_error(coder,node,& - 'Cannot find parameter: ',node_arg(node,1)) + 'Cannot find parameter: ',node_num_arg(node,1)) call make_temp_var(coder,cblock,node) else call code_val(coder,p) @@ -4128,186 +3152,156 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call name_const(node,sym_stretch_dim) return case(sym_unique) - p=node_arg(node,1) - call name_const(node,int(p%offset)) - return - case(sym_dash) - p=node_arg(node,1) - if(pm_fast_isname(p)) then - call make_static_bool_const(coder,cblock,node,& - p%offset==sym_true) - else - call make_const(coder,cblock,node,p,& - pm_new_value_typ(coder%context,p)) - endif + call name_const(node,node_num_arg(node,1)) return - case(sym_fix) - call make_temp_var(coder,cblock,node) - call dup_code(coder) + case(sym_fix,sym_literal) save_fixed=coder%fixed coder%fixed=.true. - call trav_closed_expr(coder,cblock,node,node_arg(node,1)) + call trav_expr(coder,cblock,node,node_arg(node,1)) coder%fixed=save_fixed - call make_sp_call(coder,cblock,node,sym_dash,1,1) + call make_sp_call_rtn(coder,cblock,node,sym,1,1) case(sym_present) - p=node_arg(node,1) - i=p%offset + i=node_num_arg(node,1) i=find_var_entry(coder,i,coder%proc_base) if(i==0) then - call code_error(coder,node,'Variable undefined in "present": ',p) + call code_error(coder,node,'Object undefined in "present": ',i) call make_temp_var(coder,cblock,node) else q=coder%var(i) if(cnode_flags_set(q,var_flags,var_is_key)) then - call code_val(coder,coder%var(i+1)) + call code_val(coder,cnode_get(q,var_extra_info)) + call make_sp_call_rtn(coder,cblock,node,sym_present,1,1) else call code_error(coder,node,& - 'Not a keyword argument in "present": ',p) + '"present" applied to an object that is not a keyword argument: ',i) call make_temp_var(coder,cblock,node) endif endif - case(first_operator:last_operator,& - sym_if_expr,sym_switch_expr) + case(first_operator:first_non_idx_operator-1) + n=node_numargs(node) + do i=1,n + call trav_expr(coder,cblock,& + node,node_arg(node,i)) + enddo + if(check_args_for_chan(n)) then + call make_comm_sys_call_rtn(coder,cblock,node,& + sym,n,1) + else + call make_sys_call_rtn(coder,cblock,node,& + sym,n,1) + endif + case(first_non_idx_operator:last_operator) + n=node_numargs(node) + do i=1,n + call trav_expr(coder,cblock,& + node,node_arg(node,i)) + enddo + call make_sys_call_rtn(coder,cblock,node,& + sym,n,1) + case(sym_as) + call trav_expr(coder,cblock,& + node,node_arg(node,1)) + call trav_expr(coder,cblock,& + node,node_arg(node,2)) + call make_sys_call_rtn(coder,cblock,node,& + sym,2,1,aflags=call_takes_uninit+call_converts_uninit+call_keep_literals) + case(sym_pm_list) call make_temp_var(coder,cblock,node) call dup_code(coder) do i=1,node_numargs(node) call trav_expr(coder,cblock,& node,node_arg(node,i)) enddo - call make_sys_call(coder,cblock,node,& + call make_sp_call(coder,cblock,node,& + sym_pm_list,node_numargs(node),1) + case(sym_if_expr) + do i=1,node_numargs(node) + call trav_expr(coder,cblock,& + node,node_arg(node,i)) + enddo + call make_sys_call_rtn(coder,cblock,node,& sym,node_numargs(node),1) - case(sym_uhash,sym_ustar) - if(coder%par_state>par_state_outer) then + case(sym_switch_expr) + n=node_numargs(node) + do i=2,n-2 call make_temp_var(coder,cblock,node) call dup_code(coder) - call make_comm_call_args(coder,cblock,pnode) - call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_comm_sys_call(coder,cblock,node,& - merge(sym_hash,sym_mult,sym==sym_uhash),1,1) - else call make_temp_var(coder,cblock,node) call dup_code(coder) - call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_sys_call(coder,cblock,node,& - merge(sym_hash,sym_mult,sym==sym_uhash),1,1) - endif + if(i==2) then + call trav_expr(coder,cblock,node,node_arg(node,1)) + base=coder%vtop + else + call dup_expr(coder,coder%vstack(base)) + endif + p=node_arg(node,i) + if(node_sym(p)==sym_dotdot) then + call make_temp_var(coder,cblock,node) + call dup_code(coder) + call trav_expr(coder,cblock,node,node_arg(p,1)) + call trav_expr(coder,cblock,node,node_arg(p,2)) + call make_sys_call(coder,cblock,node,sym_case_range,2,1) + else + call trav_expr(coder,cblock,node,p) + endif + call make_sys_call(coder,cblock,node,sym_checkcase,2,1) + call trav_expr(coder,cblock,node,node_arg(node,i+1)) + enddo + call trav_expr(coder,cblock,node,node_arg(node,n)) + do i=2,n-2 + call make_sys_call(coder,cblock,node,sym_if_expr,3,1) + enddo + case(sym_uhash,sym_ustar) + call trav_expr(coder,cblock,node,node_arg(node,1)) + call make_comm_sys_call_rtn(coder,cblock,node,& + merge(sym_hash,sym_mult,sym==sym_uhash),1,1) case(sym_lt) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call trav_expr(coder,cblock,node,node_arg(node,2)) call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_sys_call(coder,cblock,node,sym_gt,2,1) + call make_sys_call_rtn(coder,cblock,node,sym_gt,2,1) case(sym_le) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call trav_expr(coder,cblock,node,node_arg(node,2)) call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_sys_call(coder,cblock,node,sym_ge,2,1) - case(sym_pm_dref:sym_pm_ref) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - do i=1,node_numargs(node) + call make_sys_call_rtn(coder,cblock,node,sym_ge,2,1) + case(sym_pm_ref) + call code_val(coder,node_arg(node,1)) + do i=2,node_numargs(node) call trav_expr(coder,cblock,node,node_arg(node,i)) enddo - call make_sp_call(coder,cblock,node,sym,node_numargs(node),1) - case(sym_caret) - if(node_numargs(node)==1) then - outmode=trav_ref(coder,cblock,pnode,node,0) - elseif(.not.pm_fast_isnull(node_arg(node,2))) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call trav_expr(coder,cblock,node,node_arg(node,1)) - call code_val(coder,node_arg(node,2)) - call make_basic_sp_call(coder,cblock,node,sym_change_mode,2,1,coder%par_depth) - else - call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_var(coder,cblock,node,pm_fast_name(coder%context,sym_caret),& - var_is_shadowed+var_is_no_import_export,pop_code(coder)) - endif - case(sym_dcaret) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_sp_call(coder,cblock,node,sym_dcaret,1,1) - case(sym_dot) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - if(node_sym(node_arg(node,1))==sym_name) then - call trav_expr(coder,cblock,node,node_arg(node,1)) - call make_const(coder,cblock,node,node_arg(node,2)) - call make_sp_call(coder,cblock,node,sym_dot,2,1) - else - outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) - if(coder%par_state>par_state_outer) then - p=pop_code(coder) - call make_comm_call_args(coder,cblock,node) - call code_val(coder,p) - call make_static_bool_const(coder,cblock,node,iand(outmode,ref_has_at)/=0) - call make_comm_sys_call(coder,cblock,node,sym_get_ref,2,1) - call check_par_nesting(coder,cblock,node,.true.) - else - call make_sys_call(coder,cblock,node,sym_get_val_ref,1,1) - endif - endif - case(sym_get_dot_ref) - outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) - case(sym_get_dot,sym_sub,sym_dot_sub) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) - if(coder%par_state>par_state_outer) then - p=pop_code(coder) - call make_comm_call_args(coder,cblock,node) - call code_val(coder,p) - call make_static_bool_const(coder,cblock,node,iand(outmode,ref_has_at)/=0) - call make_comm_sys_call(coder,cblock,node,sym_get_ref,2,1) - call check_par_nesting(coder,cblock,node,.true.) - else - call make_sys_call(coder,cblock,node,sym_get_val_ref,1,1) - endif - case(sym_at) - outmode=trav_ref(coder,cblock,pnode,node,ref_is_val) + call make_sp_call_rtn(coder,cblock,node,sym_pm_ref,node_numargs(node),1) + case(sym_pm_each_index) + call trav_pm_each_index(coder,cblock,pnode,node,.true.) + case(sym_reference) + call trav_reference(coder,cblock,pnode,node,.false.,.true.,.false.,call_n=n) + if(n>0) call make_comm_sys_call_rtn(coder,cblock,node,sym_get_ref,n+1,1) case(sym_open) call make_temp_var(coder,cblock,node) call dup_code(coder) call trav_call(coder,cblock,pnode,node,1,.false.) case(sym_pval,sym_pval_as) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call trav_expr(coder,cblock,node,node_arg(node,1)) call trav_expr(coder,cblock,node,node_arg(node,2)) - call swap_code(coder) - call make_sp_call(coder,cblock,node,sym,2,1) + call trav_expr(coder,cblock,node,node_arg(node,1)) + call make_sp_call_rtn(coder,cblock,node,sym,2,1) case(sym_type_val) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call trav_type_constraint(coder,node,node_arg(node,1)) call make_const(coder,cblock,node,& pm_fast_tinyint(coder%context,pop_word(coder))) - call make_sp_call(coder,cblock,node,sym_type_val,1,1) + call make_sp_call_rtn(coder,cblock,node,sym_type_val,1,1) case(sym_array_former,sym_matrix_former) i=node_get_num(node,node_args+2) - if(sym==sym_matrix_former) then - call make_temp_var(coder,cblock,node) - call dup_code(coder) - endif - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call array_span(node_get_num(node,node_args+3),node_get_num(node,node_args+1)) if(i/=1) then call array_span(node_get_num(node,node_args+4),i) - call make_sys_call(coder,cblock,node,sym_array,2,1) + call make_sys_call_rtn(coder,cblock,node,sym_array,2,1) else - call make_sys_call(coder,cblock,node,sym_array,1,1) + call make_sys_call_rtn(coder,cblock,node,sym_array,1,1) endif list=node_arg(node,1) call trav_expr(coder,cblock,list,node_arg(list,1)) call swap_code(coder) - call make_sys_call(coder,cblock,list,sym_do_dim,2,1) + call make_sys_call_rtn(coder,cblock,list,sym_do_dim,2,1) if(sym==sym_matrix_former) then - call make_sys_call(coder,cblock,node,sym_matrix_former,1,1) + call make_sys_call_rtn(coder,cblock,node,sym_matrix_former,1,1) endif do i=2,node_numargs(list) call dup_code(coder) @@ -4315,61 +3309,34 @@ recursive subroutine trav_expr(coder,cblock,pnode,node) call trav_expr(coder,cblock,list,node_arg(list,i)) call make_assign_call(coder,cblock,list,sym_set_elem,3,0,aflags=call_ignore_rules) enddo - case(sym_struct,sym_rec) - call trav_structrec(coder,cblock,node) + case(sym_rec) + call trav_rec(coder,cblock,node) case(sym_query) - if(coder%par_state==par_state_outer) then - call code_error(coder,node,& - 'Cannot use "?" or "??" outside of any parallel statement') - elseif(coder%par_statepar_state_outer)) - else - call code_val(coder,p) + call trav_ref_to_var(coder,cblock,node,name,.false.) + if(cnode_get_kind(top_code(coder))==cnode_is_var) then + if(cnode_flags_set(top_code(coder),var_flags,var_is_ref)) then + call make_sys_call_rtn(coder,cblock,node,sym_get_ref,1,1) endif endif endif @@ -4519,17 +3436,17 @@ subroutine trav_name(coder,cblock,node,sym,name) end subroutine trav_name !======================================================== - ! Traverse struct or rec creation "new" expression + ! Traverse "rec" expression ! Parse node contains full_type/ list_of_expr / name / tag !======================================================== - recursive subroutine trav_structrec(coder,cblock,node) + recursive subroutine trav_rec(coder,cblock,node) type(code_state):: coder type(pm_ptr),intent(in):: cblock,node - type(pm_ptr):: exprs,p,name,decl,tag,name1,name2,elems,info - integer:: i,j,k,vbase,n,m,count,nam1,nam2,sym,basex,tno + type(pm_ptr):: exprs,p,decl,tag,name1,name2,elems,info + integer:: i,j,k,name,vbase,n,m,count,nam1,nam2,sym,basex,tno ! Find associated type declaraton (decl) - name=node_arg(node,4) + name=node_num_arg(node,4) tag=node_arg(node,3) decl=find_decl(coder,node,name,modl_type) if(pm_fast_isnull(decl)) then @@ -4539,14 +3456,14 @@ recursive subroutine trav_structrec(coder,cblock,node) else decl=node_arg(decl,2) if(node_sym(decl)/=sym_is) then - call code_error(coder,node,'Not a "struct" or "rec" type name:',name) + call code_error(coder,node,'Not a "rec" type name:',name) call make_temp_var(coder,cblock,node) return else - decl=node_arg(node_get(decl,typ_includes),1) + decl=node_arg(node_get(decl,type_includes),1) sym=node_sym(decl) - if(sym/=sym_struct.and.sym/=sym_rec) then - call code_error(coder,node,'Does not reference "struct" or "rec" type') + if(sym/=sym_rec) then + call code_error(coder,node,'Does not reference "rec" type') call code_error(coder,decl,'Declaration referenced in above error') call make_temp_var(coder,cblock,node) return @@ -4564,22 +3481,22 @@ recursive subroutine trav_structrec(coder,cblock,node) call trav_expr(coder,cblock,exprs,node_arg(node_arg(exprs,i),1)) enddo - ! Set up struct/rec creation call - call make_temp_var(coder,cblock,node) - call dup_code(coder) + ! Set up rec creation call basex=coder%vtop - info=trav_structrec_decl(coder,decl,decl) + info=trav_rec_decl(coder,decl,decl) call make_const(coder,cblock,node,info) if(pm_fast_isnull(node_arg(node,1))) then call code_num(coder,-1) tno=info%data%i(info%offset+1) - tno=pm_typ_arg(coder%context,tno,1) + tno=pm_type_arg(coder%context,tno,1) else call trav_type(coder,node,node_arg(node,1)) - tno=pm_user_typ_body(coder%context,top_word(coder)) + tno=pm_user_type_body(coder%context,top_word(coder)) call code_num(coder,pop_word(coder)) endif - ! At this point tno contains the body of the struct/rec type + call code_val(coder,coder%var(coder%mask)) + + ! At this point tno contains the body of the rec type ! Match element names and push values in correct order name1=pm_name_val(coder%context,int(tag%offset)) @@ -4594,12 +3511,12 @@ recursive subroutine trav_structrec(coder,cblock,node) if(nam1==nam2) then count=count+1 call code_val(coder,coder%vstack(vbase+i)) - call cast_element(node_arg(exprs,i),pm_typ_arg(coder%context,tno,j)) + call cast_element(node_arg(exprs,i),pm_type_arg(coder%context,tno,j)) cycle outer endif enddo p=node_arg(elems,j) - if(node_sym(p)==sym_define) then + if(node_sym(p)==sym_assign) then call trav_closed_expr(coder,cblock,p,node_arg(p,2)) else call code_val(coder,coder%undef_val) @@ -4611,7 +3528,7 @@ recursive subroutine trav_structrec(coder,cblock,node) outer2:do i=1,m do j=1,n nam1=name1%data%i(name1%offset+i) - nam2=name2%data%i(name2%offset+j) + nam2=abs(name2%data%i(name2%offset+j)) if(nam1==nam2) cycle outer2 enddo call element_error(exprs,sym,name,name1,i) @@ -4620,12 +3537,12 @@ recursive subroutine trav_structrec(coder,cblock,node) ! Tidy up and create call if(pm_debug_checks) then - if(coder%vtop/=basex+n+2) then + if(coder%vtop/=basex+n+3) then write(*,*) '>>',coder%vtop,n,coder%vtop-n-2 - call pm_panic('trav_structrec') + call pm_panic('trav_rec') endif endif - call make_sp_call(coder,cblock,node,sym,n+2,1,flags=coder%run_flags) + call make_sp_call_rtn(coder,cblock,node,sym,n+3,1) coder%vstack(vbase+1)=coder%vstack(coder%vtop) coder%vtop=vbase+1 @@ -4635,10 +3552,12 @@ recursive subroutine trav_structrec(coder,cblock,node) include 'ftiny.inc' subroutine element_error(node,sym,name,name1,i) - type(pm_ptr),intent(in):: node,name,name1 + type(pm_ptr),intent(in):: node + integer,intent(in):: name + type(pm_ptr),intent(in):: name1 integer,intent(in):: sym,i call code_error(coder,node_arg(node,i),'"'//trim(sym_names(sym))//' '//& - trim(pm_name_as_string(coder%context,int(name%offset)))//& + trim(pm_name_as_string(coder%context,name))//& '" does not have element "'//& trim(pm_name_as_string(coder%context,& name1%data%i(name1%offset+i)))//'"') @@ -4647,12 +3566,12 @@ end subroutine element_error subroutine cast_element(node,tno) type(pm_ptr),intent(in):: node integer,intent(in):: tno - if(tno/=0) then + !if(tno/=0) then call make_cast(coder,cblock,node,tno) - endif + !endif end subroutine cast_element - end subroutine trav_structrec + end subroutine trav_rec !======================================================== ! Traverse a cast to a type defined by node @@ -4662,7 +3581,6 @@ recursive subroutine trav_cast(coder,cblock,pnode,node,sym) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,pnode,node integer,intent(in):: sym - integer:: mode,depth,tno call trav_type_constraint(coder,pnode,node) if(top_word(coder)/=0) then call make_cast(coder,cblock,node,pop_word(coder)) @@ -4680,45 +3598,14 @@ recursive subroutine make_cast(coder,cblock,node,tno) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node integer,intent(in):: tno - call make_temp_var(coder,cblock,node) - call swap_and_dup_code(coder) - call make_temp_var(coder,cblock,node) - call dup_code(coder) call make_const(coder,cblock,node,& - pm_fast_tinyint(coder%context,tno)) - call make_sp_call(coder,cblock,node,sym_type_val,1,1) - call make_sys_call(coder,cblock,node,sym_as,2,1) + pm_fast_tinyint(coder%context,tno),int(pm_tiny_int)) + call make_sp_call_rtn(coder,cblock,node,sym_type_val,1,1) + call make_sys_call_rtn(coder,cblock,node,sym_as,2,1,aflags=call_keep_literals) contains include 'ftiny.inc' end subroutine make_cast - !======================================================== - ! Parallel scope depth of a value - !======================================================== - function par_depth(coder,val) result(depth) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: val - integer:: depth - depth=max(1,coder%par_depth-1) - if(pm_fast_vkind(val)==pm_pointer) then - if(cnode_get_kind(val)==cnode_is_var) then - depth=cnode_get_num(val,var_par_depth)+coder%proc_par_depth - endif - endif - contains - include 'fvkind.inc' - end function par_depth - - !======================================================== - ! Set a variable to be shared - !======================================================== - subroutine set_var_as_shared(coder,var) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: var - call cnode_set_num(var,var_par_depth,& - coder%par_depth-1-coder%proc_par_depth) - end subroutine set_var_as_shared - !************************************************* ! TYPES @@ -4745,10 +3632,9 @@ end subroutine trav_type_constraint recursive subroutine trav_type(coder,pnode,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: pnode,node - integer:: sym,i,n,m,nshared,base,flags + integer:: sym,i,n,flags integer::typno type(pm_ptr):: name,val,p - character(len=100):: str if(pm_fast_isnull(node)) then call push_word(coder,0) return @@ -4766,7 +3652,7 @@ recursive subroutine trav_type(coder,pnode,node) call push_word(coder,0) case(sym_or) n=node_numargs(node) - call push_word(coder,pm_typ_new_any) + call push_word(coder,pm_type_new_any) call push_word(coder,0) do i=1,n call trav_type(coder,pnode,node_arg(node,i)) @@ -4774,24 +3660,22 @@ recursive subroutine trav_type(coder,pnode,node) call make_type(coder,2+n) case(sym_and) n=node_numargs(node) - call push_word(coder,pm_typ_new_all) + call push_word(coder,pm_type_new_all) call push_word(coder,0) do i=1,n call trav_type(coder,pnode,node_arg(node,i)) enddo call make_type(coder,2+n) case(sym_pval) - call push_word(coder,pm_typ_new_poly) - call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) - call make_type(coder,3) + call push_word(coder,pm_new_poly_type(coder%context,pop_word(coder))) case(sym_type_val) - call push_word(coder,pm_typ_new_type) + call push_word(coder,pm_type_new_type) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) case(sym_includes) - call push_word(coder,pm_typ_new_includes) + call push_word(coder,pm_type_new_includes) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) typno=top_word(coder) @@ -4803,17 +3687,17 @@ recursive subroutine trav_type(coder,pnode,node) call make_type(coder,4) case(sym_proc) if(node_numargs(node)==1) then - p=find_decl(coder,node,node_arg(node,1),modl_proc) + p=find_decl(coder,node,node_num_arg(node,1),modl_proc) if(pm_fast_isnull(p)) then call code_error(coder,node,& 'proc value not associated with any defined procedure: ',& - node_arg(node,1)) + node_num_arg(node,1)) call push_word(coder,0) return endif elseif(node_numargs(node)==2) then - p=find_imported_decl(coder,node,node_arg(node,1),& - node_arg(node,2),modl_proc) + p=find_imported_decl(coder,node,node_num_arg(node,1),& + node_num_arg(node,2),modl_proc) if(pm_fast_isnull(p)) then call push_word(coder,0) return @@ -4824,52 +3708,76 @@ recursive subroutine trav_type(coder,pnode,node) endif call push_word(coder,proc_type_from_decl(coder,p,node)) case(sym_unique) + call push_word(coder,pm_new_name_type(coder%context,node_num_arg(node,1))) + case(sym_fix) name=node_arg(node,1) - call push_word(coder,pm_new_name_typ(coder%context,int(name%offset))) - case(sym_dash) - name=node_arg(node,1) - if(pm_fast_isname(name)) then - if(name%offset==sym_true) then - call push_word(coder,coder%true_name) - else - call push_word(coder,coder%false_name) + select case(node_sym(name)) + case(sym_true) + call push_word(coder,coder%true_fix) + case(sym_false) + call push_word(coder,coder%false_fix) + case(sym_number,sym_string) + call push_word(coder,& + pm_fix_value_type_from_literal(coder%context,node_num_arg(name,1))) + case default + call push_word(coder,pm_type_new_fix) + call push_word(coder,0) + call trav_type(coder,pnode,name) + if(top_word(coder)/=0) then + call defer_type_check(coder,node,pnode,& + coder%literal_types,top_word(coder),sym_fix,& + cnode_is_arg_constraint) endif - else - call push_word(coder,pm_new_value_typ(coder%context,name)) - endif + call make_type(coder,3) + end select + case(sym_literal) + name=node_arg(node,1) + select case(node_sym(name)) + case(sym_true) + call push_word(coder,coder%true_literal) + case(sym_false) + call push_word(coder,coder%false_literal) + case(sym_number,sym_string) + call push_word(coder,node_num_arg(name,1)) + case default + call push_word(coder,pm_type_new_unfixed) + call push_word(coder,0) + call trav_type(coder,pnode,name) + call make_type(coder,3) + end select case(sym_contains) - call push_word(coder,pm_typ_new_contains) + call push_word(coder,pm_type_new_contains) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) case(sym_casts_to) - call push_word(coder,pm_typ_new_has) + call push_word(coder,pm_type_new_has) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) case(sym_except) - call push_word(coder,pm_typ_new_except) + call push_word(coder,pm_type_new_except) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call trav_type(coder,pnode,node_arg(node,2)) call make_type(coder,4) case(sym_type) call trav_type_decl(coder,pnode,node) + case(sym_assign_or_init) + call push_word(coder,pm_type_new_uninitialised) + call push_word(coder,0) + call push_word(coder,0) + call make_type(coder,3) case(sym_open_brace) - name=node_arg(node,1) - call push_word(coder,pm_typ_new_user) - call push_word(coder,int(name%offset)) + call push_word(coder,pm_type_new_user) + call push_word(coder,node_num_arg(node,1)) typno=get_typeno(2) if(typno==0) call pm_panic('Intrinsic type not found') call push_word(coder,typno) - case(sym_struct,sym_rec) + case(sym_rec) flags=node_num_arg(node,7) name=node_arg(node,2) - if(sym==sym_struct) then - call push_word(coder,pm_typ_new_struct+flags) - else - call push_word(coder,pm_typ_new_rec+flags) - endif + call push_word(coder,pm_type_new_rec+flags) call push_word(coder,abs(int(name%offset))) val=node_arg(node,1) n=node_numargs(val) @@ -4878,47 +3786,47 @@ recursive subroutine trav_type(coder,pnode,node) enddo call make_type(coder,n+2) case(sym_caret) - call push_word(coder,pm_typ_new_array) + call push_word(coder,pm_type_new_array) call push_word(coder,node_get_num(node,node_args+1)) call trav_type(coder,pnode,node_arg(node,1)) call trav_type(coder,pnode,node_arg(node,3)) call push_word(coder,int(pm_long)) call make_type(coder,5) case(sym_dcaret) - call push_word(coder,pm_typ_new_vect) + call push_word(coder,pm_type_new_vect) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) case(sym_underscore) - call push_word(coder,pm_typ_new_bottom) + call push_word(coder,pm_type_new_bottom) call push_word(coder,0) call make_type(coder,2) case(sym_const) - call push_word(coder,pm_typ_new_const) + call push_word(coder,pm_type_new_unfixed) call push_word(coder,0) call trav_type(coder,pnode,node_arg(node,1)) call make_type(coder,3) case(sym_list,sym_dotdotdot) if(sym==sym_dotdotdot) then - call push_word(coder,pm_typ_new_vtuple) + call push_word(coder,pm_type_new_vtuple) else - call push_word(coder,pm_typ_new_tuple) + call push_word(coder,pm_type_new_tuple) endif call push_word(coder,0) - base=coder%wtop - nshared=0 n=node_numargs(node) - do i=2,n,2 + do i=1,n,2 val=node_arg(node,i) - if(node_sym(val)==sym_mode) nshared=nshared+1 call trav_type(coder,val,val) enddo - coder%wstack(base)=nshared call make_type(coder,n/2+2) - case(sym_define,sym_var) + case(sym_pm_list) + call push_word(coder,pm_type_new_vtuple+pm_type_is_list) + call push_word(coder,0) + call make_type(coder,2) + case(sym_assign,sym_var) call trav_type(coder,pnode,node_arg(node,1)) case(sym_pm_dref) - call push_word(coder,pm_typ_is_dref) + call push_word(coder,pm_type_is_dref) n=node_get_num(node,node_args) call push_word(coder,n) n=node_numargs(node) @@ -4926,19 +3834,14 @@ recursive subroutine trav_type(coder,pnode,node) call trav_type(coder,pnode,node_arg(node,i)) enddo call make_type(coder,n+1) - case(sym_amp) - call push_word(coder,pm_typ_new_amp) - call push_word(coder,0) - call trav_type(coder,pnode,node_arg(node,1)) - call make_type(coder,3) case(sym_mode) call trav_type(coder,pnode,node_arg(node,1)) typno=pop_word(coder) call push_word(coder,& - pm_typ_add_mode(coder%context,typno,& - node_num_arg(node,2),.false.,.true.)) + pm_type_add_mode(coder%context,typno,& + node_num_arg(node,2),istype=.true.)) case(sym_result) - call push_word(coder,pm_typ_new_tuple) + call push_word(coder,pm_type_new_tuple) call push_word(coder,0) n=node_numargs(node) do i=1,n @@ -4971,7 +3874,7 @@ recursive subroutine trav_type(coder,pnode,node) function get_typeno(size) result(tno) integer,intent(in):: size integer:: tno - tno=pm_typ_lookup(coder%context,& + tno=pm_type_lookup(coder%context,& coder%wstack(coder%wtop-size+1:coder%wtop)) end function get_typeno @@ -4979,7 +3882,7 @@ end function get_typeno function get_user_typeno(size) result(tno) integer,intent(in):: size integer:: tno - tno=pm_user_typ_lookup(coder%context,& + tno=pm_user_type_lookup(coder%context,& coder%wstack(coder%wtop-size+1:coder%wtop)) end function get_user_typeno @@ -4987,24 +3890,24 @@ recursive subroutine proc_type type(pm_ptr):: dp,list,arg integer:: i,j,n,base - call push_word(coder,pm_typ_new_proc) + call push_word(coder,pm_type_new_proc) call push_word(coder,0) base=coder%wtop dp=node_arg(node,1) do i=1,node_numargs(dp),2 - if(.not.pm_fast_isnull(find_type_var(coder,node_arg(dp,i)))) then + if(.not.pm_fast_isnull(find_type_var(coder,node_num_arg(dp,i)))) then call code_error(coder,node,& - 'Cannot shadow type-match parameter:',node_arg(dp,i)) + 'Cannot shadow type-match parameter:',node_num_arg(dp,i)) endif enddo - call push_word(coder,pm_typ_new_proc_sig) - call push_word(coder,node_get_num(node,node_args+1)) + call push_word(coder,pm_type_new_proc_sig) + call push_word(coder,node_num_arg(node,2)) do i=3,4 list=node_arg(node,i) call push_word(coder,& - merge(pm_typ_is_vtuple,pm_typ_is_tuple,node_sym(list)==sym_dotdotdot)) + merge(pm_type_is_vtuple,pm_type_is_tuple,node_sym(list)==sym_dotdotdot)) if(i==4.or.pm_fast_isnull(node_arg(node,5))) then call push_word(coder,0) else @@ -5028,31 +3931,28 @@ end subroutine trav_type !================================================================= ! Traverse a type reference T or T(args) - ! - type node should be of the form args type_name + ! - type node is of the form args type_name ! - process any associated type definition, if not already cached !================================================================= recursive subroutine trav_type_decl(coder,pnode,node) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: pnode,node - type(pm_ptr):: namenode,name,decl,dec,inc,pargs,also_dec - type(pm_ptr):: twice_dec,main_dec,tname,tval,pars,newdec - type(pm_ptr),target:: incset - logical:: is_present,also_present,type_present,is_interface + type(pm_ptr):: namenode,decl,dec,inc,pargs,also_dec + type(pm_ptr):: twice_dec,main_dec,pars,newdec + logical:: is_present,also_present,type_present logical:: dotdotdot_present,multiple_modules,twice,has_constraints - integer:: nargs,sym,i,j,n,base,parbase,ibase,npars,idepth - integer:: new_type,tno - type(pm_reg),pointer:: reg - logical:: ok + integer:: name,nargs,sym,i,base,parbase,ibase,npars,idepth + integer:: new_type,gatebase ! Type name and arguments nargs=node_numargs(node)-1 namenode=node_arg(node,nargs+1) if(pm_fast_isname(namenode)) then - name=namenode + name=namenode%offset else - name=node_arg(namenode,2) + name=node_num_arg(namenode,2) endif - call push_word(coder,pm_typ_new_user) + call push_word(coder,pm_type_new_user) call push_word(coder,-1) if(nargs>0) then ! Type arguments @@ -5064,15 +3964,16 @@ recursive subroutine trav_type_decl(coder,pnode,node) ! Debugging stuff if(debug_codegen) then write(*,*) 'Traverse type def: ',& - trim(pm_name_as_string(coder%context,int(name%offset))),' nargs=',nargs,'{' + trim(pm_name_as_string(coder%context,name)),' nargs=',nargs,'{' do i=coder%wtop-nargs+1,coder%wtop write(*,*) coder%wstack(i) enddo write(*,*) '}' endif - ! Check if this is a type variable base=coder%wtop + + ! Check if this is a type variable if(nargs==0.and.pm_fast_isname(namenode)) then decl=find_type_var(coder,name) if(.not.pm_fast_isnull(decl)) then @@ -5085,19 +3986,19 @@ recursive subroutine trav_type_decl(coder,pnode,node) ! Find declaration if(.not.pm_fast_isname(namenode)) then decl=find_imported_decl(coder,namenode,& - node_arg(namenode,1),node_arg(namenode,2),modl_type) + node_num_arg(namenode,1),node_num_arg(namenode,2),modl_type) if(pm_fast_isnull(decl)) then call code_error(coder,node,& 'Cannot find type: '//& trim(pm_name_as_string(coder%context,node_num_arg(namenode,1)))//'::'//& - trim(pm_name_as_string(coder%context,int(name%offset)))) + trim(pm_name_as_string(coder%context,name))) goto 888 endif else decl=find_decl(coder,node,name,modl_type) if(pm_fast_isnull(decl)) then ! Not found but may be intrinsic declaration - coder%wstack(coder%wtop-nargs)=name%offset + coder%wstack(coder%wtop-nargs)=name new_type=get_typeno(nargs+2) if(new_type>0) then ! .. is intrinsic declaraton, return it @@ -5107,7 +4008,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) endif call code_error(coder,node,& 'Cannot find type: '//& - trim(pm_name_as_string(coder%context,int(name%offset)))) + trim(pm_name_as_string(coder%context,name))) goto 888 endif endif @@ -5123,7 +4024,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) endif ! Create user type entry - pointing to nothing to start with - new_type=pm_new_user_typ(coder%context,coder%wstack(base-nargs-1:base),0) + new_type=pm_new_user_type(coder%context,coder%wstack(base-nargs-1:base),0) ! Check for excessive recursion idepth=node_get_num(decl,node_args+4) @@ -5132,7 +4033,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) call code_error(coder,decl,& 'Very complex recursive type - most probably infinite: '& //trim(pm_name_as_string(coder%context,& - int(name%offset)))) + name))) call node_set_num(decl,node_args+4,idepth+1) endif coder%wtop=coder%wtop-nargs-1 @@ -5144,33 +4045,31 @@ recursive subroutine trav_type_decl(coder,pnode,node) ! Find main definition of type dotdotdot_present=.false. multiple_modules=.false. - is_interface=.false. dec=node_arg(decl,2) ibase=-1 do sym=node_sym(dec) select case(sym) - case(sym_includes,sym_is,sym_dotdotdot,sym_interface) + case(sym_includes,sym_is,sym_dotdotdot) main_dec=dec parbase=coder%wtop - pars=node_get(dec,typ_params) + pars=node_get(dec,type_params) npars=node_numargs(pars)/2 - call make_type_vars(coder,int(name%offset),dec,node,pars,& + call make_type_vars(coder,name,dec,node,pars,& base-nargs,nargs) - inc=node_get(dec,typ_ins) + inc=node_get(dec,type_parents) if(.not.pm_fast_isnull(inc)) then do i=1,node_numargs(inc) call trav_type(coder,pnode,node_arg(inc,i)) call drop_word(coder) enddo endif - has_constraints=.not.pm_fast_isnull(node_get(main_dec,typ_constraints)) + has_constraints=.not.pm_fast_isnull(node_get(main_dec,type_constraints)) if(sym/=sym_is) then - is_interface=sym==sym_interface - inc=node_get(dec,typ_includes) + inc=node_get(dec,type_includes) if(.not.pm_fast_isnull(inc)) then ibase=coder%wtop - call push_word(coder,pm_typ_new_any) + call push_word(coder,pm_type_new_any) call push_word(coder,0) do i=1,node_numargs(inc) call trav_type(coder,pnode,node_arg(inc,i)) @@ -5181,11 +4080,11 @@ recursive subroutine trav_type_decl(coder,pnode,node) else ibase=coder%wtop dotdotdot_present=.true. - call push_word(coder,pm_typ_new_any) + call push_word(coder,pm_type_new_any) call push_word(coder,0) endif else - inc=node_get(dec,typ_includes) + inc=node_get(dec,type_includes) call trav_type(coder,pnode,node_arg(inc,1)) if(has_constraints) then call check_constraints(top_word(coder),inc) @@ -5196,12 +4095,12 @@ recursive subroutine trav_type_decl(coder,pnode,node) case(sym_in) dec=node_arg(dec,1) case default - dec=node_get(dec,typ_link) + dec=node_get(dec,type_link) end select if(pm_fast_isnull(dec)) then call code_error(coder,decl,& 'Type is extended using ":" or "..." but not defined: '//& - trim(pm_name_as_string(coder%context,int(name%offset)))) + trim(pm_name_as_string(coder%context,name))) goto 999 endif enddo @@ -5222,15 +4121,10 @@ recursive subroutine trav_type_decl(coder,pnode,node) write(*,*) 'CHECK TYPE DEF>',sym_names(sym) endif if(sym==sym_in) then - call make_type_vars(coder,int(name%offset),pnode,node,& + call make_type_vars(coder,name,pnode,node,& pm_null_obj,0,0) call trav_type(coder,pnode,node_arg(dec,2)) call pop_type_vars(coder) - if(is_interface) then - call defer_type_check(coder,dec,main_dec,& - new_type,top_word(coder),sym_includes,& - cnode_is_interface_constraint) - endif if(has_constraints) then call check_constraints(top_word(coder),dec) endif @@ -5249,29 +4143,28 @@ recursive subroutine trav_type_decl(coder,pnode,node) else if(sym==sym_also) then also_present=.true. also_dec=dec - pargs=node_get(dec,typ_params) - call make_type_vars(coder,int(name%offset),& + pargs=node_get(dec,type_params) + gatebase=-1 + call make_type_vars(coder,name,& pnode,node,pargs,base-nargs,nargs,& - parbase,npars) - inc=node_get(dec,typ_includes) + parbase,npars,gatebase=gatebase) + inc=node_get(dec,type_includes) if(.not.pm_fast_isnull(inc)) then do i=1,node_numargs(inc) call trav_type(coder,pnode,node_arg(inc,i)) - if(is_interface) then - call defer_type_check(coder,node_arg(inc,i),main_dec,& - new_type,top_word(coder),sym_includes,& - cnode_is_interface_constraint) - endif if(has_constraints) then call check_constraints(top_word(coder),dec) endif enddo endif + if(gatebase>=0) then + call make_type(coder,coder%wtop-gatebase) + endif call pop_type_vars(coder) else - ! sym_dotdotdot, sym_includes or sym_interface + ! sym_dotdotdot, sym_includes if(pm_debug_checks) then - if(sym/=sym_dotdotdot.and.sym/=sym_includes.and.sym/=sym_interface) then + if(sym/=sym_dotdotdot.and.sym/=sym_includes) then if(sym>=0.and.sym<=num_sym) then write(*,*) 'SYM=',trim(sym_names(sym)) else @@ -5280,7 +4173,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) call pm_panic('Not a type in trav_type_decl') endif endif - if(sym==sym_dotdotdot.or.sym==sym_interface) then + if(sym==sym_dotdotdot) then dotdotdot_present=.true. endif if(is_present.or.type_present) then @@ -5291,8 +4184,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) type_present=.true. endif - 20 continue - newdec=node_get(dec,typ_link) + newdec=node_get(dec,type_link) endif if(pm_fast_isnull(newdec)) exit if(node_get_modl_name(dec)/=& @@ -5302,18 +4194,13 @@ recursive subroutine trav_type_decl(coder,pnode,node) ! Create a union type from the parts brought together if(.not.is_present.and.coder%wtop>ibase) then - if(node_sym(main_dec)==sym_interface) then - ! This is an interface type -- create it - call make_type(coder,coder%wtop-ibase) - call trav_interface(coder,node_get(main_dec,typ_interface),& - pop_word(coder)) - elseif(coder%wtop-ibase>3) then + if(coder%wtop-ibase>3) then call make_type(coder,coder%wtop-ibase) endif endif ! Set the body of the user type to be the new type - call pm_user_typ_set_body(coder%context,new_type,top_word(coder)) + call pm_user_type_set_body(coder%context,new_type,top_word(coder)) ! Tidy up and place new type on wstack base=base-nargs-1 @@ -5332,20 +4219,20 @@ recursive subroutine trav_type_decl(coder,pnode,node) if(is_present.and.also_present) then call code_error(coder,also_dec,& 'Cannot add to this type using ":" or "...": '//& - trim(pm_name_as_string(coder%context,int(name%offset)))) + trim(pm_name_as_string(coder%context,name))) call code_error(coder,main_dec,& 'Type declaration being extended in the above error') endif if(also_present.and..not.type_present) then call code_error(coder,also_dec,& '"Type extended using "..." or ":" without original "type is " definition present: '//& - trim(pm_name_as_string(coder%context,int(name%offset)))) + trim(pm_name_as_string(coder%context,name))) endif if(multiple_modules.and.also_present.and..not.dotdotdot_present) then call code_error(coder,also_dec,& 'Type is extended using "..." or ":" across multiple modules"//& " without "..." present in original "type is": '//& - trim(pm_name_as_string(coder%context,int(name%offset)))) + trim(pm_name_as_string(coder%context,name))) endif if(twice) then call code_error(coder,main_dec,& @@ -5356,8 +4243,8 @@ recursive subroutine trav_type_decl(coder,pnode,node) if(debug_codegen) then write(*,*) 'definition traversed for ',& - trim(pm_name_as_string(coder%context,int(name%offset))),'#',top_word(coder) - write(*,*) '#', trim(pm_typ_as_string(coder%context,top_word(coder))) + trim(pm_name_as_string(coder%context,name)),'#',top_word(coder) + write(*,*) '#', trim(pm_type_as_string(coder%context,top_word(coder))) endif return @@ -5370,7 +4257,6 @@ recursive subroutine trav_type_decl(coder,pnode,node) 888 continue coder%wtop=coder%wtop-nargs-1 coder%wstack(coder%wtop)=0 - contains @@ -5386,7 +4272,7 @@ recursive subroutine trav_type_decl(coder,pnode,node) function get_typeno(size) result(tno) integer,intent(in):: size integer:: tno - tno=pm_typ_lookup(coder%context,& + tno=pm_type_lookup(coder%context,& coder%wstack(coder%wtop-size+1:coder%wtop)) end function get_typeno @@ -5396,45 +4282,22 @@ subroutine check_constraints(tno,node) type(pm_ptr):: constraints integer:: i - ! Make an entry for each "<: type" entry to be checked later - constraints=node_get(main_dec,typ_constraints) + ! Make an entry for each ": type" entry to be checked later + constraints=node_get(main_dec,type_constraints) do i=1,node_numargs(constraints) call trav_type(coder,main_dec,node_arg(constraints,i)) call defer_type_check(coder,node,node_arg(constraints,i),pop_word(coder),tno,& - 0,cnode_is_typ_constraint) + 0,cnode_is_type_constraint) enddo end subroutine check_constraints end subroutine trav_type_decl - !=============================================================== - ! Traverse interface declaration and make type - ! base_type must be union of types conforming to the interface - !============================================================== - recursive subroutine trav_interface(coder,node,base_type) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: node - integer,intent(in):: base_type - type(pm_ptr):: p,val - integer:: n,i - p=node_arg(node,2) - call push_word(coder,pm_typ_new_interface) - call push_word(coder,int(p%offset)) - call push_word(coder,base_type) - p=node_arg(node,1) - n=node_numargs(p) - do i=1,n - val=node_arg(p,i) - call trav_type(coder,val,val) - enddo - call make_type(coder,n+3) - end subroutine trav_interface - !=============================================================== - ! Create a template type from struct/rec declaration + ! Create a template type from rec declaration !=============================================================== - recursive function trav_structrec_decl(coder,pnode,decl) result(vect) + recursive function trav_rec_decl(coder,pnode,decl) result(vect) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: decl,pnode type(pm_ptr):: vect @@ -5452,7 +4315,7 @@ recursive function trav_structrec_decl(coder,pnode,decl) result(vect) n=node_numargs(params) do i=1,n,2 arg=node_arg(params,i+1) - call push_word(coder,pm_typ_new_param) + call push_word(coder,pm_type_new_param) call push_word(coder,(i+1)/2) call trav_type(coder,arg,arg) call make_type(coder,3) @@ -5462,7 +4325,7 @@ recursive function trav_structrec_decl(coder,pnode,decl) result(vect) call trav_type(coder,pnode,decl) tno=pop_word(coder) call pop_type_vars(coder) - tno=pm_new_params_typ(coder%context,n,tno) + tno=pm_new_params_type(coder%context,n,tno) vect=pm_fast_newnc(coder%context,pm_int,5) call code_val(coder,vect) ! protect from GC vect%data%i(vect%offset)=node_num_arg(decl,2) @@ -5475,7 +4338,7 @@ recursive function trav_structrec_decl(coder,pnode,decl) result(vect) else call trav_type(coder,pnode,decl) tno=pop_word(coder) - tno=pm_new_params_typ(coder%context,0,tno) + tno=pm_new_params_type(coder%context,0,tno) vect=pm_fast_newnc(coder%context,pm_int,5) call code_val(coder,vect) ! protect from GC vect%data%i(vect%offset)=node_num_arg(decl,2) @@ -5486,33 +4349,32 @@ recursive function trav_structrec_decl(coder,pnode,decl) result(vect) call pm_ptr_assign(coder%context,decl,node_args+5_pm_ln,vect) call drop_code(coder) endif - call pm_typ_record_by_name(coder%context,& + call pm_type_record_by_name(coder%context,& node_get_num(decl,node_args+2),tno) coder%wtop=base contains include 'fisnull.inc' include 'fnewnc.inc' - end function trav_structrec_decl + end function trav_rec_decl !=========================================================== ! Push information on arguments to parameterised type ! If parbase is not present, leave parameters on wstack !=========================================================== subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& - parbase,nbasepars) + parbase,nbasepars,gatebase) type(code_state),intent(inout):: coder integer,intent(in):: parent type(pm_ptr),intent(in):: pnode,callnode,pnames integer,intent(in):: argbase,nargs integer,intent(in),optional:: parbase integer,intent(in),optional:: nbasepars - logical:: ok + integer,intent(out),optional:: gatebase integer:: k,base,wbase,npars - integer:: vtyp,partyp - type(pm_ptr):: pname,tv,name - logical:: local,check_against_base + integer:: vtyp,partyp,vvtyp,name,pname + logical:: check_against_base check_against_base=.false. - name=node_arg(callnode,node_numargs(callnode)) + name=node_num_arg(callnode,node_numargs(callnode)) if(pm_fast_isnull(pnames)) then if(nargs/=0) then call code_error(coder,callnode,& @@ -5540,9 +4402,8 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& endif coder%top=coder%top+1 coder%stack(coder%top)=typevar_start - coder%link(coder%top)=0 coder%var(coder%top)=pm_null_obj - + base=coder%top wbase=coder%wtop if(.not.present(parbase)) then @@ -5551,8 +4412,8 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& enddo endif do k=npars,1,-1 - pname=node_arg(pnames,k*2-1) - coder%stack(k+coder%top+1)=pname%offset + pname=node_num_arg(pnames,k*2-1) + coder%stack(k+coder%top+1)=pname if(k>nargs) then vtyp=0 else @@ -5571,15 +4432,27 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& ! Defer test that parameter conforms to ! parameter in base definition call defer_type_check(coder,pnames,pnode,coder%wstack(parbase+k),& - partyp,int(pname%offset),cnode_is_par_constraint) + partyp,pname,cnode_is_par_constraint) ! Intersect argument and parameter - call push_word(coder,pm_typ_new_all) + call push_word(coder,pm_type_new_all) call push_word(coder,0) call push_word(coder,min(vtyp,partyp)) call push_word(coder,max(vtyp,partyp)) call make_type(coder,4) + vvtyp=vtyp vtyp=pop_word(coder) + + ! Push information on vstack to make gated type + ! which checks for null intersections between + ! arguments and parameters + if(gatebase<0) then + gatebase=coder%wtop + call push_word(coder,pm_type_new_gated) + call push_word(coder,0) + endif + call push_word(coder,vvtyp) + call push_word(coder,partyp) endif else @@ -5590,25 +4463,23 @@ subroutine make_type_vars(coder,parent,pnode,callnode,pnames,argbase,nargs,& else ! Defer test that argument meets parameter constraint call defer_type_check(coder,callnode,pnode,& - partyp,vtyp,int(pname%offset),cnode_is_arg_constraint) + partyp,vtyp,pname,cnode_is_arg_constraint) endif endif - if(find_var_entry(coder,& - int(pname%offset),base)>0) then + if(find_var_entry(coder,pname,base)>0) then call code_error(coder,pnames,& 'Repitition of type parameter name:',& pname) else - call make_var_tab_entry(coder,int(pname%offset),& + call push_var(coder,pname,& pm_fast_tinyint(coder%context,vtyp)) endif enddo coder%top=coder%top+1 coder%stack(coder%top)=typevar_end - coder%link(coder%top)=base - coder%var(coder%top)=pm_null_obj + coder%var(coder%top)%offset=base contains include 'ftiny.inc' include 'fisnull.inc' @@ -5620,13 +4491,13 @@ end subroutine make_type_vars subroutine pop_type_vars(coder) type(code_state),intent(inout):: coder integer:: base - base=coder%link(coder%top) + base=coder%var(coder%top)%offset if(pm_debug_checks) then if(coder%stack(coder%top)/=typevar_end) & call pm_panic('Pop type vars - no end record') endif coder%top=coder%top-1 - call pop_vars_to(coder,base) + coder%top=base if(pm_debug_checks) then if(coder%stack(coder%top)/=typevar_start) & call pm_panic('Pop type vars - not at start record') @@ -5641,21 +4512,19 @@ subroutine copy_type_vars(coder) type(code_state),intent(inout):: coder integer:: top,base,i,nbase top=coder%proc_base - base=coder%link(top) + base=coder%var(top)%offset coder%top=coder%top+1 nbase=coder%top coder%stack(coder%top)=typevar_start - coder%link(coder%top)=0 coder%var(coder%top)=pm_null_obj do i=base+1,top-1 if(coder%stack(i)/=0) then - call make_var_tab_entry(coder,coder%stack(i),coder%var(i)) + call push_var(coder,coder%stack(i),coder%var(i)) endif enddo coder%top=coder%top+1 coder%stack(coder%top)=typevar_end - coder%link(coder%top)=nbase - coder%var(coder%top)=pm_null_obj + coder%var(coder%top)%offset=nbase end subroutine copy_type_vars !======================================== @@ -5663,7 +4532,7 @@ end subroutine copy_type_vars !======================================== function find_type_var(coder,vname) result(vr) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: vname + integer,intent(in):: vname type(pm_ptr):: vr integer:: k integer:: n @@ -5672,8 +4541,8 @@ function find_type_var(coder,vname) result(vr) elseif(coder%stack(coder%top)/=typevar_end) then vr=pm_null_obj else - n=vname%offset - k=find_var_entry(coder,n,int(coder%link(coder%top))) + n=vname + k=find_var_entry(coder,n,int(coder%var(coder%top)%offset)) if(k/=0) then vr=coder%var(k) else @@ -5705,11 +4574,10 @@ end subroutine defer_type_check subroutine complete_type_checks(coder) type(code_state),intent(inout):: coder type(pm_ptr):: p,keys,vals,tv - integer(pm_ln):: i,j + integer(pm_ln):: i integer:: k integer:: tno,tno1,tno2 - type(pm_ptr):: tset,name - type(pm_typ_einfo):: einfo + type(pm_ptr):: name p=coder%prog_cblock keys=pm_dict_keys(coder%context,coder%context%tcache) vals=pm_dict_vals(coder%context,coder%context%tcache) @@ -5717,12 +4585,12 @@ subroutine complete_type_checks(coder) ! Check no named type is problematically recursive do i=0,pm_dict_size(coder%context,coder%context%tcache)-1 tv=keys%data%ptr(keys%offset+i) - if(pm_tv_kind(tv)==pm_typ_is_user) then + if(pm_tv_kind(tv)==pm_type_is_user) then tno=i+1 - if(pm_typ_is_recur(coder%context,tno,tno)) then + if(pm_type_is_recur(coder%context,tno,tno)) then call code_error(coder,pm_null_obj,& 'Type directly includes itself: '//& - trim(pm_typ_as_string(coder%context,tno))) + trim(pm_type_as_string(coder%context,tno))) call pm_ptr_assign(coder%context,vals,i,pm_null_obj) endif endif @@ -5731,16 +4599,14 @@ subroutine complete_type_checks(coder) ! Check all named types include themselves (weeds out some errors) do i=0,pm_dict_size(coder%context,coder%context%tcache)-1 tv=keys%data%ptr(keys%offset+i) - if(pm_tv_kind(tv)==pm_typ_is_user) then + if(pm_tv_kind(tv)==pm_type_is_user) then tno=i+1 ! Check type includes its body to avoid automatic true return - if(.not.pm_typ_includes(coder%context,tno,& - pm_user_typ_body(coder%context,tno),pm_typ_incl_typ,& - einfo)) then + if(.not.pm_type_includes(coder%context,tno,& + pm_user_type_body(coder%context,tno),pm_type_incl_type)) then call code_error(coder,pm_null_obj,& 'Type is incorrectly defined: '//& - trim(pm_typ_as_string(coder%context,tno))) - call pm_typ_error(coder%context,einfo) + trim(pm_type_as_string(coder%context,tno))) endif endif enddo @@ -5754,56 +4620,41 @@ subroutine complete_type_checks(coder) case(cnode_is_arg_constraint) tno1=cnode_num_arg(p,2) tno2=cnode_num_arg(p,3) - if(.not.pm_typ_includes(coder%context,tno1,tno2,pm_typ_incl_typ,& - einfo)) then + if(.not.pm_type_includes(coder%context,tno1,tno2,pm_type_incl_type)) then call cnode_error(coder,p,& 'Type argument "'//& trim(pm_name_as_string(coder%context,& int(name%offset)))//& '" does not meet constraint: '//& - trim(pm_typ_as_string(coder%context,tno1))//& + trim(pm_type_as_string(coder%context,tno1))//& ' inc '//& - trim(pm_typ_as_string(coder%context,tno2))) - call pm_typ_error(coder%context,einfo) + trim(pm_type_as_string(coder%context,tno2))) call code_error(coder,cnode_arg(p,5),& 'Constraint that gave rise to above error') endif case(cnode_is_par_constraint) tno1=cnode_get_num(p,cnode_args+1) tno2=cnode_get_num(p,cnode_args+2) - if(.not.pm_typ_includes(coder%context,tno1,tno2,pm_typ_incl_typ,& - einfo)) then + if(.not.pm_type_includes(coder%context,tno1,tno2,pm_type_incl_type)) then call cnode_error(coder,p,& 'Parameter "'//& trim(pm_name_as_string(coder%context,& int(name%offset)))//& '" does not match base type; parameter contraint: '//& - trim(pm_typ_as_string(coder%context,tno1))//& + trim(pm_type_as_string(coder%context,tno1))//& ' ,argument: '//& - trim(pm_typ_as_string(coder%context,tno2))) - call pm_typ_error(coder%context,einfo) + trim(pm_type_as_string(coder%context,tno2))) call code_error(coder,cnode_arg(p,5),& 'Constraint that gave rise to the above error') endif - case(cnode_is_typ_constraint) + case(cnode_is_type_constraint) tno1=cnode_get_num(p,cnode_args+1) tno2=cnode_get_num(p,cnode_args+2) - if(.not.pm_typ_includes(coder%context,tno1,tno2,pm_typ_incl_equiv,& - einfo)) then + if(.not.pm_type_includes(coder%context,tno1,tno2,pm_type_incl_equiv)) then call cnode_error(coder,p,'Type does not meet constraint:') - call pm_typ_error(coder%context,einfo) call code_error(coder,cnode_arg(p,5),& 'Type constraint referenced in above error') endif - case(cnode_is_interface_constraint) - tno1=pm_user_typ_body(coder%context,cnode_get_num(p,cnode_args+1)) - tno2=cnode_get_num(p,cnode_args+2) - if(.not.pm_interface_typ_conforms(coder%context,tno1,tno2,einfo)) then - call cnode_error(coder,p,'Type does not conform to interface') - call pm_typ_error(coder%context,einfo) - call code_error(coder,cnode_arg(p,5),& - 'Definition of interface referenced in above error') - endif end select p=cnode_arg(p,1) enddo @@ -5825,12 +4676,12 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) type(pm_ptr),intent(in):: cblock,pnode,node integer,intent(in):: nret logical,intent(in):: amps_ok - type(pm_ptr):: list,procs,keys,sig,name,amp,prvar,proc,p,arg - integer:: flags,i,j,nargs,nkeys,ampbase,vsym,outmode,nref - integer:: depth,otop,obase,owbase,base,abase,atop,babase,astart - logical:: iscomm,outer,has_shared_amp_arg,need_alias_checks,shared_ref_ok - integer:: save_run_mode,save_run_flags + type(pm_ptr):: list,procs,keys,keynames,name,amp,amps,prvar,proc + integer:: flags,i,nargs,nkeys,vsym,outmode + integer:: otop,obase,owbase,base + logical:: iscomm,isdot + ! Save stack tops to check clean up otop=coder%top obase=coder%vtop owbase=coder%wtop @@ -5838,51 +4689,32 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) ! Determine properties of call name=node_arg(node,1) list=node_arg(node,2) - keys=node_arg(node,3) - amp=node_arg(node,4) - flags=node_get_num(node,node_args+4) - shared_ref_ok=iand(flags,call_ignore_rules+proc_run_shared+proc_run_local+call_is_comm)/=0 + amp=node_arg(node,3) + keys=node_arg(node,4) + keynames=node_arg(node,5) + flags=node_num_arg(node,6) if(node_sym(list)==sym_dotdotdot) then flags=ior(flags,call_is_vararg) endif - if(iand(flags,proc_run_local+proc_run_shared)/=0) then - if(coder%par_state==par_state_outer) then - call code_error(coder,node,& - 'Cannot have <> call attribute outside of a parallel context',& - name) - endif - endif nargs=node_numargs(list) + iscomm=iand(flags,proccall_is_comm)/=0 + isdot=iand(flags,proccall_is_ref)/=0 + if(debug_codegen) then write(*,*) 'TRAV CALL>',& trim(pm_name_as_string(coder%context,int(name%offset))),& nargs,nret,coder%vtop,flags - write(*,*) 'TOP==',coder%top endif - ! Extra argument for comm calls - if(iand(flags,call_is_comm)/=0) then - iscomm=.true. - call check_par_nesting(coder,cblock,node,pm_fast_isnull(amp)) - - ! Comm call (& its args) operates in standard run mode - ! - not the current one - save_run_mode=coder%run_mode - save_run_flags=coder%run_flags - coder%run_mode=sym_complete - coder%run_flags=0 - elseif(iand(flags,proc_run_shared+proc_run_local)/=0) then - call check_par_nesting(coder,cblock,node,pm_fast_isnull(amp)) - iscomm=.false. - elseif(iand(flags,proc_run_complete)/=0) then - call check_par_nesting(coder,cblock,node,.false.) - iscomm=.false. - else - iscomm=.false. + if(coder%par_state==par_state_none.and.& + iscomm.and.iand(flags,proccall_is_general)==0) then + call code_error(coder,node,& + 'Cannot call a "%" procedure outside of a parallel context: ',int(name%offset)) endif base=coder%vtop - has_shared_amp_arg=.false. + + ! write(*,*) 'AMP',pm_fast_isnull(amp),trim(pm_name_as_string(coder%context,int(name%offset))) ! Standard arguments if(pm_fast_isnull(amp)) then @@ -5891,117 +4723,65 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) node_arg(list,i)) enddo else - if(.not.amps_ok) then - call code_error(coder,list,& - 'Call using "&" or "&&" arguments cannot be a component of an expression') - endif - - amp=pm_name_val(coder%context,int(amp%offset)) + amps=pm_name_val(coder%context,int(amp%offset)) flags=ior(flags,call_is_assign_call) - - ! Make space on vstack to store in/out temp vars for amp args - ampbase=coder%vtop - coder%vstack(coder%vtop+1:coder%vtop+nargs)=pm_null_obj - coder%vtop=coder%vtop+nargs - - ! Alias checks if needed - nref=0 - abase=coder%top - if(pm_opts%check_alias) then - do j=0,pm_fast_esize(amp) - i=amp%data%i(amp%offset+j) - arg=node_arg(list,i) - if(node_sym(arg)==sym_amp) then - call trav_alias_checks(coder,cblock,list,amp,i,ampbase) - nref=nref+1 - endif - enddo - endif - atop=coder%top - - do i=1,nret - call code_val(coder,coder%vstack(base-nret+i)) - enddo - base=coder%vtop - j=0 - do i=1,nargs - if(amp%data%i(amp%offset+j)==i) then - arg=node_arg(list,i) - if(node_sym(arg)==sym_amp) then - outmode=trav_ref(coder,cblock,list,& - node_arg(arg,1),& - merge(ref_ignores_rules+ref_is_amp,ref_is_amp,shared_ref_ok)) - else - call make_temp_var(coder,cblock,list) - call dup_code(coder) - call trav_expr(coder,cblock,list,arg) - call make_basic_sys_call(coder,cblock,node,sym_dup,1,1,& - coder%par_depth,call_ignore_rules) - coder%vstack(ampbase+i)=top_code(coder) - endif - j=min(pm_fast_esize(amp),j+1) - else - arg=node_arg(list,i) - coder%aliased=.false. - call trav_expr(coder,cblock,list,arg) - if(coder%aliased) then - if(node_sym(arg)==sym_dot.or.& - node_sym(arg)==sym_sub) then - arg=coder%vstack(ampbase+i) - if(pm_fast_vkind(arg)==pm_tiny_int) then - !write(*,*) 'nref=',nref,arg%offset,'#',i - if(arg%offset==nref) cycle - endif - endif - call make_temp_var(coder,cblock,list) - call swap_and_dup_code(coder) - call make_sys_call(coder,cblock,node,sym_clone,1,1) - coder%aliased=.false. - endif + if(.not.amps_ok) then + if(iand(flags,proccall_is_yield)/=0) then + call code_error(coder,list,'"yield" cannot be a component of an expression') + elseif(iand(flags,proccall_is_ref)==0) then + call code_error(coder,list,& + 'Call using "&" arguments cannot be a component of an expression') endif + endif + call process_amp_args(list,amps) + endif + + ! Create argument list node from nargs + nret values on vstack + call make_arglist(coder,cblock,node,nargs,nret,.false.,iscomm,comm_args_present=.true.) + + ! Keyword arguments + if(.not.pm_fast_isnull(keys)) then + nkeys=node_numargs(keys) + do i=1,nkeys + call trav_expr(coder,cblock,node,node_arg(keys,i)) enddo - call hide_vars(coder,abase+1,atop) + call make_arglist(coder,cblock,node,nkeys,0,.false.,iscomm) + else + nkeys=0 + call code_null(coder) endif - babase=merge(base+3,base+1,iscomm) - ! Find procs with this signature - amp=node_arg(node,4) + ! Find procs with this name proc=pm_null_obj if(pm_fast_isname(name)) then - proc=find_decl(coder,node,name,modl_proc) + proc=find_decl(coder,node,int(name%offset),modl_proc) if(pm_fast_isnull(proc)) then - call code_error(coder,node,'Cannot find proc: ',name) + call code_error(coder,node,'Cannot find proc: ',int(name%offset)) call make_temp_var(coder,cblock,node) endif else vsym=node_sym(name) select case(vsym) case(sym_name) - proc=find_decl(coder,name,name,modl_proc) + proc=find_decl(coder,name,node_num_arg(name,1),modl_proc) if(pm_fast_isnull(proc)) then - call code_error(coder,name,'Cannot find proc: ',node_arg(name,1)) + call code_error(coder,name,'Cannot find proc: ',node_num_arg(name,1)) endif case(sym_use) - proc=find_imported_decl(coder,name,node_arg(name,1),& - node_arg(name,2),modl_proc) + proc=find_imported_decl(coder,name,node_num_arg(name,1),& + node_num_arg(name,2),modl_proc) case(sym_dot) call trav_expr(coder,cblock,node,node_arg(name,1)) case(sym_proc) if(node_numargs(name)==1) then - proc=find_decl(coder,name,node_arg(name,1),modl_proc) + proc=find_decl(coder,name,node_num_arg(name,1),modl_proc) if(pm_fast_isnull(proc)) then - call code_error(coder,name,'Cannot find proc: ',node_arg(name,1)) + call code_error(coder,name,'Cannot find proc: ',node_num_arg(name,1)) endif else - proc=find_imported_decl(coder,name,node_arg(name,1),& - node_arg(name,2),modl_proc) + proc=find_imported_decl(coder,name,node_num_arg(name,1),& + node_num_arg(name,2),modl_proc) endif - case(sym_method_call) - call make_temp_var(coder,cblock,node) - call dup_code(coder) - call code_val(coder,coder%vstack(babase)) - call make_const(coder,cblock,node,node_arg(name,1)) - call make_sp_call(coder,cblock,node,sym_method_call,2,1) case default write(*,*) sym_names(vsym) call pm_panic('Bad VSYM in trav_call') @@ -6011,14 +4791,14 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) endif endif + ! Now find procs with this signature if(.not.pm_fast_isnull(proc)) then prvar=pm_null_obj - procs=find_sig(coder,node,name,& - amp,nargs,nret,flags,sig,iscomm,procroot=proc) + procs=find_sig(coder,node,name,proc) else + ! f.(...) call prvar=pop_code(coder) - procs=find_vcall_sig(coder,node,amp,& - nargs,nret,flags,sig,iscomm) + procs=pm_fast_tinyint(coder%context,0) endif ! Error return if no such proc @@ -6027,71 +4807,9 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) return endif - ! Keyword arguments (need sig first) - if(.not.pm_fast_isnull(prvar).and..not.pm_fast_isnull(keys)) then - call code_error(coder,keys,'Cannot have keyword arguments in ".()" call') - nkeys=0 - else - nkeys=trav_keys(coder,cblock,keys,sig,iscomm) - endif - - ! Swap keyword and standard args - if(nkeys>0) then - call check_vstack(coder,nargs) - do i=base+1,base+nargs - coder%vtop=coder%vtop+1 - coder%vstack(coder%vtop)=coder%vstack(i) - enddo - do i=base+nargs+1,coder%vtop - coder%vstack(i-nargs)=coder%vstack(i) - enddo - coder%vtop=coder%vtop-nargs - endif - - ! Debugging trace - if(debug_codegen) then - if(pm_fast_isname(name)) then - write(*,*) 'TRAV CALL MAKE FULL CALL>',& - trim(pm_name_as_string(coder%context,int(name%offset))),& - nargs,nret,nkeys,coder%vtop - else - write(*,*) 'TRAV CALL MAKE FULL CALL> .proc ',& - nargs,nret,nkeys,coder%vtop - endif - - do i=coder%vtop-nargs-nkeys-nret+1,coder%vtop - call qdump_code_tree(coder,pm_null_obj,6,coder%vstack(i),2) - enddo - write(*,*) 'TRAV CALL END MAKE FULL CALL>' - endif - - flags=ior(flags,coder%run_flags) - if(coder%par_state>=par_state_cond.and.& - iand(flags,proc_run_complete+proc_run_shared+proc_run_local)==0) then - flags=ior(flags,call_is_cond) - endif - if(coder%par_state==par_state_cond.or.& - coder%par_state==par_state_par) then - flags=ior(flags,call_is_unlabelled) - endif - - ! Make the call - call import_args(coder,cblock,node,nargs,nret,nkeys,amp,flags,abase) + ! Make the actual call node call make_full_call(coder,cblock,node,procs,amp,& - nargs,nret,nkeys,flags,prvar,coder%par_depth) - - ! Write out && args - if(.not.pm_fast_isnull(amp)) then - amp=pm_name_val(coder%context,int(amp%offset)) - do i=0,pm_fast_esize(amp) - j=amp%data%i(amp%offset+i) - if(.not.pm_fast_isnull(coder%vstack(ampbase+j))) then - call code_val(coder,coder%vstack(ampbase+j)) - call make_assignment_noalias(coder,cblock,list,node_arg(list,j)) - endif - enddo - coder%vtop=obase-nret - endif + nargs,nret,nkeys,keynames,flags,prvar) ! If this is a variable call, flag the variable if(.not.pm_fast_isnull(prvar)) then @@ -6103,19 +4821,23 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) endif endif endif - - ! Restore run mode/run flags for comm calls - if(iscomm) then - coder%run_mode=save_run_mode - coder%run_flags=save_run_flags - endif - - ! If debugging, check tidy up + + ! If debugging compiler, check tidy up if(pm_debug_checks) then - if(coder%vtop/=obase-nret.or.coder%wtop/=owbase) then - write(*,*) obase,nret,obase-nret,coder%vtop,owbase,coder%wtop,nargs,otop,coder%top - call pm_panic('trav call') + if(coder%vtop/=obase-nret) then + write(*,*) coder%vtop,'/=',obase,'-',nret,& + trim(pm_name_as_string(coder%context,int(name%offset))) + call pm_panic('trav_call vstack mismatch') + endif + if(coder%wtop/=owbase) then + write(*,*) coder%wtop,'/=',owbase,& + trim(pm_name_as_string(coder%context,int(name%offset))) + call pm_panic('trav_call wstack mismatch') endif +!!$ if(coder%top/=otop) then +!!$ write(*,*) coder%top,'/=',otop +!!$ call pm_panic('trav_call local stack mismatch') +!!$ endif endif if(debug_codegen) then @@ -6129,123 +4851,136 @@ recursive subroutine trav_call(coder,cblock,pnode,node,nret,amps_ok) include 'fisname.inc' include 'fesize.inc' include 'fvkind.inc' - end subroutine trav_call - - !=========================================================================== - ! Process keyword arguments - returns num of arguments used - ! -- represented as block of arguments between returns and standard args - ! -- Order is determined by signature of *called* procedure(s) - !========================================================================== - recursive function trav_keys(coder,cblock,list,sig,iscomm) result(nkeys) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,list,sig - logical,intent(in):: iscomm - integer:: nkeys - integer:: start,i,j - type(pm_ptr):: keys,keynames,empty - keys=cnode_arg(sig,1) - if(.not.pm_fast_isnull(keys)) then - ! Create empty block of arguments - start=coder%vtop - nkeys=pm_set_size(coder%context,keys) - do i=1,nkeys - call code_null(coder) - enddo - else - nkeys=0 - endif - if(.not.pm_fast_isnull(list)) then - if(nkeys==0) then - call code_error(coder,list,& - 'Unexpected keyword arguments') - else - ! Fill in correct entry for each supplied keyword argument - do i=1,node_numargs(list),2 - call trav_expr(coder,cblock,list,node_arg(list,i+1)) - if(iscomm) then - if(var_private(coder,top_code(coder))) then - call code_error(coder,list,& - 'Keyword arguments to communicating call must be shared') - endif - endif - j=pm_set_lookup(coder%context,keys,node_arg(list,i)) - if(j>0) then - coder%vstack(start+j)=pop_code(coder) - else - call code_error(coder,list,& - 'Unexpected keyword argument: ',& - node_arg(list,i)) - call drop_code(coder) - endif - enddo - - ! Process keys... in call - if(node_sym(list)==sym_dotdotdot) then - if(.not.pm_fast_isnull(coder%proc_keys)) then - call pm_set_merge(coder%context,coder%proc_keys,keys) - keynames=pm_set_keys(coder%context,keys) - do i=1,nkeys - if(pm_fast_isnull(coder%vstack(start+i))) then - j=pm_set_lookup(coder%context,coder%proc_keys,& - keynames%data%ptr(keynames%offset+i-1)) - if(j>0) then - call make_temp_var(coder,cblock,list) - coder%vstack(start+i)=top_code(coder) - call make_int_const(coder,cblock,& - list,j) - call make_int_const(coder,cblock,& - list,coder%proc_nret) - call make_sp_call(coder,cblock,& - list,sym_key,2,1) - endif - endif - enddo - endif - endif - endif - endif - if(nkeys>0) then - empty=coder%undef_val - do i=1,nkeys - if(pm_fast_isnull(coder%vstack(start+i))) then - coder%vstack(start+i)=empty - endif - enddo - endif - contains - include 'fisnull.inc' include 'ftiny.inc' - end function trav_keys + subroutine process_amp_args(node,amp) + type(pm_ptr),intent(in):: node + type(pm_ptr),intent(in):: amp + integer:: i,j,jj,k,sym,first_amp + type(pm_ptr):: arg,arg2 + logical:: aliased(nargs),xaliased(nargs,nargs),is_amp(nargs),alias,any_aliased + character(len=*),parameter:: emess='An "&" argument aliases another argument' + + j=0 + any_aliased=.false. + aliased=.false. + first_amp=amp%data%i(amp%offset) + do i=1,nargs + arg=node_arg(node,i) + is_amp(i)=amp%data%i(amp%offset+j)==i + if(is_amp(i)) then + xaliased(:,i)=.false. + do k=1,i-1 + arg2=node_arg(list,k) + sym=node_sym(arg2) + if(sym==sym_name.or.sym==sym_reference) then + if(check_aliased(coder,arg,arg2,emess)) then + aliased(i)=.true. + aliased(k)=.true. + xaliased(k,i)=.true. + endif + endif + enddo + j=min(j+1,pm_fast_esize(amp)) + else + sym=node_sym(arg) + if(sym==sym_reference.or.sym==sym_name) then + do k=first_amp,i-1 + if(is_amp(k)) then + if(check_aliased(coder,arg,arg2,emess)) then + aliased(i)=.true. + aliased(k)=.true. + xaliased(i,k)=.true. + endif + endif + enddo + endif + endif + enddo + + if(any_aliased) then + do i=1,nargs + arg=node_arg(node,i) + if(aliased(i)) then + call trav_reference(coder,cblock,node,arg,is_amp(i),.true.,.true.) + elseif(is_amp(i)) then + call trav_reference(coder,cblock,node,arg,.true.,.true.,.false.) + call code_null(coder) + else + call trav_expr(coder,cblock,node,arg) + call code_null(coder) + endif + enddo + do i=1,nargs + if(is_amp(i).and.aliased(i)) then + do j=1,nargs + if(i/=j.and..not.(is_amp(j).and.j>i)) then + if(xaliased(k,j)) then + call code_val(coder,coder%vstack(base+i*2-1)) + call code_val(coder,coder%vstack(base+j*2-1)) + call make_sys_call(coder,cblock,node_arg(node,i),& + sym_check_alias,2,0) + endif + endif + enddo + endif + enddo + do i=1,nargs + coder%vstack(base+i)=coder%vstack(base+2*i) + enddo + coder%vtop=coder%vtop-nargs + else + do i=1,nargs + arg=node_arg(node,i) + if(is_amp(i)) then + call trav_reference(coder,cblock,node,arg,.true.,.true.,.false.) + else + call trav_expr(coder,cblock,node,arg) + endif + enddo + endif + end subroutine process_amp_args + + end subroutine trav_call + + !================================================= + ! Make an alias check - PM__alias_check(p1,p2) + !================================================= + subroutine make_alias_check(coder,cblock,node,p1,p2) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + type(pm_ptr),intent(in):: p1,p2 + call dup_expr(coder,p1) + call dup_expr(coder,p2) + call make_sys_call(coder,cblock,node,sym_check_alias,2,0) + end subroutine make_alias_check + !=============================================================== ! Traverse procedure definition !=============================================================== - recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& - amplocs,nret,procs,numprocs,lclbase) + recursive subroutine trav_proc(coder,node) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: callnode,node,amplocs,keyargs,procs - integer,intent(in):: nargs,nret,numprocs,lclbase + type(pm_ptr),intent(in):: node - type(pm_ptr):: cblock,cblock2,cblock3,cblock4 - type(pm_ptr):: p,par,amp,rtypes,arg,rv,tkeys - integer:: i,j,n,base,obase,wbase,npars,cbase,nkeyargs - integer:: flags,sym,loop_pars,reduce_base,reduce_start,rsig - integer:: partyp - integer:: save_index,t - integer:: save_proc_base,& - save_par_base, save_over_base,save_proc_par_depth,& - save_proc_nret,save_par_state,save_proc_ncalls,& - save_subs_index,save_run_mode,save_run_flags - type(pm_ptr):: save_sub_array,save_loop_cblock, & - save_proc_keys,save_label - logical:: save_aliased,save_in_sync + integer:: nargs,nret + type(pm_ptr):: cblock,cblock2 + type(pm_ptr):: p,amp,keycall,argcall + type(pm_ptr),target:: tkeys + integer:: i,j,base,obase,wbase,npars,cbase + integer:: flags,sym,rsig + integer:: save_index,save_proc_base,save_proc_ncalls,& + save_lex_scope,save_par_state,& + save_state_base,save_mask,save_param_base integer:: pr_flags type(pm_reg),pointer:: reg - logical:: complete,old_complete integer,save:: pdepth=0 - + + nargs=node_numargs(node_get(node,proc_params))/2 + nret=node_get_num(node,proc_numret) + flags=node_get_num(node,proc_flags) + if(debug_codegen) then write(*,*) repeat(' ',pdepth),'TRAV PROC>',& trim(pm_name_as_string(coder%context,& @@ -6254,19 +4989,20 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& pdepth=pdepth+1 endif - if(pm_fast_isnull(keyargs)) then - nkeyargs=0 - else - nkeyargs=pm_set_size(coder%context,keyargs) - endif - + !nkeyargs=0 + ! Parameter types wbase=coder%wtop obase=coder%vtop - partyp=proc_param_type(coder,node) - call code_num(coder,int(partyp)) - if(coder%wtop/=wbase) call pm_panic('par type wstack mismatch') + call code_num(coder,proc_param_type(coder,node)) + call code_num(coder,proc_result_type(coder,node)) + call code_num(coder,nargs) + call code_num(coder,nret) + call code_num(coder,flags) + call code_val(coder,node_get(node,proc_amplocs)) + call code_val(coder,node_get(node,proc_name)) + sym=node_sym(node) if(sym==sym_builtin) then @@ -6280,59 +5016,10 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& cbase=coder%vtop call code_val(coder,node_get(node,proc_opcode)) call code_val(coder,node_get(node,proc_opcode2)) - call code_val(coder,node_get(node,proc_data)) - call code_val(coder,node_get(node,proc_flags)) - call code_num(coder,proc_result_type(coder,node)) - if(nret>0) then - p=node_get(node,proc_retas) - if(pm_fast_istiny(p)) then - call code_val(coder,p) - call code_num(coder,0) - elseif(pm_fast_isnull(p)) then - p=node_get(node,proc_result_types) - if(node_sym(p)==sym_dash) then - call code_null(coder) - call code_num(coder,sym_dash) - else - call code_null(coder) - call code_num(coder,0) - endif - else - call save_proc_state - call init_proc_state - cblock=make_cblock(coder,pm_null_obj,node,sym_present) - npars=0 - call code_params(cblock,.false.) - sym=node_sym(p) - p=node_arg(p,1) - base=coder%vtop - call trav_xexpr(coder,cblock,node,p) - call make_sp_call(coder,cblock,node,& - sym_result,coder%vtop-base,0) - coder%vtop=base - call close_cblock(coder,cblock) - call code_num(coder,sym) - call restore_proc_state - endif - else - call code_null(coder) - call code_num(coder,0) - endif - endif - coder%id=coder%id+1 - call code_num(coder,coder%id) - if(pm_debug_checks) then - if(coder%vtop-cbase/=bi_node_size) then - write(*,*) '===========',coder%vtop,cbase,cbase+bi_node_size - do i=cbase+1,coder%vtop - call qdump_code_tree(coder,pm_null_obj,6,& - coder%vstack(i),2) - write(*,*) '====' - enddo - call pm_panic('making bi') - endif - endif - call make_code(coder,node,cnode_is_builtin,bi_node_size) + coder%id=coder%id+1 + call code_num(coder,coder%id) + call make_code(coder,node,cnode_is_builtin,bi_node_size) + end if else ! User-defined procedure @@ -6344,110 +5031,75 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& return endif - write(70,*) trim(pm_name_as_string(coder%context,& - node_get_num(node,proc_name))),'par',coder%par_state - old_complete=coder%par_statepm_register(coder%context,'tproc',tkeys) - + ! Different types of procedure npars=0 flags=node_get_num(node,proc_flags) pr_flags=flags - if(iand(flags,proc_is_each_proc)==0) then - if(iand(flags,proc_is_comm+proc_run_shared+proc_run_local)==& - proc_is_comm) then - loop_pars=coder%top - if(iand(flags,proc_run_complete)/=0) then - complete=.true. - call check_param_modes(sym_complete,sym_complete) - elseif(iand(flags,proc_is_uncond)/=0) then - complete=.true. - elseif(iand(flags,proc_is_cond)/=0) then - complete=.false. - else - complete=old_complete - endif - call code_params(cblock,.true.) - call code_keys(cblock,tkeys) - call code_loop_startup(cblock,cblock2,cblock3) - call code_check(cblock3) - call code_body(cblock3) - call code_result(cblock3,flags) - call code_loop_finish(cblock,cblock2,cblock3) - else - if(iand(flags,proc_run_shared+proc_run_local)/=0) then - loop_pars=coder%top - call check_param_modes(sym_mirrored,sym_shared) - call code_params(cblock,.true.) - call export_params - else - call code_params(cblock,.false.) - endif - call code_keys(cblock,tkeys) - call code_check(cblock) - call code_body(cblock) - call code_result(cblock,flags) - endif + if(iand(flags,proc_run_shared+proc_run_local+proc_run_complete)/=0) then + call code_params(cblock,.true.,argcall) + call code_keys(cblock,tkeys,keycall,.true.,.true.) + call export_params(cblock) + call code_special_check_body_and_result(cblock) + elseif(iand(flags,proccall_is_comm)/=0) then + coder%par_state=merge(par_state_comm_proc,par_state_none,& + iand(flags,proc_is_uncond)==0) + call code_params(cblock,.true.,argcall) + call code_keys(cblock,tkeys,keycall,.true.,.false.) + call code_loop_check_body_and_result(cblock) else - pr_flags=ior(pr_flags,proc_is_each_proc) - call code_proc_each - endif - call close_cblock(coder,cblock) - - if(pm_debug_checks) then - if(coder%vtop/=obase+2) then - write(*,*) coder%vtop,obase+2 - do i=obase+3,coder%vtop - write(*,*) '===================' - call qdump_code_tree(coder,pm_null_obj,6,& - coder%vstack(i),2) - write(*,*) '===================' - enddo - write(*,*) sym_names(sym) - call pm_panic( 'Proc cnode mismatch' ) - endif - if(coder%wtop/=wbase) then - write(*,*) coder%wtop,wbase - call pm_panic('proc wstack mismatch') - endif + coder%par_state=par_state_none + call code_params(cblock,.false.,argcall) + call code_keys(cblock,tkeys,keycall,.false.,.false.) + call code_check(cblock) + call code_body(cblock) + call pass_back_amps(cblock) + call code_result(cblock,flags) endif - write(70,*) trim(pm_name_as_string(coder%context,& - node_get_num(node,proc_name))),pr_flags,complete,old_complete,coder%par_state - + call close_cblock(coder,cblock) ! Create proc code object call code_num(coder,coder%index) ! Maximum index call code_num(coder,0) ! Recursion flag coder%id=coder%id+1 call code_num(coder,coder%id) ! Procedure id. index - call code_num(coder,proc_result_type(coder,node)) ! Return type - call code_num(coder,npars) ! Number of parameters - call code_num(coder,0) ! Number of keywords - ! (fixed later) - call code_num(coder,nret) ! Number of returns - call code_num(coder,pr_flags) ! Flags - call code_num(coder,node_get_num(node,proc_name)) ! Name call code_num(coder,coder%proc_ncalls) ! Number of calls call code_val(coder,tkeys) ! Keyword arg info + call code_val(coder,keycall) ! Keyword call + call code_val(coder,argcall) ! Arguments call + if(.not.pm_fast_isnull(node_get(node,proc_when))) then + cblock2=make_cblock(coder,cblock,node,sym_when) + call trav_xexpr(coder,cblock2,node,node_get(node,proc_when)) + call close_cblock(coder,cblock2) + else + call code_null(coder) + call code_null(coder) + endif call make_code(coder,node,cnode_is_proc,pr_node_size) - - call pm_delete_register(coder%context,reg) - - call pop_par_scope(coder,cblock,node) + call pm_delete_register(coder%context,reg) + call restore_proc_state endif + if(pm_debug_checks) then + if(coder%vtop/=obase+1) then + call pm_panic('trav_proc: vstack') + endif + if(coder%wtop/=wbase) then + call pm_panic('trav_proc: vstack') + endif + endif + if(debug_codegen) then pdepth=pdepth-1 write(*,*) repeat(' ',pdepth),'END TRAV PROC>',& @@ -6455,7 +5107,7 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& node_get_num(node,proc_name))),coder%wtop,coder%top !call dump_parse_tree(coder%context,6,node,2) endif - + contains include 'fisnull.inc' include 'fistiny.inc' @@ -6467,216 +5119,182 @@ recursive subroutine trav_proc(coder,callnode,node,nargs,keyargs,& include 'fvkind.inc' subroutine save_proc_state - save_index=coder%index - save_proc_base=coder%proc_base - save_proc_ncalls=coder%proc_ncalls - save_par_base=coder%par_base - save_over_base=coder%over_base - save_loop_cblock=coder%loop_cblock - save_proc_keys=coder%proc_keys - save_proc_par_depth=coder%proc_par_depth - save_proc_nret=coder%proc_nret - save_par_state=coder%par_state - save_label=coder%label - save_subs_index=coder%subs_index - save_run_mode=coder%run_mode - save_run_flags=coder%run_flags - save_aliased=coder%aliased - save_in_sync=coder%in_sync + save_index=coder%index + save_lex_scope=coder%lex_scope + save_proc_base=coder%proc_base + save_proc_ncalls=coder%proc_ncalls + save_par_state=coder%par_state + save_state_base=coder%state_base + save_mask=coder%mask + save_param_base=coder%param_base end subroutine save_proc_state subroutine init_proc_state - coder%index=0 - coder%proc_base=coder%top - coder%proc_ncalls=0 - coder%par_base=coder%top - coder%over_base=coder%top+2 - coder%proc_keys=keyargs - coder%proc_par_depth=coder%par_depth - coder%proc_nret=nret - coder%par_state=par_state_outer - coder%run_mode=sym_complete - coder%subs_index=-1 - coder%run_flags=0 - coder%aliased=.false. - coder%in_sync=.false. + coder%index=0 + coder%lex_scope=0 + coder%proc_base=coder%top + coder%proc_ncalls=0 end subroutine init_proc_state - subroutine restore_proc_state - coder%index=save_index - coder%proc_base=save_proc_base - coder%proc_ncalls=save_proc_ncalls - coder%par_base=save_par_base - coder%over_base=save_over_base - coder%loop_cblock=save_loop_cblock - coder%proc_keys=save_proc_keys - coder%par_depth=coder%proc_par_depth - coder%proc_par_depth=save_proc_par_depth - coder%proc_nret=save_proc_nret - coder%par_state=save_par_state - coder%run_mode=save_run_mode - coder%run_flags=save_run_flags - coder%label=save_label - coder%subs_index=save_subs_index - coder%aliased=save_aliased - coder%in_sync=save_in_sync + subroutine restore_proc_state + coder%index=save_index + coder%lex_scope=save_lex_scope + coder%proc_base=save_proc_base + coder%proc_ncalls=save_proc_ncalls + coder%par_state=save_par_state + coder%state_base=save_state_base + coder%mask=save_mask + coder%param_base=save_param_base end subroutine restore_proc_state - subroutine code_params(cblock,iscomm) + subroutine code_params(cblock,iscomm,argcall) type(pm_ptr),intent(in):: cblock logical,intent(in):: iscomm - type(pm_ptr):: name,var,p - integer:: state,flags,cflags + type(pm_ptr),intent(out):: argcall + type(pm_ptr):: p + integer:: name,flags,flags0 + if(iscomm) then + coder%state_base=coder%top + coder%mask=coder%state_base+num_comm_args + endif + coder%param_base=coder%top p=node_get(node,proc_params) + flags0=merge(var_is_maybe_not_private,0,iscomm) if(.not.pm_fast_isnull(p)) then amp=node_get(node,proc_amplocs) if(pm_fast_isnull(amp)) then do i=1,node_numargs(p),2 - flags=var_is_param - name=node_arg(p,i) - if(name%offset==sym_arg) flags=var_is_varg - if(iscomm.and.i>3) then - cflags=coder%wstack(lclbase+(i+1)/2) - call make_var(coder,cblock,p,name,flags) - if(iand(cflags,var_is_imported)==0) then - call var_set_par_depth(coder,top_code(coder),coder%par_depth+1) - endif - else - call make_var(coder,cblock,p,name,flags) - endif + flags=flags0+var_is_param + name=node_num_arg(p,i) + if(name==sym_dotdotdot) flags=var_is_varg + call make_var(coder,cblock,p,name,flags) enddo else j=0 amp=pm_name_val(coder%context,int(amp%offset)) do i=1,node_numargs(p),2 if(amp%data%i(amp%offset+j)==(i+1)/2) then - flags=var_is_ref+var_is_param+var_is_var + flags=flags0+var_is_ref+var_is_param+var_is_var if(node_sym(node_arg(p,i+1))/=sym_pm_dref) then flags=ior(flags,var_is_ref) endif if(j3) then - cflags=coder%wstack(lclbase+(i+1)/2) - call make_var(coder,cblock,p,name,flags) - if(iand(cflags,var_is_imported)==0) then - call var_set_par_depth(coder,top_code(coder),coder%par_depth+1) - endif - else - call make_var(coder,cblock,p,name,flags) + flags=flags0+var_is_param endif + name=node_num_arg(p,i) + if(name==sym_dotdotdot) flags=var_is_varg + call make_var(coder,cblock,p,name,flags) enddo endif npars=npars+node_numargs(p)/2 call make_basic_sp_call(coder,cblock,p,& - sym_open,npars,0,coder%par_depth) + sym_open,npars,0) + argcall=cnode_get(cnode_get(cblock,cblock_last_call),call_args) + else + argcall=pm_null_obj endif end subroutine code_params + + recursive subroutine code_keys(cblock,tkeys,key_call,iscomm,isshrd) + type(pm_ptr),intent(in):: cblock + type(pm_ptr),intent(inout):: key_call + type(pm_ptr),intent(inout),target:: tkeys + logical,intent(in):: iscomm,isshrd + type(pm_ptr):: p,typ,cblock2 + integer:: i,n,base,newbase,vname,vbase,wbase,tno,flags0 - subroutine export_params - integer:: i,flags - type(pm_ptr):: var - p=node_get(node,proc_params) - do i=2,npars - var=coder%var(loop_pars+i) - flags=coder%wstack(lclbase+i) - if(iand(flags,var_is_imported)==0) then - call make_var(coder,cblock,p,cnode_get(var,var_name),& - ior(iand(cnode_get_num(var,var_flags),& - var_is_var+var_is_ref),var_is_shadowed)) - call code_val(coder,var) - call make_basic_sp_call(coder,cblock,p,sym_export_param,& - 1,1,coder%par_depth) + flags0=merge(var_is_maybe_not_private,0,iscomm) + + p=node_get(node,proc_keys) + if(pm_fast_isnull(p)) then + tkeys=pm_null_obj + key_call=pm_null_obj + if(.not.(iscomm.or.isshrd)) then + call make_state_vars(coder,cblock,node,& + topo=coder%var(coder%proc_base+1)) endif + return + endif + n=node_numargs(p)/3 + vbase=coder%vtop + base=coder%top + + ! Create actual keyword parameter variables + wbase=coder%wtop + do i=1,node_numargs(p),3 + vname=node_num_arg(p,i) + call push_word(coder,vname) + call make_var(coder,cblock,p,vname,& + flags0+var_is_param+var_is_key+var_is_multi_access) enddo - end subroutine export_params - subroutine check_param_modes(mode,flag_sym) - integer,intent(in):: mode,flag_sym - type(pm_ptr):: p,arg - integer:: i - p=node_get(node,proc_params) - do i=num_comm_args*2+2,node_numargs(p),2 - arg=node_arg(p,i) - if(node_sym(arg)/=sym_mode) then - call code_error(coder,node,& - 'All parameters for "<<'//trim(sym_names(flag_sym))//& - '>>" procedure must have an explicit mode') + ! Export parameters for a gbl proc + if(isshrd) then + newbase=coder%top + do i=1,node_numargs(p)/3 + call make_var(coder,cblock,p,vname,& + flags0+var_is_param+var_is_key+var_is_multi_access+var_is_shadowed) + call code_val(coder,coder%var(base+i)) + call make_sys_call(coder,cblock,node,sym_export_param,1,1) + enddo + base=newbase + endif + + ! Create a vector of all key names followed by all key types + ! and finally by largest index associated with keys + do i=1,node_numargs(p),3 + typ=node_arg(p,i+1) + if(pm_fast_isnull(typ)) then + call push_word(coder,-1) else - if(.not.pm_mode_compatable(mode,node_num_arg(arg,2))) then - call code_error(coder,arg,& - 'Parameter for "<<'//trim(sym_names(flag_sym))//& - '>>" procedure cannot have this mode: ',node_arg(arg,2)) - endif + call trav_type(coder,p,typ) endif enddo - p=node_get(node,proc_result_types) - do i=1,node_numargs(p) - arg=node_arg(p,i) - if(node_sym(arg)==sym_mode) then - call code_error(coder,node,& - 'Return modes for a "<<'//trim(sym_names(flag_sym))//& - '>>" procedure must be undefined or "'//& - trim(sym_names(mode))) - endif + tkeys=pm_fast_newnc(coder%context,pm_int,coder%wtop-wbase+1) + tkeys%data%i(tkeys%offset:tkeys%offset+coder%wtop-wbase-1)=& + coder%wstack(wbase+1:coder%wtop) + coder%wtop=wbase + + ! Create visible keyword parameters + do i=1,node_numargs(p),3 + vname=node_num_arg(p,i) + call make_var(coder,cblock,p,vname,& + flags0+var_is_key+var_is_multi_access+var_is_shadowed,& + extra_info=coder%var(base+(i+2)/3)) enddo - end subroutine check_param_modes - - recursive subroutine code_keys(cblock,tkeys) - type(pm_ptr),intent(in):: cblock - type(pm_ptr),intent(inout):: tkeys - type(pm_ptr):: vname,arg - integer:: tbase,vb,base - ! Keyword arguments - p=node_get(node,proc_keys) - if(.not.pm_fast_isnull(p)) then - base=coder%vtop - tbase=coder%wtop - do i=1,node_numargs(p),3 - vname=node_arg(p,i) - call make_var(coder,cblock,p,vname,& - var_is_key+var_is_multi_access) - vb=coder%top - call hide_vars(coder,coder%top,vb) ! Stop recursive use of tag name - call make_sys_var(coder,cblock,p,& - pm_name2(coder%context,sym_present,& - int(vname%offset)),var_is_multi_access) - j=pm_set_lookup(coder%context,keyargs,node_arg(p,i)) - if(pm_debug_checks) then - if(j<0) call pm_panic('lookup key arg') - endif - ! key= sym_present(nret,j,default, [type]) - call make_int_const(coder,cblock,p,nret) - call make_int_const(coder,cblock,p,j) - call trav_expr(coder,cblock,p,node_arg(p,i+2)) - call reveal_vars(coder,vb,vb) - if(.not.pm_fast_isnull(node_arg(p,i+1))) then - call push_word(coder,(i+2)/3) - arg=node_arg(p,i+1) - call trav_type(coder,arg,arg) - call make_int_const(coder,cblock,p,top_word(coder)) - call make_sp_call(coder,cblock,p,& - sym_present,4,2) - else - call make_sp_call(coder,cblock,p,& - sym_present,3,2) - endif - enddo - ! Create tkeys (defined in parent subroutine) with vector of type constraints - if(coder%wtop>tbase) then - tkeys=pm_fast_newnc(coder%context,pm_int,coder%wtop-tbase) - tkeys%data%i(tkeys%offset:tkeys%offset+coder%wtop-tbase-1)=& - coder%wstack(tbase+1:coder%wtop) - coder%wtop=tbase - endif - if(pm_debug_checks) then - if(base/=coder%vtop) call pm_panic('trav_proc key mismatch') - endif + + call hide_vars(coder,base+1,coder%top) + + if(.not.(iscomm.or.isshrd)) then + call make_state_vars(coder,cblock,node,& + topo=coder%var(coder%proc_base+1)) endif + + ! Create blocks to compute default values + do i=1,node_numargs(p),3 + cblock2=make_cblock(coder,cblock,node,sym_key) + call trav_expr(coder,cblock2,p,node_arg(p,i+2)) + tno=tkeys%data%i(tkeys%offset+n+i/3) + ! For stated type constraints, convert default value to + ! that type + if(tno>=0) then + call make_const(coder,cblock2,node,& + pm_fast_tinyint(coder%context,tno)) + call make_sp_call_rtn(coder,cblock2,node,sym_type_val,1,1) + call make_sp_call_rtn(coder,cblock2,node,sym_cast,2,1) + endif + call close_cblock(coder,cblock2) + call reveal_vars(coder,base+n+(i+2)/3,base+n+(i+2)/3) + enddo + + ! Create call: key keyarg... keyvar... (block defvar)... + call make_sp_call(coder,cblock,node,sym_key,n*2,n*2) + key_call=cnode_get(cnode_get(cblock,cblock_last_call),call_args) + + ! Last index used by default expressions + tkeys%data%i(tkeys%offset+pm_fast_esize(tkeys))=coder%index + end subroutine code_keys recursive subroutine code_check(cblock) @@ -6692,18 +5310,18 @@ end subroutine code_check recursive subroutine code_body(cblock) type(pm_ptr),intent(in):: cblock ! Body of statements - p=node_get(node,proc_stmts) - if(.not.pm_fast_isnull(p)) then - call trav_open_stmt_list(coder,cblock,node,p) - endif + p=node_get(node,proc_stmts) + if(.not.pm_fast_isnull(p)) then + call trav_open_stmt_list(coder,cblock,node,p) + endif end subroutine code_body recursive subroutine code_result(cblock,flags) type(pm_ptr),intent(in):: cblock integer,intent(in):: flags - type(pm_ptr):: p,q - integer:: status,i,j - + type(pm_ptr):: p + integer:: i + ! Result expression p=node_get(node,proc_result) if(.not.pm_fast_isnull(p)) then @@ -6714,8 +5332,7 @@ recursive subroutine code_result(cblock,flags) call make_temp_var(coder,cblock,node) call dup_code(coder) call code_val(coder,coder%vstack(i)) - call make_basic_sp_call(coder,cblock,node,sym_import_param,1,1,& - coder%par_depth) + call make_comm_sys_call(coder,cblock,node,sym_import_param,1,1) coder%vstack(i)=pop_code(coder) enddo end if @@ -6723,233 +5340,173 @@ recursive subroutine code_result(cblock,flags) sym_result,nret,0) rsig=pop_word(coder) if(pm_debug_checks) then - if(coder%vtop/=base) then - write(*,*) '***************',nret - do i=base+1,coder%vtop - call qdump_code_tree(coder,pm_null_obj,6,& - coder%vstack(i),2) - enddo - write(*,*) coder%vtop,base - write(*,*) '%%%%%%%%%%%%' - call dump_parse_tree(coder%context,6,p,2) - call pm_panic('rtn mismatch') - endif - endif - else - rsig=0 - endif - end subroutine code_result - - ! This sets up a par-loop structure for comm proc - subroutine code_loop_startup(cblock,cblock2,cblock3) - type(pm_ptr),intent(in):: cblock - type(pm_ptr),intent(out):: cblock2,cblock3 - integer:: iter - - - !coder%over_base=coder%top - call make_var_tab_entry(coder,sym_for,& - coder%var(loop_pars+1)) - - - call make_sys_var(coder,cblock,node,sym_in,0) - - iter=coder%top - coder%par_base=iter - call make_sys_var(coder,cblock,node,sym_pling,var_is_shadowed) - call code_val(coder,coder%var(iter+lv_distr)) - call make_sys_call(coder,cblock,node,sym_get_tile_sz,1,2) - call make_sys_var(coder,cblock,node,sym_hash,var_is_shadowed) - call var_set_par_depth(coder,coder%var(iter+lv_numz),coder%par_depth+1) - call drop_code(coder) - cblock2=make_cblock(coder,cblock,node,sym_proc) - coder%loop_cblock=cblock2 - call drop_code(coder) - - ! Alias the region and subregion variables - call make_var_tab_entry(coder,sym_region,coder%var(iter+lv_distr)) - call make_var_tab_entry(coder,sym_subregion,coder%var(loop_pars+2)) - coder%over_base =coder%top - - call push_par_scope(coder,cblock2) - call make_var_tab_entry(coder,sym_here_in_tile,coder%var(loop_pars+3)) - call make_sys_var(coder,cblock2,node,sym_here,var_is_shadowed) - call code_val(coder,coder%var(iter+lv_tile)) - call code_val(coder,coder%var(iter+lv_index)) - call make_sys_call(coder,cblock2,node,sym_get_element,2,1) - -!!$ if(iter+lv_here/=coder%top) then -!!$ write(*,*) '#',iter+lv_here,coder%top -!!$ call pm_panic('iter mismatch in code_loop_startup') -!!$ endif - - coder%par_state=par_state_for - coder%run_mode=sym_complete - - coder%par_state=merge(par_state_for,par_state_masked,complete) - - if(complete) pr_flags=ior(pr_flags,proc_run_complete) - cblock3=make_cblock(coder,cblock2,node,sym_for_stmt) - - if(pm_is_compiling) then - ! Call PM__do_over to set-up subset loops - call make_sys_var(coder,cblock3,node,sym_nested_loop,var_is_shadowed) - call dup_code(coder) - call code_val(coder,coder%var(coder%over_base)) - call code_val(coder,coder%var(iter+lv_distr)) - call make_basic_sys_call(coder,cblock3,node,sym_do_over,2,1,& - coder%par_depth-1,call_inline_when_compiling) - call make_basic_sys_call(coder,cblock3,node,sym_nested_loop,1,0,& - coder%par_depth-1,call_inline_when_compiling) - endif - - end subroutine code_loop_startup - - subroutine code_loop_finish(cblock,cblock2,cblock3) - type(pm_ptr),intent(in):: cblock,cblock2,cblock3 - call close_cblock(coder,cblock3) - call make_sp_call(coder,cblock2,node,sym_for,1,0) - call close_cblock(coder,cblock2) - call pop_par_scope(coder,cblock,node) - call code_val(coder,coder%var(coder%par_base+lv_numz)) - call code_val(coder,cblock2) - call code_val(coder,coder%var(coder%par_base+lv_num)) - call make_sp_call(coder,cblock,node,sym_pct,2,1) - end subroutine code_loop_finish - - recursive subroutine code_proc_each - integer:: cflags - type(pm_ptr):: cblock5,cblock6,arg1 - integer:: slot1 - loop_pars=coder%top - call code_params(cblock,iand(flags,proc_is_comm)/=0) - call code_keys(cblock,tkeys) - base=coder%vtop - do i=1,nret - call make_temp_var(coder,cblock,node) - enddo - cblock3=make_cblock(coder,cblock,node,sym_each) - if(nret>0) then - do i=1,nret - call code_val(coder,coder%vstack(base+i)) - enddo - call make_sp_call(coder,cblock3,node,sym_result,nret,0) - endif - call close_cblock(coder,cblock3) - cblock2=make_cblock(coder,cblock,node,sym_each) - slot1=coder%index+1 - if(iand(flags,proc_is_comm)==0) then - if(debug_codegen) then - write(*,*) 'TRAV EACH PROC>',& - trim(pm_name_as_string(coder%context,& - node_get_num(node,proc_name))),coder%wtop,coder%proc_base - endif - call code_body(cblock2) - call code_result(cblock2,flags) - ! Flag special cases: f(x) each(x)=x; f(x) each(x) {}; PM__dup() - pr_flags=proc_is_each_proc - if(npars==1.and.nret==1) then - if(pm_fast_isnull(node_get(node,proc_stmts))) then - arg1=node_arg(node_get(node,proc_params),1) - if(arg1%offset==sym_dup) then - pr_flags=pr_flags+proc_is_dup_each - elseif(arg1==node_arg(node_get(node,proc_result),1)) then - pr_flags=pr_flags+proc_is_thru_each - endif - endif - elseif(nret==0) then - if(node_numargs(node_get(node,proc_stmts))==0) then - pr_flags=pr_flags+proc_is_empty_each + if(coder%vtop/=base) then + write(*,*) '***************',nret + do i=base+1,coder%vtop + call qdump_code_tree(coder,pm_null_obj,6,& + coder%vstack(i),2) + enddo + write(*,*) coder%vtop,base + write(*,*) '%%%%%%%%%%%%' + call dump_parse_tree(coder%context,6,p,2) + call pm_panic('rtn mismatch') endif endif else - call code_loop_startup(cblock2,cblock4,cblock5) - call code_check(cblock5) - call code_body(cblock5) - call code_result(cblock5,flags) - call code_loop_finish(cblock2,cblock4,cblock5) - pr_flags=proc_is_each_proc+proc_is_comm + rsig=0 endif - call close_cblock(coder,cblock2) - cblock4=make_cblock(coder,cblock,node,sym_each) - coder%temp=pm_fast_newnc(coder%context,& - pm_int,2) - rv=coder%temp - call make_const(coder,cblock,node,coder%temp) - rv%data%i(rv%offset)=slot1 - p=node_get(node,proc_reduce) - n=node_numargs(p) - do i=1,n - par=node_arg(p,i) - arg=find_var(coder,node_arg(p,i)) - if(pm_fast_isnull(arg)) then - call code_error(coder,p,& - '"each" variable not in parameter list',par) - elseif(cnode_flags_clear(arg,var_flags,var_is_param)) then - call code_error(coder,p,& - 'repeated "each" variable') - endif - call code_val(coder,arg) - call make_var(coder,cblock,node,node_arg(p,i),var_is_shadowed) - enddo - base=coder%vtop - do i=1,nret - call make_temp_var(coder,cblock,node) - enddo - if(sym/=sym_proc) then - call code_loop_startup(cblock4,cblock5,cblock6) + end subroutine code_result + + subroutine code_special_check_body_and_result(cblock) + type(pm_ptr),intent(in):: cblock + type(pm_ptr):: cblock2 + integer:: sym + if(iand(flags,proc_run_shared+proc_run_local)/=0) then + sym=merge(sym_pm_shared_always,sym_pm_shared,iand(flags,proc_run_always)/=0) else - cblock6=cblock4 + sym=merge(sym_pm_chan_always,sym_pm_chan,iand(flags,proc_run_always)/=0) endif - do i=1,nret - call code_val(coder,coder%vstack(base+i)) + call code_val(coder,coder%var(coder%mask)) + cblock2=make_cblock(coder,cblock,node,sym) + call code_check(cblock2) + coder%par_state=par_state_none + call code_body(cblock2) + call import_params(cblock2) + call pass_back_amps(cblock2) + call code_result(cblock2,flags) + call close_cblock(coder,cblock2) + call make_sp_call(coder,cblock,node,sym,2,0) + end subroutine code_special_check_body_and_result + + subroutine export_params(cblock) + type(pm_ptr),intent(in):: cblock + integer:: i + type(pm_ptr):: var,p + p=node_get(node,proc_params) + call hide_vars(coder,coder%state_base+1,coder%state_base+num_comm_args) + do i=num_comm_args+1,npars + var=coder%var(coder%state_base+i) + call make_var(coder,cblock,p,cnode_get_num(var,var_name),& + ior(iand(cnode_get_num(var,var_flags),& + var_is_var+var_is_ref),var_is_shadowed)) + call code_val(coder,var) + call make_comm_sys_call(coder,cblock,p,sym_export_param,& + 1,1) enddo - if(nkeyargs>0) then - do i=1,nkeyargs - call make_temp_var(coder,cblock6,node) - call dup_code(coder) - call make_int_const(coder,cblock6,& - node,i+nret) - call make_sp_call(coder,cblock6,& - node,sym_key,1,1) + end subroutine export_params + + subroutine import_params(cblock) + type(pm_ptr),intent(in):: cblock + integer:: i,j + type(pm_ptr):: amp,p + p=node_get(node,proc_params) + amp=node_get(node,proc_amplocs) + if(.not.pm_fast_isnull(amp)) then + amp=pm_name_val(coder%context,int(amp%offset)) + do j=0,pm_fast_esize(amp) + i=amp%data%i(amp%offset+j) + call code_val(coder,coder%var(coder%state_base+i)) + call code_val(coder,coder%var(coder%state_base+npars-num_comm_args+i)) + call make_comm_sys_call(coder,cblock,p,sym_import_param,2,0,assign=.true.) enddo endif + end subroutine import_params + + subroutine pass_back_amps(cblock) + type(pm_ptr),intent(in):: cblock + integer:: i,j + type(pm_ptr):: amp,p p=node_get(node,proc_params) - do i=1,node_numargs(p),2 - call code_val(coder,find_var(coder,node_arg(p,i))) - enddo - if(sym==sym_pct) then - cflags=call_is_comm - else - cflags=0 - endif - call make_full_call(coder,cblock6,node,procs,amplocs,npars,& - nret,nkeyargs,cflags,pm_null_obj,coder%par_depth) - if(sym/=sym_proc) then - call code_loop_finish(cblock4,cblock5,cblock6) + amp=node_get(node,proc_amplocs) + if(.not.pm_fast_isnull(amp)) then + amp=pm_name_val(coder%context,int(amp%offset)) + do j=0,pm_fast_esize(amp) + i=amp%data%i(amp%offset+j) + call code_val(coder,coder%var(coder%param_base+i)) + enddo + call make_sp_call(coder,cblock,node,sym_amp,int(pm_fast_esize(amp))+1,0) endif - call close_cblock(coder,cblock4) - rv%data%i(rv%offset+1)=coder%index - call make_sp_call(coder,cblock,node,sym_each_proc,4+nret+n*2,nret) - end subroutine code_proc_each + end subroutine pass_back_amps + + subroutine code_loop_check_body_and_result(cblock) + type(pm_ptr),intent(in):: cblock + type(pm_ptr):: cblock2 + call code_val(coder,coder%var(coder%state_base+4)) + cblock2=make_cblock(coder,cblock,node,sym_pct) + call code_check(cblock2) + call code_body(cblock2) + call pass_back_amps(cblock2) + call code_result(cblock2,flags) + call close_cblock(coder,cblock2) + call make_sp_call(coder,cblock,node,sym_pct,2,0) + end subroutine code_loop_check_body_and_result end subroutine trav_proc + !======================================================== + ! Traverse a procedure parameter list + ! !!! stuff to say + !======================================================== + subroutine trav_params(coder,cblock,paramlist,amps,step,pre_args) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,paramlist + integer,intent(in):: amps,step,pre_args + + integer:: i,j,k,flags,flags0,nargs,name + type(pm_ptr):: amp + flags0=var_is_param+var_is_maybe_not_private + nargs=node_numargs(paramlist) + if(amps==0) then + do i=1,nargs,step + flags=flags0 + name=node_num_arg(paramlist,i) + if(name==sym_dotdotdot) flags=flags0+var_is_varg + call make_sys_var(coder,cblock,paramlist,name,flags) + enddo + else + j=0 + k=0 + amp=pm_name_val(coder%context,amps) + do i=1,nargs,step + k=k+1 + if(amp%data%i(amp%offset+j)==k) then + flags=var_is_ref+var_is_param+var_is_var + if(j0) return - + if(node_sym(node)==sym_proc) then + when=merge(0,pm_type_is_when,pm_fast_isnull(node_get(node,proc_when))) + else + when=0 + endif p=node_get(node,proc_params) - call push_word(coder,merge(pm_typ_is_vtuple,pm_typ_is_tuple,& - node_sym(p)==sym_dotdotdot)) + call push_word(coder,merge(pm_type_is_vtuple,pm_type_is_tuple,& + node_sym(p)==sym_dotdotdot)+when) amp=node_get(node,proc_amplocs) if(pm_fast_isnull(amp)) then call push_word(coder,0) @@ -7072,7 +5627,6 @@ function proc_param_type(coder,node) result(tno) call make_type(coder,n/2+2) tno=pop_word(coder) - call node_set_num(node,proc_coded_params,tno) contains include 'fisnull.inc' end function proc_param_type @@ -7086,8 +5640,7 @@ function proc_result_type(coder,node) result(tno) integer:: tno integer:: nret,i type(pm_ptr):: p,arg - tno=node_get_num(node,proc_coded_results) - if(tno>0) return + p=node_get(node,proc_result_types) if(node_sym(node)==sym_builtin.and.node_sym(p)==sym_dash) then p=node_arg(p,1) @@ -7095,10 +5648,10 @@ function proc_result_type(coder,node) result(tno) if(pm_fast_isnull(p)) then nret=node_get_num(node,proc_numret) if(nret==0) then - call push_word(coder,pm_typ_is_tuple) + call push_word(coder,pm_type_is_tuple) call push_word(coder,0) else - call push_word(coder,pm_typ_is_undef_result) + call push_word(coder,pm_type_is_undef_result) call push_word(coder,nret) endif call make_type(coder,2) @@ -7106,7 +5659,7 @@ function proc_result_type(coder,node) result(tno) if(node_sym(p)==sym_dash) then p=node_arg(p,1) endif - call push_word(coder,pm_typ_is_tuple) + call push_word(coder,pm_type_is_tuple) call push_word(coder,0) nret=node_numargs(p) do i=1,nret @@ -7116,420 +5669,74 @@ function proc_result_type(coder,node) result(tno) call make_type(coder,nret+2) endif tno=pop_word(coder) - call node_set_num(node,proc_coded_results,tno) contains include 'fisnull.inc' end function proc_result_type - - !======================================================== - ! Find of construct procedure signature - !======================================================== - recursive function find_sig(coder,node,pname,amplocs,& - nargs,nret,flags,sigvect,iscomm,noerr,procroot) result(sig) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: node,pname,amplocs - integer,intent(in):: nargs,nret,flags - type(pm_ptr),intent(out):: sigvect - logical,intent(in):: iscomm - logical,optional,intent(in):: noerr - type(pm_ptr),optional,intent(in):: procroot - type(pm_ptr):: sig,name,modl,xproc,arg - type(pm_ptr):: cblock,keys, procdef,proc,amplocs2,keyargs, cproc - integer:: nret2,nargs2,base,i,j,n,oldwtop,numprocs,lclbase - integer:: k,oldk - integer:: flags2,owtop,sigflags,siglen - logical:: vkeys - character(len=100):: str - owtop=coder%wtop - lclbase=-1 - if(iscomm) then - lclbase=coder%wtop - do i=1,nargs - arg=coder%vstack(coder%vtop-nargs+i) - if(cnode_get_kind(arg)==cnode_is_var) then - coder%wstack(coder%wtop+i)=& - merge(var_is_imported,0,par_depth(coder,arg)',& - pm_fast_isnull(node_get(proc,proc_link)) - endif - if(proc_conforms()) then - if(debug_codegen) then - write(*,*) 'CONFORMING_PROC>',coder%vtop,base,trim(str) - endif - call trav_proc(coder,node,proc,nargs,keys,& - amplocs,nret,sig,numprocs,lclbase) - if(coder%wtop/=oldwtop) call pm_panic('stray w') - if(debug_codegen) then - write(*,*) 'FINISHED TRAVERSING CONFORMING PROC>',& - coder%vtop,base,trim(str) - endif - cproc=top_code(coder) - if(cnode_get_kind(cproc)==cnode_is_builtin) then - flags2=cnode_get_num(cproc,bi_flags) - else - flags2=cnode_get_num(cproc,pr_flags) - endif - ! Combine flags for this signature - coder%vstack(base+2)%offset=& - ior(coder%vstack(base+2)%offset,& - int(flags2,pm_p)) - endif - proc=node_get(proc,proc_link) - if(pm_fast_isnull(proc)) exit - enddo - if(.not.pm_fast_isnull(keys)) then - n=pm_set_size(coder%context,keys) - do i=base+4,coder%vtop,2 - if(cnode_get_kind(coder%vstack(i))==cnode_is_proc) then - call cnode_set_num(coder%vstack(i),pr_nkeys,n) - endif - enddo - endif - if(debug_codegen) then - write(*,*) 'SIGEND> ',& - 'NARGS=',nargs,'nret=',nret,'N=',& - coder%vtop-base,'WT=',coder%wtop - endif - if(coder%vtop>base+2) then - if(debug_codegen) & - write(*,*) 'MAKE-SIG-VECT>',base,coder%vtop,coder%vtop-base - call make_code(coder,node,cnode_is_arglist,coder%vtop-base) - sig=top_code(coder) - k=pm_idict_add(coder%context,coder%sig_cache,& - coder%wstack(coder%wtop-siglen+1:),siglen,sig) - if(k/=oldk) then - write(*,*) k,oldk,oldwtop - call pm_panic('k moved') - endif - call drop_code(coder) - sigvect=sig - sig=pm_fast_tinyint(coder%context,k) - else - call drop_code(coder) - call drop_code(coder) - if(.not.present(noerr)) then - call code_error(coder,node,& - 'Cannot find procedure with compatable signature: ') - call more_error(coder%context,& - ' '//trim(sig_as_str(coder,name,amplocs,& - nargs,nret,flags))) - proc=node_arg(procdef,2) - call more_error(coder%context,& - ' Procedures considered:') - i=0 - do - call more_error(coder%context,& - ' '//trim(proc_sig_as_str(coder,proc))) - proc=node_get(proc,proc_link) - if(pm_fast_isnull(proc)) exit - i=i+1 - if(i>11.and..not.pm_opts%see_all_procs) then - call more_error(coder%context,'... (to see all procedures use -fsee-all-procs)') - exit - endif - enddo - endif - sig=pm_null_obj - endif - else - sig=pm_fast_tinyint(coder%context,k) - sigvect=pm_dict_val(coder%context,coder%sig_cache,int(k,pm_ln)) - endif - coder%wtop=owtop - contains - include 'fisnull.inc' - include 'fnewnc.inc' - include 'ftiny.inc' - - function proc_conforms() result(ok) - logical:: ok - type(pm_ptr):: params,arg - integer:: sym,flags2 - amplocs2=node_get(proc,proc_amplocs) - nret2=node_get_num(proc,proc_numret) - flags2=node_get_num(proc,proc_flags) - if(debug_codegen) then - write(*,*) 'CHECK CONFORM>',& - amplocs%offset,amplocs2%offset,& - nret,nret2,flags,flags2 - endif - ok=(iand(flags,call_is_comm)==& - iand(flags2,proc_is_comm)& - .and.amplocs2%offset==amplocs%offset& - .and.nret2==nret) - if(iand(flags2,proc_is_cond+proc_is_uncond)/=0) then - if(iand(flags2,proc_is_cond)/=0) then - if(coder%par_state=par_state_cond) ok=.false. - endif - endif - end function proc_conforms - - end function find_sig - - !====================================================================== - ! Find or construct signature for variable call using variable selector - !====================================================================== - recursive function find_vcall_sig(coder,node,amplocs,& - nargs,nret,flags,sigvect,iscomm) result(sig) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: node,amplocs - integer,intent(in):: nargs,nret,flags - type(pm_ptr),intent(out):: sigvect - logical,intent(in):: iscomm - type(pm_ptr):: sig,arg - integer:: k - integer:: i,cflags,flags2,locl_base,siglen - character(len=100):: str - siglen=4 - if(iscomm) then - do i=1,nargs - arg=coder%vstack(coder%vtop-nargs+i) - if(cnode_get_kind(arg)==cnode_is_var) then - coder%wstack(coder%wtop+i)=cnode_get_num(arg,var_flags) - else - coder%wstack(coder%wtop+i)=0 - endif - enddo - coder%wtop=coder%wtop+nargs - siglen=siglen+nargs - end if - call check_wstack(coder,4) - coder%wstack(coder%wtop+1)=iand(flags,call_is_comm) - coder%wstack(coder%wtop+2)=amplocs%offset - coder%wstack(coder%wtop+3)=nret - coder%wstack(coder%wtop+4)=sym_proc - coder%wtop=coder%wtop+4 - k=pm_ivect_lookup(coder%context,coder%sig_cache,& - coder%wstack(coder%wtop-siglen+1:),siglen) - if(k>0) then - sig=pm_fast_tinyint(coder%context,k) - sigvect=pm_dict_val(coder%context,& - coder%sig_cache,int(k,pm_ln)) - else - call code_null(coder) - call code_num(coder,proc_is_var) - call code_num(coder,coder%call_sig) - call code_val(coder,node) - call make_code(coder,node,cnode_is_arglist,4) - sigvect=top_code(coder) - k=pm_idict_add(coder%context,& - coder%sig_cache,& - coder%wstack(coder%wtop-siglen+1:),& - siglen,sigvect) - coder%call_sig=k - - sig=pm_fast_tinyint(coder%context,k) - call drop_code(coder) - - endif - coder%wtop=coder%wtop-siglen - contains - include 'ftiny.inc' - end function find_vcall_sig - - !======================================================================= - ! Complete variable-call signatures now all proc{..} values located - !======================================================================= - subroutine complete_vcall_sigs(coder) - type(code_state):: coder - integer(pm_ln):: kbase,k,newk,nbase - type(pm_ptr):: name,names,nameset,amplocs,key,keys - type(pm_ptr):: sig,vals,val,node,sigvect,procroot,procroots - integer:: i,nret,nargs,base,n,lbase,flags - k=coder%call_sig - if(k==0) return - - if(pm_fast_isnull(coder%proc_name_vals)) then - val=vals%data%ptr(vals%offset+k-1) - call cnode_error(coder,val,& - 'Call to procedure value '//& - ' but program does not create any procedure values') + + args(1)=node_get_num(procdef,proc_name) + signo=pm_ivect_lookup(coder%context,coder%sig_cache,& + args,1) + if(signo>0) then + sig=pm_fast_tinyint(coder%context,signo) return endif + + call make_code(coder,node,cnode_is_callsig,0) + signo=pm_idict_add(coder%context,coder%sig_cache,& + args,1,pop_code(coder)) + + base=coder%vtop + proc=node_arg(procdef,2) do - k=coder%call_sig - kbase=k - nameset=coder%proc_name_vals - nbase=pm_dict_size(coder%context,nameset) - names=pm_dict_keys(coder%context,nameset) - procroots=pm_dict_vals(coder%context,nameset) - keys=pm_dict_keys(coder%context,coder%sig_cache) - vals=pm_dict_vals(coder%context,coder%sig_cache) - do while(k/=0) - key=keys%data%ptr(keys%offset+k-1) - val=vals%data%ptr(vals%offset+k-1) - node=cnode_arg(val,4) - n=pm_fast_esize(key) - flags=key%data%i(key%offset+n-3) - nargs=n-4 - amplocs=pm_fast_name(coder%context,& - key%data%i(key%offset+n-2)) - nret=key%data%i(key%offset+n-1) - base=coder%vtop - lbase=coder%wtop - call check_wstack(coder,int(pm_fast_esize(key)-2)) - coder%wstack(coder%wtop+1:coder%wtop+pm_fast_esize(key)-3)=& - key%data%i(key%offset:key%offset+pm_fast_esize(key)-4) - coder%wtop=coder%wtop+pm_fast_esize(key)-3 - call code_null(coder) - call code_val(coder,cnode_arg(val,2)) - call code_val(coder,cnode_arg(val,3)) - call code_val(coder,cnode_arg(val,4)) - do i=1,pm_dict_size(coder%context,nameset) - procroot=procroots%data%ptr(procroots%offset+i-1) - name=names%data%ptr(names%offset+i-1) - sig=find_sig(coder,node,name,amplocs,& - nargs,nret,flags,sigvect,.false.,& - noerr=.true.,procroot=procroot) - if(.not.pm_fast_isnull(sig)) then - call code_val(coder,name) - call code_val(coder,sig) - endif - enddo - coder%wtop=lbase - newk=cnode_num_arg(val,3) - call make_code(coder,node,cnode_is_arglist,& - coder%vtop-base) - call pm_dict_set_val(coder%context,& - coder%sig_cache,k,top_code(coder)) - call drop_code(coder) - coder%vtop=base - k=newk - enddo - if(nbase==pm_dict_size(coder%context,coder%proc_name_vals).and.& - kbase==coder%call_sig) exit + call trav_proc(coder,proc) + proc=node_get(proc,proc_link) + if(pm_fast_isnull(proc)) exit enddo + call make_code(coder,node,cnode_is_callsig,coder%vtop-base) + signo=pm_idict_add(coder%context,coder%sig_cache,& + args,1,top_code(coder)) + call drop_code(coder) + sig=pm_fast_tinyint(coder%context,signo) contains - include 'fname.inc' include 'fisnull.inc' - include 'fesize.inc' - end subroutine complete_vcall_sigs - + include 'ftiny.inc' + end function find_sig + !=========================================== ! Sort all defined signatures !=========================================== subroutine sort_sigs(coder) type(code_state),intent(inout):: coder integer(pm_ln):: i - type(pm_ptr):: vals,v,n + type(pm_ptr):: vals,v if(debug_codegen) then - write(*,*) 'SORT SIGS',pm_dict_size(coder%context,coder%sig_cache) + write(*,*) 'SORT SIGS',& + pm_dict_size(coder%context,coder%sig_cache) endif vals=pm_dict_vals(coder%context,coder%sig_cache) do i=0,pm_dict_size(coder%context,coder%sig_cache)-1 v=vals%data%ptr(vals%offset+i) - if(cnode_flags_clear(v,cnode_args+1,proc_is_var)) then - if(debug_codegen) then - write(*,*) 'SORT SIG',i,& - pm_dict_size(coder%context,coder%sig_cache)-1,& - trim(sig_name_str(coder,int(i+1))),& - v%data%ptr(v%offset+cnode_args+1)%offset - endif - call sort_sig(coder,v,int(i+1)) - else if(debug_codegen) then - write(*,*) 'SORT SIG SKIP',i,& - pm_dict_size(coder%context,coder%sig_cache)-1,& - trim(sig_name_str(coder,int(i+1))) - endif + call sort_sig(coder,v,int(i+1)) enddo end subroutine sort_sigs @@ -7540,88 +5747,75 @@ subroutine sort_sig(coder,sig,signo) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: sig integer,intent(in):: signo - integer:: start,end - integer:: h,i,j,k,ii,rel,rtype1,rtype2 - integer:: typ1,typ2,typ3,inter,union - type(pm_ptr):: code,pars - logical:: ok - type(pm_typ_einfo):: einfo - start=sig%offset+cnode_args+2 - end=sig%offset+pm_fast_esize(sig) - if(debug_codegen) write(*,*) 'SORT SIGNATURE>',start,end - do i=end-3,start,-2 - if(debug_more_codegen) write(*,*) 'I=',i,i+2,end-1 - typ1=sig%data%ptr(i)%offset - code=sig%data%ptr(i+1) - j=i+2 - do while(j<=end-1) - typ2=sig%data%ptr(j)%offset + integer:: i,j,typ1,typ2 + type(pm_ptr):: proc1,proc2 + + if(debug_codegen) write(*,*) 'SORT SIGNATURE>' + + do i=cnode_numargs(sig),1,-1 + proc1=cnode_arg(sig,i) + typ1=cnode_get_num(proc1,pr_ptype) + j=i+1 + do while(j<=cnode_numargs(sig)) + proc2=cnode_arg(sig,j) + typ2=cnode_get_num(proc2,pr_ptype) + if(debug_codegen) then write(*,*) 'COMPARE SIGS>',typ1,typ2 write(*,*) '--------------------------------------' - write(*,*) trim(pm_typ_as_string(coder%context,typ2)) - write(*,*) trim(pm_typ_as_string(coder%context,typ1)) + write(*,*) trim(pm_type_as_string(coder%context,typ2)) + write(*,*) trim(pm_type_as_string(coder%context,typ1)) write(*,*) '--------------------------------------' endif - if(typ1==typ2) then - call cnode_error(coder,code,& - 'Procedure "'//trim(sig_name_str(coder,signo))//& - '" defined with identical signatures:'//& - trim(pm_typ_as_string(coder%context,typ2))) - call cnode_error(coder,sig%data%ptr(j+1),& - 'Conflicting definition') - return - else if(pm_typ_includes(coder%context,typ2,typ1,pm_typ_incl_typ,& - einfo)) then - if(debug_more_codegen) write(*,*) 'INCL' - call check_nesting(code,sig%data%ptr(j+1)) - exit + if(cnode_get_num(proc1,pr_nret)/=cnode_get_num(proc2,pr_nret).or.& + iand(cnode_get_num(proc1,pr_flags),proccall_is_comm+proc_is_cond)/=& + iand(cnode_get_num(proc2,pr_flags),proccall_is_comm+proc_is_cond).or.& + iand(cnode_get_num(proc1,pr_flags),proccall_is_comm+proc_is_uncond)/=& + iand(cnode_get_num(proc2,pr_flags),proccall_is_comm+proc_is_cond)) then + if(debug_more_codegen) write(*,*) 'SIG DIFFERENT' + sig%data%ptr(sig%offset+cnode_args+j-2)=proc2 + j=j+1 + else if(pm_type_includes(coder%context,typ2,typ1,pm_type_incl_type)) then + if(pm_type_includes(coder%context,typ1,typ2,pm_type_incl_type)) then + if(.not.pm_type_has_when(coder%context,typ2)) then + call cnode_error(coder,proc1,& + 'Procedure "'//trim(sig_name_str(coder,signo))//& + '" defined with identical signatures:'//& + trim(pm_type_as_string(coder%context,typ2))) + call cnode_error(coder,proc2,'Conflicting definition') + return + else + sig%data%ptr(sig%offset+cnode_args+j-2)=proc2 + j=j+1 + endif + else + if(debug_more_codegen) write(*,*) 'SIG INCL' + call check_nesting(proc1,proc2) + exit + endif else - if(debug_more_codegen) write(*,*) 'NOT INCL' - if(pm_typ_includes(coder%context,typ1,typ2,pm_typ_incl_typ,& - einfo)) then - call check_nesting(sig%data%ptr(j+1),code) + if(debug_more_codegen) write(*,*) 'SIG NOT INCL' + if(pm_type_includes(coder%context,typ1,typ2,pm_type_incl_type)) then + call check_nesting(proc2,proc1) endif - sig%data%ptr(j-2)=sig%data%ptr(j) - sig%data%ptr(j-1)=sig%data%ptr(j+1) - j=j+2 + sig%data%ptr(sig%offset+cnode_args+j-2)=proc2 + j=j+1 endif enddo - sig%data%ptr(j-2)%offset=typ1 - sig%data%ptr(j-1)=code + sig%data%ptr(sig%offset+cnode_args+j-2)=proc1 enddo - - if(pm_debug_checks) then - do i=start,end-1,2 - !write(*,*) '::',i,sig%data%ptr(i+1)%data%vkind - if(sig%data%ptr(i+1)%data%vkind/=pm_pointer) then - call pm_dump_tree(coder%context,6,sig%data%ptr(i+1),2) - !write(*,*) sym_names(sig%data%ptr(i+1)%offset) - else - !call qqdump_code_tree(coder,pm_null_obj,6,sig%data%ptr(i+1),2) - endif - if(cnode_get_kind(sig%data%ptr(i+1))/=cnode_is_proc& - .and.cnode_get_kind(sig%data%ptr(i+1))/=cnode_is_builtin) then - write(*,*) cnode_get_kind(sig%data%ptr(i+1)) - call pm_panic('sort_sig not proc') - endif - end do - end if contains include 'fesize.inc' subroutine check_nesting(first,second) type(pm_ptr),intent(in):: first,second logical:: isbad - integer:: ret1,ret2 + integer:: ret1,ret2,rtype1,rtype2,ii type(pm_ptr):: tv1,tv2 - + if(cnode_flags_clear(second,& pr_flags,proc_is_open)) then -!!$ write(*,*) 'COMPARE>',trim(sig_name_str(coder,signo)),' ',& -!!$ trim(pm_name_as_string(coder%context,cnode_get_name(code,cnode_modl_name))),& -!!$ trim(pm_name_as_string(coder%context,cnode_get_name(sig%data%ptr(j+1),cnode_modl_name))) if(.not.(cnode_get(first,cnode_modl_name)==& cnode_get(second,cnode_modl_name))) then call cnode_error(coder,first,& @@ -7630,35 +5824,19 @@ subroutine check_nesting(first,second) 'Conflicting definition') endif endif - - ! This would implement the ".." internal-to-module extension - ! rule - not yet decided if this is a good idea - -!!$ if(cnode_flags_clear(sig%data%ptr(j+1),& -!!$ pr_flags,proc_is_extensible)) then -!!$ call cnode_error(coder,code,& -!!$ 'Procedure "'//trim(sig_name_str(coder,signo))//& -!!$ '" attempts to specialise procedure defined without ".." or "..."') -!!$ call cnode_error(coder,sig%data%ptr(j+1),& -!!$ 'Conflicting definition') -!!$ endif - - ! This assumes pr_rtype == bi_rtype - if(pm_debug_checks) then - if(pr_rtype/=bi_rtype) call pm_panic('pr_rtype/=bi_rtype') - endif + ret1=cnode_get_num(second,pr_rtype) ret2=cnode_get_num(first,pr_rtype) - tv1=pm_typ_vect(coder%context,ret1) - tv2=pm_typ_vect(coder%context,ret2) - if(pm_tv_kind(tv1)/=pm_typ_is_undef_result.and.& - pm_tv_kind(tv2)/=pm_typ_is_undef_result) then + tv1=pm_type_vect(coder%context,ret1) + tv2=pm_type_vect(coder%context,ret2) + if(pm_tv_kind(tv1)/=pm_type_is_undef_result.and.& + pm_tv_kind(tv2)/=pm_type_is_undef_result) then isbad=.false. do ii=1,pm_tv_numargs(tv1) rtype1=pm_tv_arg(tv1,ii) rtype2=pm_tv_arg(tv2,ii) - if(.not.pm_typ_includes(coder%context,& - rtype1,rtype2,pm_typ_incl_typ,einfo)) then + if(.not.pm_type_includes(coder%context,& + rtype1,rtype2,pm_type_incl_type)) then if(.not.isbad) then call cnode_error(coder,first,& 'Procedure "'//trim(sig_name_str(coder,signo))//& @@ -7667,13 +5845,12 @@ subroutine check_nesting(first,second) call more_error(coder%context,'Return value #'//& trim(pm_int_as_string(ii))//& ' in original procedure has type: '//& - trim(pm_typ_as_string(coder%context,rtype1))) + trim(pm_type_as_string(coder%context,rtype1))) call more_error(coder%context,& 'but in this procedure has type: '//& - trim(pm_typ_as_string(coder%context,rtype2))) + trim(pm_type_as_string(coder%context,rtype2))) isbad=.true. - - + endif enddo if(isbad) then @@ -7681,9 +5858,9 @@ subroutine check_nesting(first,second) 'Original procedure in above error') endif endif - + end subroutine check_nesting - + end subroutine sort_sig @@ -7697,12 +5874,11 @@ end subroutine sort_sig !======================================================== recursive function find_param(coder,cblock,node,name,name2) result(v) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node,name - type(pm_ptr),intent(in),optional:: name2 + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: name + integer,intent(in),optional:: name2 type(pm_ptr):: v type(pm_ptr):: p - logical:: ok - integer:: i,n if(present(name2)) then p=find_imported_decl(coder,node,name,name2,modl_param,.true.) else @@ -7731,15 +5907,17 @@ end function find_param !======================================================== function find_decl(coder,node,name,where) result(ptr) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: node,name - integer,intent(in):: where + type(pm_ptr),intent(in):: node + integer,intent(in):: name,where type(pm_ptr):: ptr type(pm_ptr):: v,modl modl=node_get_modl(node) - v=pm_dict_lookup(coder%context,modl%data%ptr(modl%offset+where),name) + v=pm_dict_lookup(coder%context,modl%data%ptr(modl%offset+where),& + pm_fast_name(coder%context,name)) if(pm_fast_isnull(v)) then v=pm_dict_lookup(coder%context,& - modl%data%ptr(modl%offset+where+modl_local),name) + modl%data%ptr(modl%offset+where+modl_local),& + pm_fast_name(coder%context,name)) if(pm_fast_isnull(v)) then ptr=v return @@ -7748,6 +5926,7 @@ function find_decl(coder,node,name,where) result(ptr) ptr=v%data%ptr(v%offset) contains include 'fisnull.inc' + include 'fname.inc' end function find_decl !======================================================== @@ -7755,24 +5934,25 @@ end function find_decl !======================================================== function find_imported_decl(coder,node,name1,name2,where,noerr) result(p) type(code_state):: coder - type(pm_ptr),intent(in):: node,name1,name2 + type(pm_ptr),intent(in):: node + integer,intent(in):: name1,name2 integer,intent(in):: where logical,intent(in),optional:: noerr type(pm_ptr):: p - type(pm_ptr):: thismodl,modl,dict + type(pm_ptr):: thismodl,modl character(len=5):: str thismodl=node_get_modl(node) modl=pm_dict_lookup(coder%context,& thismodl%data%ptr(thismodl%offset+modl_include),& - name1) + pm_fast_name(coder%context,name1)) if(pm_fast_isnull(modl)) then call code_error(coder,node,'No such module: ',name1) p=pm_null_obj else modl=node_arg(modl,2) p=pm_dict_lookup(coder%context,& - modl%data%ptr(modl%offset+where),name2) + modl%data%ptr(modl%offset+where),pm_fast_name(coder%context,name2)) if(pm_fast_isnull(p)) then if(.not.present(noerr)) then str='proc' @@ -7782,7 +5962,7 @@ function find_imported_decl(coder,node,name1,name2,where,noerr) result(p) str='param' endif call code_error(coder,node,'Cannot find '//str//' '//& - trim(pm_name_as_string(coder%context,int(name2%offset)))//& + trim(pm_name_as_string(coder%context,name2))//& ' in: ',name1) endif else @@ -7791,25 +5971,9 @@ function find_imported_decl(coder,node,name1,name2,where,noerr) result(p) endif contains include 'fisnull.inc' + include 'fname.inc' end function find_imported_decl - - !=============================================== - ! Push two implicit communicating proc arguments - !=============================================== - subroutine make_comm_call_args(coder,cblock,node) - type(code_state),intent(inout):: coder - type(pm_ptr):: cblock,node - if(coder%par_base==0) then - call make_temp_var(coder,cblock,node) - call make_temp_var(coder,cblock,node) - call make_temp_var(coder,cblock,node) - else - call code_val(coder,coder%var(coder%par_base+lv_distr)) - call code_val(coder,coder%var(coder%over_base)) - call code_val(coder,coder%var(coder%par_base+lv_index)) - endif - end subroutine make_comm_call_args !======================================================================= ! Make type using size elements from wstack and push it on wstack @@ -7823,7 +5987,7 @@ subroutine make_type(coder,size,val) if(coder%wtop<1) call pm_panic('make type') endif coder%wstack(coder%wtop)=& - pm_new_typ(coder%context,coder%wstack(coder%wtop:coder%wtop+size-1),& + pm_new_type(coder%context,coder%wstack(coder%wtop:coder%wtop+size-1),& val) end subroutine make_type @@ -7833,136 +5997,106 @@ end subroutine make_type !======================================================================== subroutine make_basic_type(coder,size,val) type(code_state),intent(inout):: coder - integer,intent(in):: size - type(pm_ptr),intent(in),optional:: val - coder%wtop=coder%wtop-size+1 - if(pm_debug_checks) then - if(coder%wtop<1) call pm_panic('make type') - endif - coder%wstack(coder%wtop)=& - pm_new_basic_typ(coder%context,coder%wstack(coder%wtop:coder%wtop+size-1),& - val) - end subroutine make_basic_type - - !=========================================================== - ! Make reference to user defined type : name(params) - !=========================================================== - function make_user_type(coder,n,tno) result(new_type) - type(code_state),intent(inout):: coder - integer,intent(in):: n - integer,intent(in):: tno - integer:: new_type - integer:: deftyp - deftyp=pm_typ_lookup(coder%context,coder%wstack(coder%wtop-n+1:coder%wtop)) - if(deftyp>=0) then - new_type=-1 - else - new_type=pm_new_typ(coder%context,coder%wstack(coder%wtop-n+1:coder%wtop),& - val=pm_fast_typeno(coder%context,tno)) - endif - contains - include 'ftypeno.inc' - end function make_user_type - - - - !========================================== - ! Set the parallel depth of a variable - !========================================== - subroutine var_set_par_depth(coder,var,depth) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: var - integer:: depth - call cnode_set_num(var,var_par_depth,depth-coder%proc_par_depth) - end subroutine var_set_par_depth - - !===================================================== - ! Check if a variable is local to the current loop - !===================================================== - function var_private(coder,var) result(islocal) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: var - logical:: islocal - islocal=.false. - if(pm_fast_vkind(var)==pm_pointer) then - if(cnode_get_kind(var)==cnode_is_var) then - islocal=cnode_get_num(var,var_par_depth)==& - coder%par_depth-coder%proc_par_depth - endif - endif - contains - include 'fvkind.inc' - end function var_private - - !================================ - ! Is value shared? - !================================ - function var_shared(coder,var) result(isshared) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: var - logical:: isshared - integer:: depth - isshared=.true. - if(pm_fast_vkind(var)==pm_pointer) then - if(cnode_get_kind(var)==cnode_is_var) then - depth=cnode_get_num(var,var_par_depth) - isshared=depth<=coder%par_depth-1-coder%proc_par_depth - endif + integer,intent(in):: size + type(pm_ptr),intent(in),optional:: val + coder%wtop=coder%wtop-size+1 + if(pm_debug_checks) then + if(coder%wtop<1) call pm_panic('make type') endif - contains - include 'fvkind.inc' - end function var_shared + coder%wstack(coder%wtop)=& + pm_new_basic_type(coder%context,coder%wstack(coder%wtop:coder%wtop+size-1),& + val) + end subroutine make_basic_type - !============================================================================= - ! Check if a variable was created in parallel scope containing current loop - !============================================================================= - function var_outer(coder,var) result(isouter) + !=========================================================== + ! Make reference to user defined type : name(params) + !=========================================================== + function make_user_type(coder,n,tno) result(new_type) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: var - logical:: isouter - isouter=.false. - if(pm_fast_vkind(var)==pm_pointer) then - if(cnode_get_kind(var)==cnode_is_var) then - isouter=cnode_get_num(var,var_par_depth)==& - coder%par_depth-1-coder%proc_par_depth - endif + integer,intent(in):: n + integer,intent(in):: tno + integer:: new_type + integer:: deftyp + deftyp=pm_type_lookup(coder%context,coder%wstack(coder%wtop-n+1:coder%wtop)) + if(deftyp>=0) then + new_type=-1 + else + new_type=pm_new_type(coder%context,coder%wstack(coder%wtop-n+1:coder%wtop),& + val=pm_fast_typeno(coder%context,tno)) endif contains - include 'fvkind.inc' - end function var_outer + include 'ftypeno.inc' + end function make_user_type + !=================================== ! Find a variable !=================================== function find_var(coder,name) result(v) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: name + integer,intent(in):: name type(pm_ptr):: v integer:: i integer::n - n=name%offset - i=find_var_entry(coder,n,coder%proc_base) + i=find_var_entry(coder,name,coder%proc_base) if(i/=0) then v=coder%var(i) + if(i<=coder%block_base) then + if(debug_more_codegen) then + write(*,*) 'importing>',trim(pm_name_as_string(coder%context,n)) + endif + call import_to_block_scope(coder,i,v,coder%block_entry) + coder%var(i)=v + endif else v=pm_null_obj endif return end function find_var + !========================================= + ! Find a system variable which must exist + !========================================== + function find_sys_var(coder,node,name) result(v) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: node + integer,intent(in):: name + type(pm_ptr):: v + integer::i + v=find_var(coder,name) + if(pm_debug_checks) then + if(pm_fast_isnull(v)) then + call code_error(coder,node,'Internal_error - cannot find sys var: '//& + trim(pm_name_as_string(coder%context,name))) + do i=1,coder%top + write(*,*) '>>',trim(pm_name_as_string(coder%context,coder%stack(i))) + enddo + call pm_panic('ooo') + endif + endif + contains + include 'fname.inc' + include 'fisnull.inc' + end function find_sys_var + + !========================================== ! Find a variable and its table entry !========================================== function find_var_and_entry(coder,name,i) result(v) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: name + integer,intent(in):: name integer,intent(out):: i type(pm_ptr):: v integer::n - n=name%offset + n=name i=find_var_entry(coder,n,coder%proc_base) if(i/=0) then v=coder%var(i) + if(i<=coder%block_base) then + call import_to_block_scope(coder,i,v,coder%block_entry) + coder%var(i)=v + endif else v=pm_null_obj endif @@ -7978,22 +6112,12 @@ function find_var_entry(coder,n,base) result(index) integer,intent(in):: base integer:: index integer:: i - type(pm_ptr):: node - index=0 - i=coder%hash(var_hash(n)) - if(pm_debug_checks) then - if(i>coder%top) then - write(*,*) '#',i,coder%top,var_hash(n) - call pm_panic('bad hash') - endif - endif - do while(i>base) + do i=coder%top,base+1,-1 if(coder%stack(i)==n) then index=i return endif - i=coder%link(i) enddo end function find_var_entry @@ -8009,6 +6133,20 @@ subroutine hide_vars(coder,start,end) enddo end subroutine hide_vars + subroutine hide_where_vars(coder,start,end) + type(code_state),intent(inout):: coder + integer,intent(in):: start,end + integer:: i + do i=start,end + if(cnode_get_kind(coder%var(i))==cnode_is_var) then + if(cnode_flags_set(coder%var(i),var_flags,var_is_where)) then + coder%stack(i)=-coder%stack(i) + endif + endif + enddo + end subroutine hide_where_vars + + !==================================================== ! Undo hide_vars for block of variables !==================================================== @@ -8017,7 +6155,7 @@ subroutine reveal_vars(coder,start,end) integer,intent(in):: start,end integer:: i do i=start,end - coder%stack(i)=-coder%stack(i) + if(coder%stack(i)<0) coder%stack(i)=-coder%stack(i) enddo end subroutine reveal_vars @@ -8033,20 +6171,11 @@ subroutine make_temp_var(coder,cblock,node) call code_val(coder,cblock) call code_null(coder) flags=0 - if(coder%par_state>=par_state_cond) then - flags=ior(flags,var_is_incomplete) - endif - if(coder%par_state==par_state_par) then - flags=ior(flags,var_is_par_var) - endif call code_num(coder,flags) call code_null(coder) coder%index=coder%index+1 call code_num(coder,coder%index) - call code_val(coder,& - pm_fast_tinyint(coder%context,coder%par_depth-coder%proc_par_depth)) - call code_val(coder,& - pm_fast_tinyint(coder%context,coder%par_depth-coder%proc_par_depth)) + call code_num(coder,coder%lex_scope) call make_code(coder,node,cnode_is_var,var_node_size) link=cnode_get(cblock,cblock_last_var) if(pm_fast_isnull(link)) then @@ -8077,8 +6206,7 @@ subroutine make_sys_var(coder,cblock,node,name,flags) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node integer,intent(in):: name,flags - call make_var(coder,cblock,node,& - pm_fast_name(coder%context,name),flags) + call make_var(coder,cblock,node,name,flags) contains include 'fname.inc' end subroutine make_sys_var @@ -8088,19 +6216,19 @@ end subroutine make_sys_var !==================================== subroutine make_var(coder,cblocka,node,name,flags,extra_info) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblocka,node,name - integer,intent(in):: flags + type(pm_ptr),intent(in):: cblocka,node + integer,intent(in):: name,flags type(pm_ptr),optional:: extra_info type(pm_ptr):: var,link,cblock - logical:: local integer:: vflags + ! Check for prior definition - if(iand(flags,var_is_shadowed)==0) then + if(iand(flags,var_is_shadowed+var_is_imported)==0) then var=find_var(coder,name) if(.not.pm_fast_isnull(var)) then if(pm_debug_checks) then - if(name%offset==0) call pm_panic('null name in make_var') + if(name==0) call pm_panic('null name in make_var') endif call code_error(coder,node,& 'Cannot redefine local variable or constant:',name) @@ -8109,8 +6237,7 @@ subroutine make_var(coder,cblocka,node,name,flags,extra_info) endif endif - if(cnode_get_name(cblocka,cblock_sym)==sym_sync.or.& - cnode_get_name(cblocka,cblock_sym)==sym_any) then + if(cnode_flags_set(cblocka,cblock_flags,cblock_is_open)) then cblock=cnode_get(cblocka,cblock_parent) else cblock=cblocka @@ -8118,26 +6245,17 @@ subroutine make_var(coder,cblocka,node,name,flags,extra_info) ! Create variable node call code_val(coder,cblock) - call code_val(coder,name) + call code_num(coder,name) ! Flag variables according to current par state - vflags=flags - if(coder%par_state>=par_state_cond) then - vflags=ior(vflags,var_is_incomplete) - endif - if(coder%par_state==par_state_par) then - vflags=ior(vflags,var_is_par_var) - endif + vflags=merge(ior(var_is_par_var,flags),flags,coder%par_state==par_state_par) ! All named variables multi access (this may change) call code_num(coder,ior(vflags,var_is_multi_access)) call code_null(coder) coder%index=coder%index+1 call code_num(coder,coder%index) - call code_val(coder,pm_fast_tinyint(coder%context,& - coder%par_depth-coder%proc_par_depth)) - call code_val(coder,pm_fast_tinyint(coder%context,& - coder%par_depth-coder%proc_par_depth)) + call code_num(coder,coder%lex_scope) if(present(extra_info)) then call code_val(coder,extra_info) call make_code(coder,node,cnode_is_var,var_node_size+1) @@ -8145,18 +6263,21 @@ subroutine make_var(coder,cblocka,node,name,flags,extra_info) call make_code(coder,node,cnode_is_var,var_node_size) endif - ! Add variable to hash table - call make_var_tab_entry(coder,int(name%offset),top_code(coder)) + ! write(*,*) 'make-var>',trim(pm_name_as_string(coder%context,int(name%offset))),coder%index + + + ! Add variable to stack + call push_var(coder,name,top_code(coder)) ! Link variable to enclosing code block link=cnode_get(cblock,cblock_last_var) if(pm_fast_isnull(link)) then call pm_ptr_assign(coder%context,cblock,& int(cblock_first_var,pm_ln),& - top_code(coder)) + top_code(coder)) call pm_ptr_assign(coder%context,cblock,& int(cblock_last_var,pm_ln),& - top_code(coder)) + top_code(coder)) else call pm_ptr_assign(coder%context,link,int(var_link,pm_ln),& top_code(coder)) @@ -8173,12 +6294,19 @@ end subroutine make_var !==================================================== ! Make an entry for a variable in the hash table !===================================================== - subroutine make_var_tab_entry(coder,name,var) + subroutine push_var(coder,name,var) type(code_state),intent(inout):: coder integer:: name type(pm_ptr),intent(in):: var - integer:: i,j + integer:: j + +!!$ if(coder%top==9) then +!!$ write(*,*) 'Push',var%data%vkind,cnode_get_kind(var) +!!$ call qdump_code_tree(coder,pm_null_obj,6,var,2) +!!$ if(cnode_get_kind(var)/=cnode_is_var) call pm_panic('poo') +!!$ endif + if(name==0) return if(coder%top>=max_code_stack) then call pm_panic('Program too complex') @@ -8187,10 +6315,7 @@ subroutine make_var_tab_entry(coder,name,var) j=coder%top coder%stack(j)=name coder%var(j)=var - i=var_hash(coder%stack(j)) - coder%link(j)=coder%hash(i) - coder%hash(i)=j - end subroutine make_var_tab_entry + end subroutine push_var !===================================== ! Pop variables down to newbase @@ -8198,41 +6323,11 @@ end subroutine make_var_tab_entry subroutine pop_vars_to(coder,newbase) type(code_state),intent(inout):: coder integer,intent(in):: newbase - integer:: i,k - integer:: j - if(pm_debug_checks) then - if(newbase>coder%top) call pm_panic('pop_vars_to') - endif - do i=coder%top,newbase+1,-1 - j=coder%stack(i) - if(j/=0) then - if(pm_debug_checks) then - if(j==typevar_start.or.j==typevar_end) then - write(*,*) 'i=',i,j - do j=coder%top,newbase+1,-1 - write(*,*) j,coder%stack(j),& - trim(pm_name_as_string(coder%context,max(0,coder%stack(j)))) - enddo - call pm_panic('Cannot pop typevar start/end') - endif - endif - k=var_hash(abs(j)) - coder%hash(k)=coder%link(i) - endif - enddo + integer:: old_top + old_top=coder%top coder%top=newbase end subroutine pop_vars_to - !======================================= - ! Variable hash from variable name - !======================================= - function var_hash(n) result(h) - integer,intent(in):: n - integer:: h - h=iand(abs(int(n)),code_local_hash-1)+1 - h=1 - end function var_hash - !========================================= ! Make integer constant node (PM sint) !========================================= @@ -8243,9 +6338,9 @@ subroutine make_int_const(coder,cblock,node,val) type(pm_ptr):: ptr ptr=pm_fast_newnc(coder%context,pm_int,1) ptr%data%i(ptr%offset)=val - coder%temp=ptr + coder%temp2=ptr call make_const(coder,cblock,node,ptr) - coder%temp=pm_null_obj + coder%temp2=pm_null_obj contains include 'fnewnc.inc' end subroutine make_int_const @@ -8260,9 +6355,9 @@ subroutine make_long_const(coder,cblock,node,val) type(pm_ptr):: ptr ptr=pm_fast_newnc(coder%context,pm_long,1) ptr%data%ln(ptr%offset)=val - coder%temp=ptr + coder%temp2=ptr call make_const(coder,cblock,node,ptr) - coder%temp=pm_null_obj + coder%temp2=pm_null_obj contains include 'fnewnc.inc' end subroutine make_long_const @@ -8277,9 +6372,9 @@ subroutine make_static_long_const(coder,cblock,node,val) type(pm_ptr):: ptr ptr=pm_fast_newnc(coder%context,pm_long,1) ptr%data%ln(ptr%offset)=val - coder%temp=ptr - call make_const(coder,cblock,node,ptr,pm_new_value_typ(coder%context,ptr)) - coder%temp=pm_null_obj + coder%temp2=ptr + call make_const(coder,cblock,node,ptr,pm_new_fix_value_type(coder%context,ptr)) + coder%temp2=pm_null_obj contains include 'fnewnc.inc' end subroutine make_static_long_const @@ -8293,10 +6388,10 @@ subroutine make_static_bool_const(coder,cblock,node,ok) logical,intent(in):: ok if(ok) then call make_const(coder,cblock,node,coder%true,& - coder%true_name) + coder%true_fix) else call make_const(coder,cblock,node,coder%false,& - coder%false_name) + coder%false_fix) endif end subroutine make_static_bool_const @@ -8308,12 +6403,14 @@ subroutine make_const(coder,cblock,node,val,typ) type(pm_ptr),intent(in):: cblock,node,val integer,intent(in),optional:: typ integer:: tno - tno=pm_fast_typeof(val) - if(tno==pm_string) tno=pm_string_type - if(present(typ)) tno=typ - if(coder%par_state/=par_state_outer) then - tno=pm_typ_add_mode(coder%context,tno,sym_mirrored,.false.) + if(present(typ)) then + tno=typ + elseif(pm_fast_typeof(val)>=pm_int) then + tno=pm_new_literal_value_type(coder%context,val) + else + tno=pm_fast_typeof(val) endif + tno=pm_type_add_mode(coder%context,tno,sym_invar) call code_val(coder,val) call code_num(coder,tno) call make_code(coder,node,cnode_is_const,2) @@ -8321,6 +6418,23 @@ subroutine make_const(coder,cblock,node,val,typ) include 'ftypeof.inc' end subroutine make_const + !=========================================== + ! Make a constant from a literal type + !=========================================== + subroutine make_literal_const(coder,cblock,node,typ,fixit) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: typ + logical,intent(in),optional:: fixit + integer:: tno + tno=typ + if(present(fixit)) tno=pm_fix_value_type_from_literal(coder%context,tno) + call code_val(coder,pm_type_val(coder%context,tno)) + call code_num(coder,tno) + call make_code(coder,node,cnode_is_const,2) + end subroutine make_literal_const + + !=========================== ! Dupicate an expression !=========================== @@ -8353,78 +6467,109 @@ end subroutine repl_expr !================================================================= ! Make a procedure call cnode for some builtin operations !================================================================== - subroutine make_sp_call(coder,cblock,node,sym,narg,nret,flags) + subroutine make_sp_call(coder,cblock,node,sym,nargs,nret,flags) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: sym,narg,nret + integer,intent(in):: sym,nargs,nret integer,intent(in),optional:: flags - integer:: depth,base,aflags + integer:: aflags aflags=0 if(present(flags)) aflags=flags - call import_args(coder,cblock,node,narg,nret,0,pm_null_obj,0,base) + call make_arglist(coder,cblock,node,nargs,nret,.false.,.false.) + call code_null(coder) call make_full_call(coder,cblock,node,& - pm_fast_tinyint(coder%context,-sym),pm_null_obj,narg,nret,0,& - ior(aflags,coder%run_flags),& - pm_null_obj,coder%par_depth) + pm_fast_tinyint(coder%context,-sym),pm_null_obj,nargs,abs(nret),0,& + pm_null_obj,aflags,& + pm_null_obj) contains include 'ftiny.inc' end subroutine make_sp_call + !================================================================= + ! Make a procedure call cnode for some builtin operations + ! creating temporary variables for returns on stack + !================================================================== + subroutine make_sp_call_rtn(coder,cblock,node,sym,narg,nret,flags) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: sym,narg,nret + integer,intent(in),optional:: flags + call make_sp_call(coder,cblock,node,sym,narg,-nret,flags) + end subroutine make_sp_call_rtn + !================================================================== ! Make a procedure call cnode for some builtin operations ! (does not create imports/exports) !================================================================== - subroutine make_basic_sp_call(coder,cblock,node,sym,narg,nret,depth) + subroutine make_basic_sp_call(coder,cblock,node,sym,nargs,nret) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: sym,narg,nret,depth - call make_full_call(coder,cblock,node,& + integer,intent(in):: sym,nargs,nret + call make_arglist(coder,cblock,node,nargs,nret,.false.,.false.,notouch=.true.) + call code_null(coder) + call make_full_call(coder,cblock,node,& pm_fast_tinyint(coder%context,-sym),pm_null_obj,& - narg,nret,0,coder%run_flags,& - pm_null_obj,depth) + nargs,abs(nret),0,pm_null_obj,0,& + pm_null_obj) contains include 'ftiny.inc' end subroutine make_basic_sp_call !============================================= ! Make a call to an intrinsic procedure + ! Returns precede arguments on the stack !============================================= subroutine make_sys_call(coder,cblock,node,sym,& - narg,nret,aflags,assign) + nargs,nret,aflags,assign) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: sym,narg,nret + integer,intent(in):: sym,nargs,nret integer,intent(in),optional:: aflags - logical,intent(in),optional:: assign - type(pm_ptr):: procs,svect,avec - integer:: flags,depth,base + logical,intent(in),optional:: assign + type(pm_ptr):: procs,avec + integer:: flags if(present(aflags)) then flags=aflags else flags=0 endif - flags=ior(flags,coder%run_flags) if(present(assign)) then - avec=coder%one + avec=coder%std_amp else avec=pm_null_obj endif - if(coder%par_state>=par_state_cond.and.& - iand(flags,proc_run_complete+proc_run_shared+proc_run_local)==0) then - flags=ior(flags,call_is_cond) - endif - call import_args(coder,cblock,node,narg,nret,0,avec,flags,base) + + call make_arglist(coder,cblock,node,nargs,nret,.true.,.false.) + call code_null(coder) procs=find_sig(coder,node,& - pm_fast_name(coder%context,sym),& - avec,narg,nret,flags,svect,.false.) + pm_fast_name(coder%context,sym)) call make_full_call(coder,cblock,node,& - procs,avec,narg,nret,0,flags,pm_null_obj,coder%par_depth) + procs,avec,nargs+1,abs(nret),0,& + pm_null_obj,flags,pm_null_obj) contains include 'fname.inc' end subroutine make_sys_call + !============================================= + ! Make a call to an intrinsic procedure + ! Arguments must be on vstack + ! Temporary return variables created and left + ! on the vstack + !============================================= + subroutine make_sys_call_rtn(coder,cblock,node,sym,& + nargs,nret,aflags,assign) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: sym,nargs,nret + integer,intent(in),optional:: aflags + logical,intent(in),optional:: assign + call make_sys_call(coder,cblock,node,sym,& + nargs,-nret,aflags,assign) + end subroutine make_sys_call_rtn + !====================================================== ! Make a call to an intrinsic communicating procedure + ! Returns precede arguments on the stack !====================================================== subroutine make_comm_sys_call(coder,cblock,node,sym,& nargs,nret,aflags,assign) @@ -8433,114 +6578,145 @@ subroutine make_comm_sys_call(coder,cblock,node,sym,& integer,intent(in):: sym,nargs,nret integer,intent(in),optional:: aflags logical,intent(in),optional:: assign - type(pm_ptr):: procs,svect,avec - integer:: depth,flags,base,narg + type(pm_ptr):: procs,avec + integer:: flags,narg narg=nargs+num_comm_args if(present(aflags)) then - flags=ior(aflags,call_is_comm) + flags=ior(aflags,proccall_is_comm+proccall_is_general) else - flags=call_is_comm + flags=proccall_is_comm+proccall_is_general endif if(present(assign)) then avec=coder%comm_amp else avec=pm_null_obj endif - call import_args(coder,cblock,node,narg,nret,0,avec,flags,base) procs=find_sig(coder,node,& - pm_fast_name(coder%context,sym)& - ,avec,narg,nret,flags,svect,.true.) + pm_fast_name(coder%context,sym)) + call make_arglist(coder,cblock,node,nargs,nret,.false.,.true.) + call code_null(coder) call make_full_call(coder,cblock,node,& - procs,avec,narg,nret,0,flags,pm_null_obj,coder%par_depth) + procs,avec,narg,abs(nret),0,pm_null_obj,flags,& + pm_null_obj) contains include 'fname.inc' end subroutine make_comm_sys_call + !============================================= + ! Make a call to a communicating procedure + ! Arguments must be on vstack + ! Temporary return variables created and left + ! on the vstack + !============================================= + subroutine make_comm_sys_call_rtn(coder,cblock,node,sym,& + nargs,nret,aflags,assign) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: sym,nargs,nret + integer,intent(in),optional:: aflags + logical,intent(in),optional:: assign + call make_comm_sys_call(coder,cblock,node,sym,& + nargs,-nret,aflags,assign) + end subroutine make_comm_sys_call_rtn + !==================================================================== ! Make a call to an intrinsic procedure with & on first argument + ! Returns must precede arguments on the stack !==================================================================== - subroutine make_assign_call(coder,cblock,node,sym,narg,nret,aflags) + subroutine make_assign_call(coder,cblock,node,sym,nargs,nret,aflags) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: sym,narg,nret + integer,intent(in):: sym,nargs,nret integer,intent(in),optional:: aflags - call make_sys_call(coder,cblock,node,sym,narg,nret,& + call make_sys_call(coder,cblock,node,sym,nargs,nret,& aflags=aflags,assign=.true.) end subroutine make_assign_call !================================================= ! Make a call to an intrinsic procedure ! with no processing of imports/exports + ! Returns must precede arguments on the stack !================================================= - subroutine make_basic_sys_call(coder,cblock,node,sym,narg,nret,depth,flags) + subroutine make_basic_sys_call(coder,cblock,node,sym,narg,nret,flags) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock,node - integer,intent(in):: sym,narg,nret,depth,flags - type(pm_ptr):: procs,svect + integer,intent(in):: sym,narg,nret,flags + type(pm_ptr):: procs procs=find_sig(coder,node,& - pm_fast_name(coder%context,sym),& - pm_null_obj,narg,nret,0,svect,.false.) + pm_fast_name(coder%context,sym)) + call make_arglist(coder,cblock,node,narg,nret,.true.,.false.,.true.) + call code_null(coder) call make_full_call(coder,cblock,node,& - procs,pm_null_obj,narg,nret,0,ior(flags,coder%run_flags),pm_null_obj,depth) + procs,pm_null_obj,narg+1,abs(nret),0,pm_null_obj,& + flags,pm_null_obj) contains include 'fname.inc' end subroutine make_basic_sys_call + subroutine make_full_sys_call(coder,cblock,node,sym,& + nargs,nret,amps,keys,keynames,flags) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node,amps,keys,keynames + integer,intent(in):: sym,nargs,nret,flags + type(pm_ptr):: procs + integer:: narg,nkeys + narg=nargs+num_comm_args + nkeys=0 + if(.not.pm_fast_isnull(keys)) nkeys=cnode_numargs(keys) + procs=find_sig(coder,node,& + pm_fast_name(coder%context,sym)) + call make_arglist(coder,cblock,node,nargs,nret,.false.,.true.) + call code_val(coder,keys) + call make_full_call(coder,cblock,node,& + procs,amps,narg,abs(nret),nkeys,keynames,flags,& + pm_null_obj) + contains + include 'fname.inc' + include 'fisnull.inc' + end subroutine make_full_sys_call + + !========================================== ! Make a procedure call + ! Argument list and key argument list (or null) + ! must be on top of vstack. !========================================== subroutine make_full_call(coder,cblock,node,procs,& - amp,narg,nret,nkeys,iflag,var,depth) + amps,nargs,nret,nkeys,keynames,flags,var) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: cblock,node,procs,amp,var - integer,intent(in):: narg,nret,nkeys - integer,intent(in):: iflag,depth - type(pm_ptr):: p,q,n,args - integer:: i + type(pm_ptr),intent(in):: cblock,node,procs,amps,var,keynames + integer,intent(in):: nargs,nret,nkeys,flags + type(pm_ptr):: p,n + integer:: iflag + if(pm_debug_checks) then - if(cnode_get_kind(cblock)/=cnode_is_cblock) & - call pm_panic('full call cblock') - endif - if(iand(iflag,proc_run_shared+proc_run_local+proc_run_complete+proc_run_always)/=0.and.& - iand(iflag,call_ignore_rules)==0) then - if(coder%par_state==par_state_outer) then - call code_error(coder,node,& - 'Cannot have "<>", "<>", "<>" or "<>" attributes'//& - ' outside of a parallel context') + if(cnode_get_kind(cblock)/=cnode_is_cblock) then + call pm_panic('full call cblock') endif endif - call make_code(coder,node,cnode_is_arglist,nret+nkeys+narg) - args=top_code(coder) + + iflag=flags + if(coder%par_state>=par_state_masked) then + iflag=ior(flags,call_is_cond) + endif + if(coder%par_state==par_state_cond.or.& + coder%par_state==par_state_par) then + iflag=ior(flags,call_is_unlabelled) + endif call code_val(coder,cblock) call code_val(coder,procs) call code_num(coder,iflag) call code_null(coder) + call code_val(coder,cnode_get(cblock,cblock_last_call)) call code_num(coder,nret) - call code_num(coder,nkeys) + call code_val(coder,keynames) coder%index=coder%index+1 call code_num(coder,coder%index) - call code_num(coder,depth-coder%proc_par_depth) call code_val(coder,var) - call code_val(coder,amp) + call code_val(coder,amps) call make_code(coder,node,cnode_is_call,call_node_size) + n=top_code(coder) - if(iand(iflag,call_is_no_touch)==0) then - do i=nret+1,nret+nkeys+narg - p=cnode_arg(args,i) - if(pm_fast_vkind(p)==pm_pointer) then - if(cnode_get_kind(p)==cnode_is_var) then - if(cnode_flags_set(p,var_flags,var_is_accessed)) then - call cnode_set_flags(p,var_flags,var_is_multi_access) - else - call cnode_set_flags(p,var_flags,var_is_accessed) - endif - endif - endif - enddo - end if - do i=1,nret - p=cnode_arg(args,i) - enddo p=cnode_get(cblock,cblock_last_call) if(pm_fast_isnull(p)) then call pm_ptr_assign(coder%context,cblock,& @@ -8556,13 +6732,111 @@ subroutine make_full_call(coder,cblock,node,procs,& call pm_ptr_assign(coder%context,cblock,& int(cblock_last_call,pm_ln),n) endif + n=pop_code(coder) + coder%proc_ncalls=coder%proc_ncalls+1 contains include 'fisnull.inc' include 'fvkind.inc' end subroutine make_full_call + !======================================================== + ! Make an argument list cnode on vstack + ! - list will contain returns, implicit args, arguments + ! in that order + ! - nargs arguments must be present at top of vstack + ! - if nret>0 then nret returns must precede arguments + ! - if nret<0 then nret temp variables created and left + ! on vstack before the argument list cnode + !======================================================== + recursive subroutine make_arglist(coder,cblock,node,nargs,nret,isstd,& + iscomm,notouch,comm_args_present) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,node + integer,intent(in):: nargs,nret + logical,intent(in):: isstd,iscomm + logical,intent(in),optional:: notouch,comm_args_present + integer:: i,ret0,arg0,extra0,nextra,base + type(pm_ptr):: arglist + + if(.not.present(notouch)) then +!!$ do i=coder%vtop-nargs+1,coder%vtop +!!$ write(*,*)' ==== ',i,' ===== ',i-(coder%vtop-nargs+1) +!!$ call qdump_code_tree(coder,pm_null_obj,6,coder%vstack(i),2) +!!$ enddo + do i=coder%vtop-nargs+1,coder%vtop + call update_arg(coder%vstack(i)) + enddo + endif + + arg0=coder%vtop-nargs + if(nret<0) then + base=arg0 + ret0=coder%vtop + do i=1,-nret + call make_temp_var(coder,cblock,node) + enddo + else + ret0=arg0-nret + base=ret0 + endif + + if(iscomm) then + do i=1,abs(nret) + call cnode_set_flags(coder%vstack(ret0+i),var_flags,var_is_maybe_not_private) + enddo + endif + + if(iscomm.and..not.present(comm_args_present)) then + extra0=coder%state_base + nextra=num_comm_args-1 + elseif(isstd) then + extra0=coder%state_base + nextra=1 + else + extra0=coder%state_base + nextra=0 + endif + + arglist=make_arglist_cnode(coder,node,abs(nret),ret0,nextra,extra0,& + iscomm.and..not.present(comm_args_present),nargs,arg0) + if(nret<0) then + if(ret0>base) then + do i=1,-nret + coder%vstack(base+i)=coder%vstack(ret0+i) + enddo + coder%vtop=base-nret+1 + else + coder%vtop=base-nret+1 + endif + else + coder%vtop=base+1 + endif + + coder%vstack(coder%vtop)=arglist + contains + include 'fvkind.inc' + + subroutine update_arg(p) + type(pm_ptr),intent(inout)::p + + if(pm_fast_vkind(p)==pm_pointer) then + if(cnode_get_kind(p)==cnode_is_var) then + call update_change_lists(coder,p,.false.) +!!$ if(.not.iscomm) then +!!$ if(cnode_flags_set(p,var_flags,var_is_maybe_not_private)) then +!!$ call code_val(coder,p) +!!$ call make_comm_sys_call_rtn(coder,cblock,node,sym_dechan,1,1) +!!$ p=pop_code(coder) +!!$ endif +!!$ endif + endif + endif + end subroutine update_arg + + end subroutine make_arglist + !================================= ! Make a cblock !================================= @@ -8606,33 +6880,92 @@ subroutine close_cblock(coder,cblock) endif p=cnode_get(cblock,cblock_last_loop_call) if(pm_fast_isnull(p)) then - call cnode_set(coder,cblock,cblock_last_loop_call,& + call cnode_set(coder%context,cblock,cblock_last_loop_call,& cnode_get(cblock,cblock_first_call)) else - call cnode_set(coder,cblock,cblock_last_loop_call,& + call cnode_set(coder%context,cblock,cblock_last_loop_call,& cnode_get(p,call_link)) endif contains include 'fisnull.inc' end subroutine close_cblock - !=============================== - ! Make a code tree node (cnode) - !=============================== + !=========================================================== + ! Make a code tree node (cnode) from nargs values on vstack + !=========================================================== subroutine make_code(coder,node,ckind,nargs) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: node integer,intent(in):: ckind,nargs - type(pm_ptr):: modl - integer:: i,ii + integer:: i + if(pm_debug_checks) then + if(coder%vtop-nargs<0) then + write(*,*) '#',coder%vtop,'<',nargs + call pm_panic('make code - not enough values on stack') + endif + endif + call make_code_stem(coder,node,ckind,nargs) + coder%temp%data%ptr(coder%temp%offset+5:coder%temp%offset+4+nargs)=& + coder%vstack(coder%vtop-nargs+1:coder%vtop) + if(pm_debug_checks) then + do i=coder%temp%offset+5,coder%temp%offset+4+nargs + !write(*,*) ckind,'##', i-coder%temp%offset-cnode_args + call pm_verify_ptr(coder%temp%data%ptr(i),'Arg to new cnode') + enddo + endif + coder%vtop=coder%vtop-nargs+1 + coder%vstack(coder%vtop)=coder%temp + end subroutine make_code + + !=========================================================== + ! Make a combined argument list cnode, built as follows + ! vstack(ret0+1)..vstack(ret0+nret) var(extra0+1..extra0+nextra) + ! [ var(coder%mask) if mask ] vstack(args0+1..args0+nargs) + !=========================================================== + function make_arglist_cnode(coder,node,nret,ret0,nextra,extra0,mask,nargs,args0) result(arglist) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: node + integer,intent(in):: nret,ret0,nextra,extra0,nargs,args0 + logical,intent(in):: mask + type(pm_ptr):: arglist + integer:: i,j,totargs + totargs=nret+nextra+nargs+merge(1,0,mask) + !write(*,*) '####',nret,ret0,nextra,extra0,nargs,args0,mask + call make_code_stem(coder,node,cnode_is_arglist,totargs) + j=coder%temp%offset+cnode_args + coder%temp%data%ptr(j:j+nret-1)=coder%vstack(ret0+1:ret0+nret) + j=j+nret + coder%temp%data%ptr(j:j+nextra-1)=coder%var(extra0+1:extra0+nextra) + j=j+nextra + if(mask) then + coder%temp%data%ptr(j)=coder%var(coder%mask) + j=j+1 + endif + coder%temp%data%ptr(j:j+nargs-1)=coder%vstack(args0+1:args0+nargs) if(pm_debug_checks) then - if(coder%vtop-nargs<0) call pm_panic('make code') + if(j+nargs/=coder%temp%offset+5+totargs) call pm_panic('make_arglist') + do i=coder%temp%offset+5,coder%temp%offset+4+nargs + call pm_verify_ptr(coder%temp%data%ptr(i),'Arg to new cnode') + enddo endif + arglist=coder%temp + end function make_arglist_cnode + + !====================================================================== + ! Make a code tree node (cnode) with unfilled space for nargs arguments + !====================================================================== + subroutine make_code_stem(coder,node,ckind,nargs) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: node + integer,intent(in):: ckind,nargs + type(pm_ptr):: modl + integer:: ii coder%temp=pm_fast_newnc(coder%context,pm_pointer,& nargs+cnode_args) if(pm_debug_checks.and..false.) then if(coder%temp%data%ptr(coder%temp%offset)%offset& ==cnode_magic_no) then + write(*,*) '------------' call qdump_code_tree(coder,pm_null_obj,62,coder%temp,2) do ii=1,coder%vtop call qdump_code_tree(coder,pm_null_obj,63,coder%vstack(ii),2) @@ -8650,29 +6983,21 @@ subroutine make_code(coder,node,ckind,nargs) modl%data%ptr(modl%offset+modl_name) coder%temp%data%ptr(coder%temp%offset+3)=& node%data%ptr(node%offset+node_lineno) - coder%temp%data%ptr(coder%temp%offset+4)=& - node%data%ptr(node%offset+node_charno) - else - coder%temp%data%ptr(coder%temp%offset+2)=pm_null_obj - coder%temp%data%ptr(coder%temp%offset+3)=pm_null_obj - coder%temp%data%ptr(coder%temp%offset+4)=pm_null_obj - endif - coder%temp%data%ptr(coder%temp%offset+5:coder%temp%offset+4+nargs)=& - coder%vstack(coder%vtop-nargs+1:coder%vtop) - if(pm_debug_checks) then - do i=coder%temp%offset+5,coder%temp%offset+4+nargs - ! write(*,*) i-coder%temp%offset-3 - call pm_verify_ptr(coder%temp%data%ptr(i),'Arg to new cnode') - enddo + coder%temp%data%ptr(coder%temp%offset+4)=& + node%data%ptr(node%offset+node_charno) + else + coder%temp%data%ptr(coder%temp%offset+2)=pm_null_obj + coder%temp%data%ptr(coder%temp%offset+3)=pm_null_obj + coder%temp%data%ptr(coder%temp%offset+4)=pm_null_obj endif - coder%vtop=coder%vtop-nargs+1 - coder%vstack(coder%vtop)=coder%temp contains include 'fisnull.inc' include 'fnewnc.inc' include 'ftiny.inc' - end subroutine make_code + end subroutine make_code_stem + + !======================================= ! Check room on vstack !======================================= @@ -8769,7 +7094,6 @@ end subroutine swap_code !=========================================================== subroutine swap_and_dup_code(coder) type(code_state),intent(inout):: coder - type(pm_ptr):: temp coder%vstack(coder%vtop+1)=coder%vstack(coder%vtop-1) coder%vstack(coder%vtop-1)=coder%vstack(coder%vtop) coder%vtop=coder%vtop+1 @@ -8787,16 +7111,29 @@ end subroutine pushdown_code !====================================================== ! Swap top 2 items on the stack with single item below - ! ... a b c -> ... c a b + ! ... a b c -> ... b c a !====================================================== subroutine swap_code_2_1(coder) + type(code_state),intent(inout):: coder + type(pm_ptr):: temp + temp=coder%vstack(coder%vtop) + coder%vstack(coder%vtop)=coder%vstack(coder%vtop-2) + coder%vstack(coder%vtop-2)=coder%vstack(coder%vtop-1) + coder%vstack(coder%vtop-1)=temp + end subroutine swap_code_2_1 + + !====================================================== + ! Swap top item on the stack with 2 items below + ! ... a b c -> ... c a b + !====================================================== + subroutine swap_code_1_2(coder) type(code_state),intent(inout):: coder type(pm_ptr):: temp temp=coder%vstack(coder%vtop) coder%vstack(coder%vtop)=coder%vstack(coder%vtop-1) coder%vstack(coder%vtop-1)=coder%vstack(coder%vtop-2) coder%vstack(coder%vtop-2)=temp - end subroutine swap_code_2_1 + end subroutine swap_code_1_2 !================================= ! Pop value from vstack @@ -8889,242 +7226,7 @@ function top_word(coder) result(k) k=coder%wstack(coder%wtop) end function top_word - !================================= - ! Check cnode (debugging) - !================================= - subroutine check_cnode(ptr,n) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer(pm_p):: m - if(.not.pm_fast_vkind(ptr)==pm_pointer) then - write(*,*) 'vKind=',ptr%data%vkind - call pm_panic('cnode not ptr') - endif - if(ptr%data%ptr(ptr%offset)%offset/=cnode_magic_no) then - call pm_panic('bad cnode magic no') - endif - m=ptr%data%ptr(ptr%offset+1)%offset - if(m<1.or.m>cnode_num_kinds) & - call pm_panic('cnode bad kind') - if(n<0.or.n>pm_fast_esize(ptr)) & - call pm_panic('bad cnode offset') - contains - include 'fvkind.inc' - include 'fesize.inc' - end subroutine check_cnode - - !========================================== - ! Get argument n from cnode - !========================================== - function cnode_arg(ptr,n) result(val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - type(pm_ptr):: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+cnode_args+n-1) - end function cnode_arg - - !====================================== - ! Get element n from cnode - !====================================== - function cnode_get(ptr,n) result(val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - type(pm_ptr):: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+n) - end function cnode_get - - !==================================== - ! Set element n of cnode - !==================================== - subroutine cnode_set(coder,ptr,n,val) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - type(pm_ptr),intent(in):: val - if(debug_codegen) call check_cnode(ptr,n) - call pm_ptr_assign(coder%context,ptr,int(n,pm_ln),val) - end subroutine cnode_set - - ! ======================================== - ! Get element n from cnode as a number - !========================================= - function cnode_get_num(ptr,n) result(val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer:: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+n)%offset - end function cnode_get_num - - !============================================ - ! Get argument n from cnode as a number - !============================================ - function cnode_num_arg(ptr,n) result(val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer:: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+n+cnode_args-1)%offset - end function cnode_num_arg - - !========================================= - ! Get element n from cnode as a name - !========================================= - function cnode_get_name(ptr,n) result(val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer:: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+n)%offset - end function cnode_get_name - - !========================================== - ! Set element n in cnode to a new number - ! (must be number already) - !========================================== - subroutine cnode_set_num(ptr,n,val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer,intent(in):: val - if(debug_codegen) call check_cnode(ptr,n) - ptr%data%ptr(ptr%offset+n)%offset=val - end subroutine cnode_set_num - - !========================================== - ! Increment argument n from cnode - !========================================== - subroutine cnode_incr_num(ptr,n,val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer,intent(in):: val - if(debug_codegen) call check_cnode(ptr,n) - ptr%data%ptr(ptr%offset+n)%offset=& - ptr%data%ptr(ptr%offset+n)%offset+val - end subroutine cnode_incr_num - - !============================================== - ! Set given flags in an element of a cnode - ! (bitwise or of existing number) - !============================================== - subroutine cnode_set_flags(ptr,n,val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer,intent(in):: val - type(pm_ptr):: p - if(debug_codegen) then - call check_cnode(ptr,n) - p=ptr%data%ptr(ptr%offset+n) - if(pm_fast_vkind(p)/=pm_tiny_int.and.pm_fast_vkind(p)/=pm_null) then - write(*,*) 'vkind=',pm_fast_vkind(ptr) - call pm_panic('Set flags') - endif - if(cnode_get_kind(ptr)==cnode_is_var.and.& - n/=var_flags.or.& - cnode_get_kind(ptr)==cnode_is_cblock.and.n/=cblock_flags.or.& - cnode_get_kind(ptr)==cnode_is_call.and.n/=call_flags) then - call pm_panic('set flags') - endif - endif - ptr%data%ptr(ptr%offset+n)%offset=ior(& - ptr%data%ptr(ptr%offset+n)%offset,int(val,pm_p)) - contains - include 'fvkind.inc' - end subroutine cnode_set_flags - - !============================================ - ! Clear flags in element of a code code - ! (Bitwise clear of exiting number) - !============================================ - subroutine cnode_clear_flags(ptr,n,val) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n - integer,intent(in):: val - type(pm_ptr):: p - if(debug_codegen) then - call check_cnode(ptr,n) - p=ptr%data%ptr(ptr%offset+n) - if(pm_fast_vkind(p)/=pm_tiny_int.and.pm_fast_vkind(p)/=pm_null) then - write(*,*) 'vkind=',pm_fast_vkind(ptr) - call pm_panic('Set flags') - endif - if(cnode_get_kind(ptr)==cnode_is_var.and.& - n/=var_flags.or.& - cnode_get_kind(ptr)==cnode_is_cblock.and.n/=cblock_flags.or.& - cnode_get_kind(ptr)==cnode_is_call.and.n/=call_flags) then - call pm_panic('set flags') - endif - endif - ptr%data%ptr(ptr%offset+n)%offset=iand(& - ptr%data%ptr(ptr%offset+n)%offset,not(int(val,pm_p))) - contains - include 'fvkind.inc' - end subroutine cnode_clear_flags - - !=================================================================== - ! Check all given flags in a given element of a cnode are clear - ! (bitwise and of extisting number and check for zero) - !=================================================================== - function cnode_flags_clear(ptr,n,flags) result(ok) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n,flags - logical:: ok - integer:: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+n)%offset - ok=iand(flags,val)==0 - end function cnode_flags_clear - - !============================================================ - ! Check all given flags in an element of a cnode are set - ! (bitwise and) - !============================================================ - function cnode_flags_set(ptr,n,flags) result(ok) - type(pm_ptr),intent(in):: ptr - integer,intent(in):: n,flags - logical:: ok - integer(pm_p):: val - if(debug_codegen) call check_cnode(ptr,n) - val=ptr%data%ptr(ptr%offset+n)%offset - ok=iand(flags,int(val))==flags - end function cnode_flags_set - - !========================================== - ! Return kind of a cnode - !========================================== - function cnode_get_kind(ptr) result(n) - type(pm_ptr),intent(in):: ptr - integer:: n - if(pm_debug_checks) call check_cnode(ptr,0) - n=ptr%data%ptr(ptr%offset+1)%offset - end function cnode_get_kind - - !======================================== - ! Return number of arguments of a cnode - !======================================== - function cnode_numargs(ptr) result(n) - type(pm_ptr),intent(in):: ptr - integer:: n - if(debug_codegen) call check_cnode(ptr,0) - n=pm_fast_esize(ptr)-cnode_args+1 - contains - include 'fesize.inc' - end function cnode_numargs - - - !======================================== - ! Does a cblock contain any communicating - ! operations? - !======================================== - function cblock_has_comm(cblock) result(ok) - type(pm_ptr):: cblock - logical:: ok - ok=(iand(cnode_get_num(cblock,cblock_flags),& - cblock_is_comm)/=0) - end function cblock_has_comm - - + !===================================== ! Dump a cnode tree (debugging) !===================================== @@ -9149,6 +7251,9 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) call pm_dump_tree(coder%context,iunit,node,2) return endif + elseif(node%data%ptr(node%offset)%offset/=cnode_magic_no) then + write(iunit,*) spaces(1:depth*2),'Not cnode' + return elseif(cnode_get_kind(node)<1.or.cnode_get_kind(node)>cnode_num_kinds) then write(iunit,*) spaces(1:depth*2),'Bad kind' return @@ -9180,10 +7285,9 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) else call pm_name_string(coder%context,int(p%offset),str) endif - write(iunit,'(A,A," Idx=",I4," Dep=",I4," Chng=",L1," Flags=",I4,"offset=",I6,I6,L)') & + write(iunit,'(A,A," Idx=",I4," Chng=",L1," Flags=",I4,"offset=",I6,I6,L)') & spaces(1:depth*2),trim(str),& cnode_get_num(node,var_index),& - cnode_get_num(node,var_par_depth),& cnode_flags_set(node,var_flags,var_is_changed),& cnode_get_num(node,var_flags),node%offset,node%data%hash,marked(node) if(.not.pm_fast_isnull(rvec)) then @@ -9193,13 +7297,13 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) write(iunit,*) spaces(1:depth*2),' Unresolved!!' else write(iunit,*) spaces(1:depth*2),' Resolved:',i,& - trim(pm_typ_as_string(coder%context,i)) + trim(pm_type_as_string(coder%context,i)) endif endif case(cnode_is_const) call pm_dump_tree(coder%context,iunit,cnode_arg(node,1),depth) !!$ write(iunit,*) spaces(1:depth*2),& -!!$ trim(pm_typ_as_string(coder%context,& +!!$ trim(pm_type_as_string(coder%context,& !!$ cnode_get_num(node,node_args+1))) case(cnode_is_call) p=cnode_get(node,call_sig) @@ -9210,24 +7314,29 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) 'Call "',trim(sym_names(-p%offset)),'":',& cnode_get_num(node,call_index) else - p=pm_dict_key(coder%context,coder%sig_cache,& - int(p%offset,pm_ln)) - call pm_name_string(coder%context,& - p%data%i(p%offset+pm_fast_esize(p)),str) - write(iunit,'(A,A,A,A," Idx=",I4," Depth=",I4," Flags=",I4,"<",I4,">")') & + write(iunit,*) 'ISS>',p%offset + if(p%offset==0) then + str='varcall' + else + p=pm_dict_key(coder%context,coder%sig_cache,& + int(p%offset,pm_ln)) + call pm_name_string(coder%context,& + p%data%i(p%offset+pm_fast_esize(p)),str) + endif + write(iunit,'(A,A,A,A," Idx=",I4," Flags=",I4,"<",I4,">")') & spaces(1:depth*2),'Call (',trim(str),') (',& cnode_get_num(node,call_index),& - cnode_get_num(node,call_par_depth),cnode_get_num(node,call_flags),po + cnode_get_num(node,call_flags),po endif if(.not.pm_fast_isnull(rvec)) then i= rvec%data%i(rvec%offset+& cnode_get_num(node,call_index)) if(i<0) then - if(i==spsig_thru) then + if(i==sp_sig_link) then write(iunit,*) spaces(1:depth*2),' sp_sig_thru' - elseif(i==spsig_dup) then + elseif(i==sp_sig_dup) then write(iunit,*) spaces(1:depth*2),' sp_sig_dup' - elseif(i==spsig_noop) then + elseif(i==sp_sig_noop) then write(iunit,*) spaces(1:depth*2),' sp_sig_noop' elseif(p%offset>=0) then write(iunit,*) spaces(1:depth*2),' Unresolved Sig!!' @@ -9256,35 +7365,26 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) if(.not.pm_fast_isnull(cnode_get(node,call_var))) then write(iunit,*) spaces(1:depth*2),'Callvar:' call qdump_code_tree(coder,rvec,iunit,& - cnode_get(node,call_var),depth+1) + cnode_get(node,call_var),depth+1) endif - + write(iunit,*) spaces(1:depth*2),')' case(cnode_is_builtin) - write(iunit,*) spaces(1:depth*2),'Builtin ',& - op_names(cnode_get_num(node,cnode_args)),& - cnode_get_num(node,cnode_args+1),'(' - if(.not.pm_fast_isnull(cnode_get(node,bi_rcode))) then - call qdump_code_tree(coder,rvec,iunit,& - cnode_get(node,bi_rcode),depth+1) + if(cnode_get_num(node,cnode_args)>=0) then + write(iunit,*) spaces(1:depth*2),'Builtin ',& + op_names(cnode_get_num(node,cnode_args)),& + cnode_get_num(node,cnode_args+1),'(' + else + write(iunit,*) spaces(1:depth*2),'Fold ',& + (cnode_get_num(node,cnode_args)),& + cnode_get_num(node,cnode_args+1),'(' endif write(iunit,*) spaces(1:depth*2),')' case(cnode_is_proc) write(iunit,'(A,A,i2,A,i2,A,i2,A,i3,A,i3,A)') spaces(1:depth*2),& 'Proc [nargs=',& - cnode_get_num(node,pr_nargs),',nkeys=',& - cnode_get_num(node,pr_nkeys),',nret=',cnode_get_num(node,pr_nret),& + cnode_get_num(node,pr_nargs),',nret=',cnode_get_num(node,pr_nret),& ',ncalls=',cnode_get_num(node,pr_ncalls),',flags=',cnode_get_num(node,pr_flags),'] (' - if(cnode_flags_set(node,pr_flags,proc_is_comm)) & - write(iunit,*) spaces(1:depth*2+1),'[loop]' - if(cnode_flags_set(node,pr_flags,proc_is_each_proc)) & - write(iunit,*) spaces(1:depth*2+1),'[each]' - if(cnode_flags_set(node,pr_flags,proc_is_dup_each)) & - write(iunit,*) spaces(1:depth*2+1),'[dup-each]' - if(cnode_flags_set(node,pr_flags,proc_is_thru_each)) & - write(iunit,*) spaces(1:depth*2+1),'[thru-each]' - if(cnode_flags_set(node,pr_flags,proc_is_empty_each)) & - write(iunit,*) spaces(1:depth*2+1),'[empty-each]' call qdump_code_tree(coder,rvec,iunit,& cnode_arg(node,1),depth+1) write(iunit,*) spaces(1:depth*2),')' @@ -9299,41 +7399,30 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) write(iunit,*) spaces(1:depth*2+1),'[impure]' if(cnode_flags_set(node,cnode_args+2,proc_is_not_inlinable)) & write(iunit,*) spaces(1:depth*2+1),'[not inlinable]' - if(cnode_flags_set(node,cnode_args+2,proc_is_not_pure_each)) & - write(iunit,*) spaces(1:depth*2+1),'[not pure each]' call qdump_code_tree(coder,cnode_arg(node,2),& iunit,cnode_arg(node,1),depth+1) - write(iunit,*) spaces(1:depth*2),')' - case(cnode_is_arglist) - write(iunit,*) spaces(1:depth*2),'Var Sig List(',cnode_numargs(node) - if(cnode_flags_set(node,cnode_args+1,proc_is_var)) then - do i=5,cnode_numargs(node),2 - write(iunit,*) spaces(1:depth*2),& - trim(pm_name_as_string(coder%context,& - cnode_get_name(node,cnode_args+i-1))),'-->',& - cnode_get_num(node,cnode_args+i) - enddo - else - write(iunit,*) spaces(1:depth*2),'Sig List(',cnode_numargs(node) - do i=2,cnode_numargs(node),2 - write(iunit,*) spaces(1:depth*2),trim(pm_typ_as_string(coder%context,& - cnode_get_num(node,cnode_args+i-1))) - call qdump_code_tree(coder,rvec,iunit,cnode_arg(node,i+1),depth+1) - enddo - endif - write(iunit,*) spaces(1:depth*2),')' - case(cnode_is_any_sig) - write(iunit,*) spaces(1:depth*2),'Any signature (' - do i=1,cnode_numargs(node) - call pm_dump_tree(coder%context,iunit,cnode_arg(node,i),depth+1) - enddo - write(iunit,*) spaces(1:depth*2),')' - case(cnode_is_autoconv_sig) - write(iunit,*) spaces(1:depth*2),'Auto convert signature (' - do i=1,cnode_numargs(node) - call pm_dump_tree(coder%context,iunit,cnode_arg(node,i),depth+1) - enddo - write(iunit,*) spaces(1:depth*2),')' + write(iunit,*) spaces(1:depth*2),')' + case(cnode_is_arglist) + write(iunit,*) spaces(1:depth*2),'Var Sig List(',cnode_numargs(node) + write(iunit,*) spaces(1:depth*2),'Sig List(',cnode_numargs(node) + do i=2,cnode_numargs(node),2 + write(iunit,*) spaces(1:depth*2),trim(pm_type_as_string(coder%context,& + cnode_get_num(node,cnode_args+i-1))) + call qdump_code_tree(coder,rvec,iunit,cnode_arg(node,i+1),depth+1) + enddo + write(iunit,*) spaces(1:depth*2),')' + case(cnode_is_any_sig) + write(iunit,*) spaces(1:depth*2),'Any signature (' + do i=1,cnode_numargs(node) + call pm_dump_tree(coder%context,iunit,cnode_arg(node,i),depth+1) + enddo + write(iunit,*) spaces(1:depth*2),')' + case(cnode_is_autoconv_sig) + write(iunit,*) spaces(1:depth*2),'Auto convert signature (' + do i=1,cnode_numargs(node) + call pm_dump_tree(coder%context,iunit,cnode_arg(node,i),depth+1) + enddo + write(iunit,*) spaces(1:depth*2),')' case default write(iunit,*) spaces(1:depth*2),'<>' end select @@ -9345,409 +7434,6 @@ recursive subroutine qdump_code_tree(coder,rvec,iunit,node,depth) include 'fisname.inc' end subroutine qdump_code_tree - subroutine print_all_sigs(context,iunit,sig_cache,proc_cache) - type(pm_context),pointer:: context - integer,intent(in):: iunit - type(pm_ptr),intent(in):: sig_cache,proc_cache - integer:: i - - do i=1,pm_dict_size(context,proc_cache) - call print_sig(context,iunit,sig_cache,proc_cache,i) - enddo - - end subroutine print_all_sigs - - subroutine print_sig(context,iunit,sig_cache,proc_cache,n) - type(pm_context),pointer:: context - integer,intent(in):: iunit,n - type(pm_ptr),intent(in):: sig_cache,proc_cache - integer:: kind,i - type(pm_ptr):: cnode,key - key=pm_dict_key(context,proc_cache,int(n,pm_ln)) - cnode=pm_dict_val(context,proc_cache,int(n,pm_ln)) - if(pm_fast_vkind(cnode)==pm_pointer) then - kind=cnode_get_kind(cnode) - !write(*,*) 'KinD=',kind - select case(kind) - case(cnode_is_resolved_proc) - write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//& - trim(pm_name_as_string(context,& - cnode_get_name(cnode_arg(cnode,1),pr_name)))//' {' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_recursive)) & - write(iunit,'(a)') ' [recursive]' - if(cnode_flags_set(cnode,cnode_args+2,proc_unfinished)) & - write(iunit,'(a)') ' [unfinished]' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_impure)) & - write(iunit,'(a)') ' [impure]' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_not_inlinable)) & - write(iunit,'(a)') ' [not inlinable]' - if(cnode_flags_set(cnode,cnode_args+2,proc_has_for)) & - write(iunit,'(a)') ' [has for]' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_not_pure_each)) & - write(iunit,'(a)') ' [not pure each]' - if(cnode_flags_set(cnode,cnode_args+2,proc_has_vkeys)) & - write(iunit,'(a)') ' [has vkeys]' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_dcomm)) & - write(iunit,'(a)') ' [dcomm]' - if(cnode_flags_set(cnode,cnode_args+2,proc_is_variant)) & - write(iunit,'(a)') ' [variant]' - if(cnode_flags_set(cnode,cnode_args+2,proc_needs_par)) & - write(iunit,'(a)') ' [needs par]' - call print_proc_cnode(context,iunit,cnode_arg(cnode,2),& - sig_cache,cnode_arg(cnode,1)) - write(iunit,'(a)') '}' - case(cnode_is_arglist) - write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'{' - if(cnode_flags_set(cnode,cnode_args+1,proc_is_var)) then - do i=5,cnode_numargs(cnode),2 - write(iunit,'(a)') trim(pm_name_as_string(context,& - cnode_get_name(cnode,cnode_args+i-1)))//' --> ['//& - trim(pm_int_as_string(cnode_get_num(cnode,cnode_args+i)))//']' - enddo - else - do i=3,cnode_numargs(cnode),2 - write(iunit,'(a)') ' '//& - trim(pm_name_as_string(context,& - key%data%i(key%offset+pm_fast_esize(key))))//& - trim(pm_typ_as_string(context,& - cnode_num_arg(cnode,i)))//' {' - call print_proc_cnode(context,iunit,pm_null_obj,& - sig_cache,cnode_arg(cnode,i+1)) - write(iunit,'(a)') ' }' - enddo - endif - write(iunit,'(a)') '}' - case(cnode_is_any_sig) - write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'Any{' - do i=1,cnode_numargs(cnode) - call pm_dump_tree(context,iunit,cnode_arg(cnode,i),2) - enddo - write(iunit,'(a)') '}' - case(cnode_is_autoconv_sig) - write(iunit,'(a)') '['//trim(pm_int_as_string(n))//']'//'Auto {' - do i=1,cnode_numargs(cnode) - call pm_dump_tree(context,iunit,cnode_arg(cnode,i),2) - enddo - write(iunit,'(a)') '}' - end select - else - call pm_dump_tree(context,iunit,cnode,1) - endif - contains - include 'fesize.inc' - include 'fvkind.inc' - end subroutine print_sig - - subroutine print_proc_cnode(context,iunit,rvec,sig_cache,cnode) - type(pm_context),pointer:: context - integer,intent(in):: iunit - type(pm_ptr),intent(in):: rvec,sig_cache,cnode - integer:: flags - if(cnode_get_kind(cnode)==cnode_is_builtin) then - write(iunit,'(a)') ' Builtin '//& - op_names(cnode_get_num(cnode,cnode_args))//& - pm_int_as_string(cnode_get_num(cnode,cnode_args+1))//'{' - if(.not.pm_fast_isnull(cnode_get(cnode,bi_rcode))) then - call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_get(cnode,bi_rcode),4) - endif - write(iunit,'(a)') ' }' - else - write(iunit,'(A,i2,A,i2,A,i2,A,i3,A)') & - ' [nargs=',& - cnode_get_num(cnode,pr_nargs),',nkeys=',& - cnode_get_num(cnode,pr_nkeys),',nret=',cnode_get_num(cnode,pr_nret),& - ',ncalls=',cnode_get_num(cnode,pr_ncalls),']' - if(cnode_flags_set(cnode,pr_flags,proc_is_comm)) & - write(iunit,'(a)') ' [loop]' - if(cnode_flags_set(cnode,pr_flags,proc_is_each_proc)) & - write(iunit,'(a)') ' [each]' - if(cnode_flags_set(cnode,pr_flags,proc_is_dup_each)) & - write(iunit,'(a)') ' [dup-each]' - if(cnode_flags_set(cnode,pr_flags,proc_is_thru_each)) & - write(iunit,'(a)') ' [thru-each]' - if(cnode_flags_set(cnode,pr_flags,proc_is_empty_each)) & - write(iunit,'(a)') ' [empty-each]' - flags=cnode_get_kind(cnode) - !write(*,*) 'Kind=',flags - call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode_arg(cnode,1),4) - endif - contains - include 'fisnull.inc' - end subroutine print_proc_cnode - - subroutine print_cblock_cnode(context,iunit,rvec,sig_cache,cnode,depth) - type(pm_context),pointer:: context - integer,intent(in):: iunit,depth - type(pm_ptr),intent(in):: rvec,sig_cache,cnode - type(pm_ptr)::p - p=cnode_get(cnode,cblock_first_call) - do while(.not.pm_fast_isnull(p)) - call print_call_cnode(context,iunit,rvec,sig_cache,p,depth) - p=cnode_get(p,call_link) - enddo - contains - include 'fisnull.inc' - end subroutine print_cblock_cnode - - subroutine print_call_cnode(context,iunit,rvec,sig_cache,cnode,depth) - type(pm_context),pointer:: context - integer,intent(in):: iunit,depth - type(pm_ptr),intent(in):: rvec,sig_cache,cnode - integer:: signo,name,i,j,k,nret,nargs,modl,line - type(pm_ptr):: p,args,amps - character(len=120):: str,location - signo=cnode_get_num(cnode,call_sig) - if(signo<0) then - str=repeat(' ',depth)//pm_name_as_string(context,-signo) - i=len_trim(str)+1 - if(.not.pm_fast_isnull(rvec)) then - k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) - if(k>=0) then - call append_to_line(iunit,str,i,& - '['//trim(pm_int_as_string(k))//'] ',.false.,depth) - endif - endif - else - p=pm_dict_key(context,sig_cache,& - int(signo,pm_ln)) - name=p%data%i(p%offset+pm_fast_esize(p)) - if(.not.pm_fast_isnull(cnode_get(cnode,call_var))) then - str=repeat(' ',depth)//'call *(' - i=depth+7 - call print_value_cnode(context,iunit,rvec,sig_cache,& - cnode_get(cnode,call_var),depth,str,i) - call append_to_line(iunit,str,i,') ',.false.,depth) - elseif(pm_fast_isnull(rvec)) then - str=repeat(' ',depth)//'call '//pm_name_as_string(context,name) - else - k=rvec%data%i(rvec%offset+cnode_get_num(cnode,call_index)) - if(k==spsig_thru) then - str=repeat(' ',depth)//'call [thru]'//& - pm_name_as_string(context,name) - elseif(k==spsig_dup) then - str=repeat(' ',depth)//'call [dup]'//& - pm_name_as_string(context,name) - elseif(k==spsig_noop) then - str=repeat(' ',depth)//'call [noop]'//& - pm_name_as_string(context,name) - elseif(k<0) then - str=repeat(' ',depth)//'call [??]'//& - pm_name_as_string(context,name) - else - str=repeat(' ',depth)//'call '//'['//trim(pm_int_as_string(k))//']'& - //pm_name_as_string(context,name) - endif - endif - i=len_trim(str) - call append_proc_call_flags(iunit,str,i,cnode_get_num(cnode,call_flags),.false.,depth) - i=i+1 - end if - - args=cnode_get(cnode,call_args) - nargs=cnode_numargs(args) - nret=cnode_get_num(cnode,call_nret) - amps=cnode_get(cnode,call_amp) - amps=pm_name_val(context,int(amps%offset)) - - if(nret>0) then - do j=1,nret - call print_value_cnode(context,iunit,rvec,sig_cache,cnode_arg(args,j),depth,str,i) - i=i+1 - enddo - call append_to_line(iunit,str,i,'<- ',.false.,depth) - endif - k=0 - do j=nret+1,nargs - if(.not.pm_fast_isnull(amps)) then - if(amps%data%i(amps%offset+k)==i-nret) then - call append_to_line(iunit,str,i,'&',.false.,depth) - k=min(k+1,pm_fast_esize(amps)) - endif - endif - call print_value_cnode(context,iunit,rvec,sig_cache,cnode_arg(args,j),depth,str,i) - i=i+1 - enddo - modl=cnode_get_num(cnode,cnode_modl_name) - line=cnode_get_num(cnode,cnode_lineno) - location=trim(pm_name_as_string(context,modl))//':'//pm_int_as_string(line) - str(len(str)-len_trim(location)+1:)=location - write(iunit,'(a)') str - - contains - include 'fesize.inc' - include 'fisnull.inc' - end subroutine print_call_cnode - - subroutine print_value_cnode(context,iunit,rvec,sig_cache,cnode,depth,str,i) - type(pm_context),pointer:: context - integer,intent(in):: iunit,depth - type(pm_ptr),intent(in):: rvec,sig_cache,cnode - character(len=*),intent(inout):: str - integer,intent(inout):: i - integer:: kind,name,tno - kind=pm_fast_vkind(cnode) - if(kind==pm_tiny_int) then - call append_to_line(iunit,str,i,& - trim(pm_int_as_string(int(cnode%offset))),.false.,depth) - elseif(kind==pm_null) then - call append_to_line(iunit,str,i,& - 'NULL',.false.,depth) - elseif(kind==pm_name) then - call append_to_line(iunit,str,i,& - "'"//trim(pm_name_as_string(context,int(cnode%offset))),.false.,depth) - elseif(kind==pm_type) then - call append_to_line(iunit,str,i,& - '<'//trim(pm_typ_as_string(context,int(cnode%offset)))//'>',.false.,depth) - else - kind=cnode_get_kind(cnode) - select case(kind) - case(cnode_is_var) - name=cnode_get_num(cnode,var_name) - if(name==0) then - call append_to_line(iunit,str,i,'#'//& - trim(pm_int_as_string(cnode_get_num(cnode,var_index))),.false.,depth) - else - call append_quoted_to_line(iunit,str,i,& - trim(pm_name_as_string(context,name)),.false.,depth) - endif - if(.not.pm_fast_isnull(rvec)) then - tno=rvec%data%i(rvec%offset+cnode_get_num(cnode,var_index)) - call append_to_line(iunit,str,i,& - '['//trim(pm_typ_as_string(context,tno))//']',.false.,depth) - endif - case(cnode_is_const) - call append_to_line(iunit,str,i,& - trim(pm_value_as_string(context,cnode_arg(cnode,1))),.false.,depth) - case(cnode_is_cblock) - call append_to_line(iunit,str,i,'{',.true.,depth) - call print_cblock_cnode(context,iunit,rvec,sig_cache,cnode,min(50,depth+2)) - str=' ' - str(depth+1:depth+1)='}' - i=depth+1 - end select - endif - contains - include 'fvkind.inc' - include 'fisnull.inc' - end subroutine print_value_cnode - - subroutine append_proc_call_flags(iunit,str,i,flags,proc_flags,depth) - integer,intent(in):: iunit - character(len=*),intent(inout):: str - integer,intent(inout):: i - integer,intent(in):: flags - logical,intent(in):: proc_flags - integer,intent(in):: depth - if(iand(flags,call_is_comm)/=0) then - call append_to_line(iunit,str,i,'%',.false.,depth) - endif - if(flags/=iand(flags,call_is_comm)) then - call append_to_line(iunit,str,i,'<',.false.,depth) - if(iand(flags,proc_run_complete)/=0) then - call append_to_line(iunit,str,i,'C',.false.,depth) - endif - if(iand(flags,proc_run_local)/=0) then - call append_to_line(iunit,str,i,'L',.false.,depth) - endif - if(iand(flags,proc_run_shared)/=0) then - call append_to_line(iunit,str,i,'S',.false.,depth) - endif - if(iand(flags,proc_run_always)/=0) then - call append_to_line(iunit,str,i,'A',.false.,depth) - endif - if(iand(flags,proc_inline)/=0) then - call append_to_line(iunit,str,i,'I',.false.,depth) - endif - if(iand(flags,proc_no_inline)/=0) then - call append_to_line(iunit,str,i,'N',.false.,depth) - endif - if(proc_flags) then - if(iand(flags,proc_is_open)/=0) then - call append_to_line(iunit,str,i,'o',.false.,depth) - endif - if(iand(flags,proc_is_each_proc)/=0) then - call append_to_line(iunit,str,i,'e',.false.,depth) - endif - if(iand(flags,proc_is_cond)/=0) then - call append_to_line(iunit,str,i,'c',.false.,depth) - endif - if(iand(flags,proc_is_uncond)/=0) then - call append_to_line(iunit,str,i,'u',.false.,depth) - endif - if(iand(flags,proc_is_abstract)/=0) then - call append_to_line(iunit,str,i,'a',.false.,depth) - endif - else - if(iand(flags,call_is_fixed)/=0) then - call append_to_line(iunit,str,i,'f',.false.,depth) - endif - if(iand(flags,call_is_assign_call)/=0) then - call append_to_line(iunit,str,i,'a',.false.,depth) - endif - if(iand(flags,call_is_vararg)/=0) then - call append_to_line(iunit,str,i,'v',.false.,depth) - endif - if(iand(flags,call_inline_when_compiling)/=0) then - call append_to_line(iunit,str,i,'i',.false.,depth) - endif - if(iand(flags,call_dup_result)/=0) then - call append_to_line(iunit,str,i,'d',.false.,depth) - endif - if(iand(flags,call_is_cond)/=0) then - call append_to_line(iunit,str,i,'c',.false.,depth) - endif - if(iand(flags,call_is_no_touch)/=0) then - call append_to_line(iunit,str,i,'n',.false.,depth) - endif - if(iand(flags,call_is_unlabelled)/=0) then - call append_to_line(iunit,str,i,'u',.false.,depth) - endif - endif - call append_to_line(iunit,str,i,'>',.false.,depth) - end if - end subroutine append_proc_call_flags - - subroutine append_quoted_to_line(iunit,str,i,part,break,depth) - integer,intent(in):: iunit - character(len=*),intent(inout):: str - integer,intent(inout):: i - character(len=*),intent(in):: part - logical,intent(in):: break - integer,intent(in):: depth - integer:: first - first=iachar(part(1:1)) - if(first>=iachar('a').and.first<=iachar('z').or.& - first>=iachar('A').and.first<=iachar('Z')) then - call append_to_line(iunit,str,i,part,break,depth) - else - call append_to_line(iunit,str,i,"'"//trim(part)//"'",break,depth) - endif - end subroutine append_quoted_to_line - - subroutine append_to_line(iunit,str,i,part,break,depth) - integer,intent(in):: iunit - character(len=*),intent(inout):: str - integer,intent(inout):: i - character(len=*),intent(in):: part - logical,intent(in):: break - integer,intent(in):: depth - integer:: n - n=len(part) - if(i+n>len(str)) then - write(iunit,'(a)') str(1:min(len(str),i)) - str=repeat(' ',depth+1)//part(1:min(len(str)-depth-1,n)) - i=depth+1+n - else - str(i+1:i+n)=part(1:n) - i=i+n - endif - if(break.or.i>len(str)) then - write(iunit,'(a)') str(1:i) - i=1 - endif - end subroutine append_to_line - - !======================================== ! Return the name of a given signature !======================================== @@ -9756,8 +7442,12 @@ function sig_name(coder,m) result(name) integer,intent(in):: m integer:: name type(pm_ptr):: key - key=pm_dict_key(coder%context,coder%sig_cache,int(m,pm_ln)) - name=key%data%i(key%offset+pm_fast_esize(key)) + if(m==0) then + name=sym_var + else + key=pm_dict_key(coder%context,coder%sig_cache,int(m,pm_ln)) + name=key%data%i(key%offset+pm_fast_esize(key)) + endif contains include 'fesize.inc' end function sig_name @@ -9769,7 +7459,11 @@ function sig_name_str(coder,m) result(str) type(code_state),intent(in):: coder integer,intent(in):: m character(len=100):: str - call pm_name_string(coder%context,sig_name(coder,m),str) + if(m==0) then + str='var' + else + call pm_name_string(coder%context,sig_name(coder,m),str) + endif end function sig_name_str !============================================ @@ -9796,16 +7490,10 @@ subroutine dump_sigs(coder,iunit) ',nret=',sig%data%i(sig%offset+pm_fast_esize(sig)-1),') (' if(pm_fast_vkind(code)==pm_int) then call pm_dump_tree(coder%context,iunit,code,2) - elseif(cnode_flags_set(code,cnode_args+1,proc_is_var)) then - do j=3,cnode_numargs(code),2 - write(iunit,*) trim(pm_name_as_string(coder%context,& - cnode_get_name(code,j+cnode_args-1))) - write(iunit,*) cnode_get_num(code,j+cnode_args) - enddo else do j=3,cnode_numargs(code),2 typ=cnode_arg(code,j) - write(iunit,*) 'Type:',trim(pm_typ_as_string(coder%context,& + write(iunit,*) 'Type:',trim(pm_type_as_string(coder%context,& int(typ%offset))) write(iunit,*) 'Code:',j,cnode_numargs(code) call qdump_code_tree(coder,pm_null_obj,iunit,cnode_arg(code,j+1),2) @@ -9876,12 +7564,12 @@ function sig_as_str(coder,name,ampl,numargs,nret,flags,args) result(str) endif call pm_name_string(coder%context,int(name%offset),str(n:)) n=len_trim(str)+1 - if(iand(flags,call_is_comm)/=0) then + if(iand(flags,proccall_is_comm)/=0) then str(n:n)='%' n=n+1 endif if(present(args).and.& - iand(flags,proc_is_comm)/=0) then + iand(flags,proccall_is_comm)/=0) then str(n:n)='(' n=n+1 do i=num_comm_args+1,nargs @@ -9939,11 +7627,6 @@ function sig_as_str(coder,name,ampl,numargs,nret,flags,args) result(str) endif endif str(n:n)=')' - if(.not.present(args).and.& - iand(flags,proc_is_comm)/=0& - .and.coder%par_state>=par_state_cond) then - str(n+2:)='Conditional context' - endif contains include 'fisnull.inc' @@ -9967,10 +7650,9 @@ subroutine code_error(coder,node,message,name,warn) type(code_state):: coder type(pm_ptr),intent(in):: node character(len=*):: message - type(pm_ptr),intent(in),optional:: name + integer,intent(in),optional:: name logical,intent(in),optional:: warn character(len=256):: str - type(pm_ptr):: modname if(pm_main_process) then write(*,*) if(.not.pm_fast_isnull(node)) then @@ -9979,10 +7661,10 @@ subroutine code_error(coder,node,message,name,warn) endif if(.not.present(warn)) then if(present(name)) then - call pm_name_string(coder%context,int(name%offset),str) - str=trim(pm_opts%error)//trim(message)//' '//trim(str) + call pm_name_string(coder%context,name,str) + str=trim(pm_opts%error)//' '//trim(message)//' '//trim(str) else - str=trim(pm_opts%error)//message + str=trim(pm_opts%error)//' '//message endif write(*,'(A)') trim(str) else @@ -10008,8 +7690,7 @@ subroutine cnode_error(coder,node,message,name,warn) character(len=*):: message type(pm_ptr),intent(in),optional:: name logical,intent(in),optional:: warn - character(len=256):: str - type(pm_ptr):: modname + character(len=2048):: str if(pm_main_process) then call pm_error_header(coder%context,& cnode_get_name(node,cnode_modl_name),& @@ -10019,9 +7700,9 @@ subroutine cnode_error(coder,node,message,name,warn) str=message elseif(present(name)) then call pm_name_string(coder%context,int(name%offset),str) - str=trim(pm_opts%error)//trim(message)//' '//trim(str) + str=trim(pm_opts%error)//' '//trim(message)//' '//trim(str) else - str=trim(pm_opts%error)//trim(message) + str=trim(pm_opts%error)//' '//trim(message) endif write(*,'(A)') trim(str) endif @@ -10034,7 +7715,5 @@ subroutine cnode_error(coder,node,message,name,warn) end subroutine cnode_error - - end module pm_codegen diff --git a/src/deadcode.f90 b/src/deadcode.f90 new file mode 100644 index 0000000..2529fc3 --- /dev/null +++ b/src/deadcode.f90 @@ -0,0 +1,241 @@ +! +! PM (Parallel Models) Programming Language +! +! Released under the MIT License (MIT) +! +! Copyright (c) Tim Bellerby, 2024 +! +! Permission is hereby granted, free of charge, to any person obtaining a copy +! of this software and associated documentation files (the "Software"), to deal +! in the Software without restriction, including without limitation the rights +! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is +! furnished to do so, subject to the following conditions: +! +! The above copyright notice and this permission notice shall be included in +! all copies or substantial portions of the Software. +! +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +! THE SOFTWARE. + +! Inter and intra-procedural dead code elimination + +module pm_deadcode + use pm_sysdep + use pm_compbase + use pm_kinds + use pm_memory + use pm_hash + use pm_lib + use pm_symbol + use pm_types + use pm_parser + use pm_cnodes + use pm_codegen + implicit none + + logical,parameter:: debug_deadcode=.false. + +contains + + recursive subroutine deadcode_proc(coder,proc) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: proc + + + ! Make sure everything called from here is analysed first + ! as we will need the parameter liveliness information + + + end subroutine deadcode_proc + + recursive subroutine find_procs_for_cblock(coder,cblock,rvec) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,rvec,procs + type(pm_ptr):: p + p=cnode_get(cblock,cblock_first_call) + do while(.not.pm_fast_isnull(p)) + call find_procs_for_call(coder,p,rvec) + p=cblock_get(p,call_link) + end do + contains + include 'fisnull.inc' + end subroutine find_procs_for_cblock + + recursive subroutine find_procs_for_call(coder,callnode,rvec) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,rvec + integer:: sig,idx,i + type(pm_ptr):: procnode,args,arg + sig=cnode_get_num(callnode,call_sig) + if(sig>0) then + idx=cnode_get_num(callnode,call_index) + idx=rvec%data%i(rvec%offset+idx) + procnode=pm_dict_val(coder%context,coder%sig_cache,int(idx,pm_ln)) + if(pm_fast_isnull(cnode_arg(procnode,5))) then + call deadcode_proc(coder,procnode) + endif + else + args=cnode_get(callnode,call_args) + do i=1,cnode_numargs(args) + arg=cnode_arg(args,i) + if(pm_fast_vkind(arg)==pm_pointer) then + if(cnode_kind(arg)==cnode_is_cblock) then + call find_procs_for_cblock(coder,arg,rvec) + endif + endif + enddo + endif + end subroutine find_procs_for_call + + subroutine dce_cblock(coder,cblock,rvec,alive,nested,eliminate) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock,rvec + logical,dimension(*):: alive + logical,intent(in):: nested,eliminate + type(pm_ptr):: p + p=cnode_get(cblock,cblock_first_call) + do while(.not.pm_fast_isnull(p)) + call dce_call(coder,p,rvec,alive,eliminate) + p=cblock_get(p,call_link) + end do + contains + include 'fisnull.inc' + end subroutine dce_cblock + + subroutine dce_call(coder,callnode,rvec,alive,nested,eliminate) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,rvec + logical,dimension(*):: alive + logical,intent(in):: nested,eliminate + + args=cnode_get(callnode,call_args) + if(sig>0) then + + else + select case(-sig) + case(sym_if,sym_if_invar) + do while(.not.pm_fast_isnull(p)) + call vpush(coder,p) + enddo + case(sym_while) + + case(sym_until,sym_each) + if(.not.nested) then + + endif + + case default: + + outs_alive=.false. + do i=1,nret + arg=cnode_arg(args,i) + idx=cnode_get_num(arg,var_index) + outs_alive=outs_alive.or.alive(idx) + alive(idx)=.false. + enddo + has_blocks=.false. + do i=nret+1,cnode_numargs(args) + arg=cnode_arg(args,i) + if(pm_fast_vkind(arg)==pm_pointer) then + kind=cnode_kind(arg) + if(kind==cnode_is_var) then + idx=cnode_get_num(arg,var_index) + alive(idx)=.true. + elseif(kind==cnode_is_cblock) then + has_blocks=.true. + endif + endif + enddo + if(has_blocks) then + do i=1,cnode_numargs(args) + arg=cnode_arg(args,i) + if(pm_fast_vkind(arg)==pm_pointer) then + if(cnode_kind(arg)==cnode_is_cblock) then + call find_procs_for_cblock(coder,arg,rvec) + endif + endif + enddo + endif + end select + end if + if(eliminate.and.no_bad_taints.and..not.outs_alive) then + rev%data%i(rvec%offset+cnode_get_num(callnode,call_index))=& + call_noop_flag + endif + end subroutine dce_call + + + recursive subroutine atree_union(a,b,c,nc) + integer,dimension(:),intent(in):: a,b + integer,dimension(*),intent(out):: c + integer,intent(inout):: nc + integer:: i,j,k,na,nb,nnc + na=countof(a(1)) + nb=countof(b(1)) + i=1 + j=1 + k=0 + do while(i<=na.and.j<=nb) + if(a(i)==b(j)) then + call push(combine(a(i),b(j)) + i=i+1 + j=j+1 + if(a(i)<0) then + if(b(j)<0) then + k=k+1 + nnc=nc-k + call atree_add(a(i:),b(j:),c(k+1:),nnc) + c(k)=-nnc + k=k+nnc+1 + i=i+countof(a(i)) + j=j+countof(b(j)) + else + i=i+countof(a(i)) + endif + else + if(b(j)<0) then + j-j+countof(b(j)) + endif + endif + elseif(a(i)nc) call pm_panic('Program too complex -- deadcode (atree)') + end subroutine push + + end subroutine atree_union + + +end module pm_deadcode diff --git a/src/infer.f90 b/src/infer.f90 index e52b2a7..cbd3a3c 100755 --- a/src/infer.f90 +++ b/src/infer.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2025 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -44,36 +44,24 @@ module pm_infer use pm_lib use pm_symbol use pm_types - use pm_parser - use pm_sysdefs + use pm_cnodes use pm_codegen + use pm_vmdefs implicit none ! Print compiler debugging messages logical,parameter:: debug_inference=.false. + logical,parameter:: debug_bprop=.false. ! Maximum times a procedure template can call itself with ! *different* arguments types each time integer,parameter:: max_recur=32 - - ! Special signatures - integer,parameter:: sp_sig_in_process=-1_pm_p - integer,parameter:: sp_sig_recursive=-2_pm_p - integer,parameter:: sp_sig_break=-3_pm_p - integer,parameter:: sp_sig_thru=-4_pm_p - integer,parameter:: sp_sig_dup=-5_pm_p - integer,parameter:: sp_sig_noop=-6_pm_p - + ! Special types integer,parameter:: undefined=-1 integer,parameter:: error_type=-2 - ! Parallel modes - integer,parameter:: par_mode_outer=1 - integer,parameter:: par_mode_multi_node=2 - integer,parameter:: par_mode_single_node=3 - integer,parameter:: par_mode_conc=4 - integer,parameter:: par_mode_inner=5 + private:: get_var_type,get_arg_type contains @@ -86,462 +74,520 @@ module pm_infer !============================== ! Type-infer main program !============================== - subroutine prc_prog(coder) + subroutine inf_prog(coder) type(code_state),intent(inout):: coder - type(pm_ptr):: cnode - integer:: i,base + type(pm_ptr):: cnode,cblock + integer:: i - if(debug_inference) write(*,*) 'PRC PROG>' + if(debug_inference) write(*,*) 'INF PROG>' coder%flag_recursion=.false. - coder%par_depth=0 + coder%trace_depth=0 + + coder%loop_depth=0 + + coder%top=1 + coder%wtop=1 + coder%incomplete=.false. + coder%taints=0 + coder%poly_cache=pm_dict_new(coder%context,32_pm_ln) - coder%first_pass=.true. - - do - coder%top=1 - coder%wtop=1 - coder%par_kind2=par_mode_outer - coder%par_kind=par_mode_outer - coder%types_finished=.true. - coder%redo_calls=.false. - coder%incomplete=.false. - coder%taints=0 - - coder%proc_cache=pm_dict_new(coder%context,32_pm_ln) - - ! Setup resolution stack block - base=create_stack_frame(coder,0,coder%index,0) - - ! Process program code - call prc_cblock(coder,top_code(coder),3) - - ! Uncaught break implies infinite recursion - if(coder%incomplete) then - if(coder%num_errors==0) then - call more_error(coder%context,& - 'Error: A procedure in this program has infinite recursion') - coder%flag_recursion=.true. - call prc_cblock(coder,top_code(coder),3) - call pm_stop('Program contains infinite recursion') - endif + coder%proc_cache=pm_dict_new(coder%context,32_pm_ln) + + ! Setup resolution stack block + call create_stack_frame(coder,coder%index) + + ! Process program code + cblock=top_code(coder) + call inf_cblock(coder,cblock) + + ! Uncaught break implies infinite recursion + if(coder%incomplete) then + if(coder%num_errors==0) then + call more_error(coder%context,& + 'Error: A procedure in this program has infinite recursion') + coder%flag_recursion=.true. + call inf_cblock(coder,top_code(coder)) + call pm_stop('Program contains infinite recursion') endif - if(debug_inference) write(*,*) 'FULL PASS FINISHED>',coder%types_finished - if(coder%types_finished) exit - coder%first_pass=.false. - enddo + endif + + call bprop(coder,cblock,& + coder%stack(coder%base+1:coder%base+coder%index),.true.) ! Create resolved code object - call code_int_vec(coder,coder%stack,3,coder%top) - call code_num(coder,coder%stack(1)) + call code_int_vec(coder,coder%stack,coder%base,coder%top) + call code_num(coder,coder%stack(2)) call make_code(coder,pm_null_obj,cnode_is_resolved_proc,3) + ! Finalise inference of procs with polymorphic arguments + call inf_poly_procs(coder) + if(debug_inference) write(*,*) 'END OF PROG> vtop=',coder%vtop contains include 'fnewnc.inc' include 'ftiny.inc' - end subroutine prc_prog + end subroutine inf_prog ! ==================================================== ! Type-infer procedure - ! Returns signature index as tiny int in on vstack + ! Returns signature index as tiny int on vstack ! ==================================================== - function prc_proc(coder,prc,callnode,atype,ptype,nret,nkeys,& - keynames,oldbase) result(rtype) + function inf_proc(coder,procnode,callnode,atype,ptype,nret,nkeys,& + keynames,keybase,proc_nkeys,nomatch,only_when,new_atype) result(rtype) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: prc,callnode + type(pm_ptr),intent(in):: procnode,callnode integer,intent(in):: atype,ptype - integer,intent(in):: nret,nkeys + integer,intent(in):: nret,nkeys,keybase,proc_nkeys + logical,intent(in):: only_when + logical,intent(out):: nomatch + integer,intent(out):: new_atype type(pm_ptr),intent(in):: keynames - integer,intent(in):: oldbase - type(pm_ptr):: cnode,cac + integer:: rtype integer:: at - integer,dimension(4+pm_max_args):: key - integer:: i,j,base,keysize - integer(pm_ln):: k - logical:: save_redo_calls,save_incomplete - integer:: taints,save_taints - integer:: keypartyp,keyargtyp - type(pm_ptr):: save_prc, keys - logical:: iscomm - - taints=0 + integer,dimension(4+proc_nkeys):: key,base_key + integer,dimension(proc_nkeys):: key_types,junk + integer:: i,j,keysize,nk,tno + integer(pm_ln):: k,kk + logical:: save_incomplete,save_types_changed + integer:: taints,save_taints,save_atype,save_new_atype,save_rtype,save_loop_depth + integer:: keypartyp,keyargtyp,last_key_index,sp_code + type(pm_ptr):: save_procnode,keys,keytypes + type(pm_ptr):: cached,cac,base_cache,rt_cache,at_cache,rvec + logical:: ok,added,change_added,pushed_stack_frame,incomplete + integer,dimension(3):: rtn_cache + + new_atype=-1 if(pm_debug_checks) then - if(cnode_get_kind(prc)/=cnode_is_proc) then - call pm_panic('prc-proc prc not proc') + if(cnode_get_kind(procnode)/=cnode_is_proc) then + call pm_panic('procnode-proc procnode not proc') endif endif - if(cnode_flags_set(prc,pr_flags,proc_is_abstract)) then - call infer_error(coder,callnode,& + ! If this is an abstract proc then raise an error + if(cnode_flags_set(procnode,pr_flags,proc_is_abstract)) then + call inf_error(coder,callnode,& 'Abstract procedure needs to be implemented for the given argument list') - call infer_error(coder,prc,& + call inf_error(coder,procnode,& 'Abstract procedure definition referenced in the above error') - call infer_trace(coder) + call inf_trace(coder) rtype=error_type + return endif - iscomm=cnode_flags_set(prc,pr_flags,proc_is_comm) - - ! Dictionary entries in coder%proc_cache: - ! Key is proc and argument types and implicit par_kind - ! Value is tiny int with procedure return type (if >0) - ! or (-1) sp_in_process in process of resolution - ! or (-2) sp_recursive called recursively - ! or (-3) sp_break breaking (or previously broke) out of inference + if(coder%top+1+cnode_get_num(procnode,pr_max_index)>max_code_stack) then + call inf_error(coder,callnode,& + 'Very deep (probably recursive) set of nested calls that cannot be processed') + call more_error(coder%context,'Check for recursive procedure calls generating a new type each time') + call more_error(coder%context,& + 'and also for (mutually) recursive calls in the default value expressions for keyword arguments') + call inf_trace(coder) + rtype=error_type + return + endif - ! Is this combination already cached? - key(1)=cnode_get_num(prc,pr_id) - key(2)=atype - keysize=4 - keys=cnode_get(prc,pr_tkeys) - if(.not.pm_fast_isnull(keys)) then - ! If there are type-constrained key args, need to add their types to - ! the cache key - do i=0,pm_fast_esize(keys),2 - j=keys%data%i(keys%offset+i) - key(5+i)=coder%wstack(coder%proc_key_base+j) - enddo - keysize=5+pm_fast_esize(keys) + call save_proc_state + coder%loop_depth=0 + coder%atype=atype + coder%proc=procnode + + + keysize=2 + pushed_stack_frame=.false. + + ! Process keyword arguments - they form part of the hash key + last_key_index=0 + if(proc_nkeys>0) then + keys=cnode_get(procnode,pr_keys) + last_key_index=keys%data%i(keys%offset+pm_fast_esize(keys)) + pushed_stack_frame=.true. + call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) + call init_stack_frame(coder,coder%base,1,coder%base+last_key_index) + call inf_key_args(coder,callnode,procnode,atype,& + nkeys,keynames,keybase,key_types,nk,.false.) + keysize=keysize+nk + elseif(nkeys>0) then + call inf_error(coder,callnode,& + 'Keyword arguments in call to procedure that does not take any') + call inf_error_with_trace(coder,procnode,& + 'Procedure definition corresponding to the above error') endif - if(debug_inference) write(*,*) 'LOOKUP',coder%par_kind,coder%par_kind2 - if(iscomm) then - key(3)=coder%par_kind - key(4)=coder%par_kind2 - k=pm_ivect_lookup(coder%context,coder%proc_cache,key,keysize) - else - key(3)=-1 - key(4)=-1 - k=pm_ivect_lookup(coder%context,coder%proc_cache,key,keysize) - if(k==0) then - key(3)=coder%par_kind - key(4)=-1 - k=pm_ivect_lookup(coder%context,coder%proc_cache,key,keysize) + + ! Process when expression + nomatch=.false. + if(.not.pm_fast_isnull(cnode_get(procnode,pr_when))) then + if(.not.pushed_stack_frame) call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) + call init_stack_frame(coder,coder%base,1,coder%base+last_key_index) + call inf_arg_types(coder,procnode,atype) + call inf_cblock(coder,cnode_get(procnode,pr_when)) + pushed_stack_frame=.true. + tno=get_arg_type(coder,callnode,cnode_get(procnode,pr_whenvar)) + if(tno==coder%false_fix.or.tno==coder%false_literal) then + call pop_stack_frame(coder) + nomatch=.true. + call restore_proc_state + return + elseif(tno/=coder%true_fix.and.tno/=coder%true_literal) then + call inf_error(coder,procnode,& + '"when" expression must have a fixed or literal bool value') + call more_error(coder%context,'Type of expression is: '//& + trim(pm_type_as_string(coder%context,tno))) endif endif - + + if(only_when) then + call pop_stack_frame(coder) + call restore_proc_state + nomatch=.false. + return + endif + + ! Lookup combination of proc, arg types and all key types + ! defined for the procedure (including defaults) + key(1)=cnode_get_num(procnode,pr_id) + key(2)=atype + do i=3,keysize + key(i)=key_types(i-2) + enddo + k=pm_ivect_lookup(coder%context,coder%proc_cache,key,keysize) + if(debug_inference) then - write(*,*) 'PRC PROC>',key(1),key(2),key(3),key(4),k,& + write(*,*) 'INF PROC>',key(1),key(2),k,& trim(pm_name_as_string(coder%context,& - cnode_get_name(prc,pr_name))),& - trim(pm_typ_as_string(coder%context,atype)) + cnode_get_name(procnode,pr_name))),& + trim(pm_type_as_string(coder%context,atype)) endif + ! This combination already cached if(k>0) then - cnode=pm_dict_val(coder%context,coder%proc_cache,k) + cached=pm_dict_val(coder%context,coder%proc_cache,k) + if(debug_inference) then write(*,*) 'FOUND',k,'-->',key(1:keysize) - write(*,*) 'CACHED>',k,cnode%data%vkind,cnode%offset,& + write(*,*) 'CACHED>',k,cached%data%vkind,cached%offset,& trim(pm_name_as_string(coder%context,& - cnode_get_name(prc,pr_name))),sp_sig_recursive,sp_sig_in_process + cnode_get_name(procnode,pr_name))),sp_sig_recursive,sp_sig_in_process endif - ! One of the special codes - if(pm_fast_istiny(cnode)) then - if(cnode%offset==sp_sig_break) then + ! Dictionary entries in coder%proc_cache: + ! Key is proc and argument types + ! Value is vector of ints with procedure return type, & arg types and taints + ! or tiny int + ! (-1) sp_sig_in_process in process of resolution + ! (-2) sp_sig_recursive called recursively + ! (-3) sp_sig_break breaking (or previously broke) out of inference + + taints=0 + incomplete=.false. + + if(pm_fast_istiny(cached)) then + + sp_code=cached%offset + if(sp_code==sp_sig_break) then + at=atype goto 10 - elseif(cnode%offset==sp_sig_recursive) then + elseif(sp_code==sp_sig_recursive) then if(coder%flag_recursion) then - call infer_error(coder,prc,'Recursive call to: '//& + call inf_error(coder,procnode,'Recursive call to: '//& trim(pm_name_as_string(coder%context,& - cnode_get_name(prc,pr_name)))) - call infer_trace(coder) + cnode_get_name(procnode,pr_name)))) + call inf_trace(coder) coder%flag_recursion=.false. endif - coder%incomplete=.true. + incomplete=.true. rtype=error_type - elseif(cnode%offset==sp_sig_in_process) then + elseif(sp_code==sp_sig_in_process) then call pm_dict_set_val(coder%context,coder%proc_cache,& k,pm_fast_tinyint(coder%context,sp_sig_recursive)) - if(coder%flag_recursion) then - call infer_error(coder,prc,'Recursive call to: '//& + if(coder%flag_recursion) then + call inf_error(coder,procnode,'Recursive call to: '//& trim(pm_name_as_string(coder%context,& - cnode_get_name(prc,pr_name)))) - call infer_trace(coder) + cnode_get_name(procnode,pr_name)))) + call inf_trace(coder) coder%flag_recursion=.false. endif - coder%incomplete=.true. + incomplete=.true. rtype=error_type - elseif(cnode%offset<0) then + elseif(sp_code<0) then ! Another special sig rtype=atype - call code_num(coder,int(cnode%offset)) - else - ! Return type - rtype=cnode%offset - if(debug_inference) write(*,*) 'CACHED RETURN>',rtype - call code_num(coder,int(k)) - endif - return - endif + call code_num(coder,int(sp_code)) + endif + elseif(pm_fast_vkind(cached)==pm_int) then + ! Cached return types + rtype=cached%data%i(cached%offset) + new_atype=cached%data%i(cached%offset+1) + taints=cached%data%i(cached%offset+2) + if(debug_inference) write(*,*) 'CACHED RETURN>',rtype,& + trim(pm_type_as_string(coder%context,rtype)) + call code_num(coder,int(k)) + else - ! Not a special code so have an inferred type - - ! Pass out taints - taints=cnode_num_arg(cnode,3) - coder%taints=ior(coder%taints,iand(taints,proc_taints)) + ! Not a special code or set of return types - so have a fully inferred procedure - ! If not quite complete need to run through again - if(iand(taints,proc_unfinished)/=0.and.& - coder%redo_calls.and..not.coder%flag_recursion) goto 10 - - ! Check keyword arguments - keys=cnode_arg(cnode,4) - do i=0,nkeys-1 - keyargtyp=coder%wstack(coder%proc_key_base+i+1) - keypartyp=keys%data%i(keys%offset+i) - if(keyargtyp/=keypartyp) then - if(keypartyp==pm_tiny_int) then - keys%data%i(keys%offset+i)=keyargtyp - elseif(keyargtyp/=pm_tiny_int) then - call infer_error(coder,prc,'Keyword/argument type mismatch:',& - pm_set_key(coder%context,keynames,int(i+1,pm_ln))) - call more_error(coder%context,'Mismatched argument: '//& - trim(pm_typ_as_string(coder%context,keyargtyp))) - call more_error(coder%context,'Mismatched parameter: '//& - trim(pm_typ_as_string(coder%context,keypartyp))) - call infer_trace(coder) - endif - endif - enddo + ! Cached return types and taints + taints=cnode_num_arg(cached,3) + rtype=cnode_num_arg(cached,4) + new_atype=cnode_num_arg(cached,5) + + ! Push signature + call code_num(coder,int(k)) - ! Push signature - call code_num(coder,int(k)) - - ! Get return type - cnode=cnode_arg(cnode,2) - rtype=cnode%data%i(cnode%offset) - if(nret==0) rtype=0 - if(debug_inference) write(*,*) 'CACHED RTYPE>',rtype + if(debug_inference) write(*,*) 'CACHED RTYPE>',rtype + + endif + if(pushed_stack_frame) call pop_stack_frame(coder) + call restore_proc_state + coder%incomplete=coder%incomplete.or.incomplete + coder%taints=ior(coder%taints,iand(taints,proc_taints)) return endif 10 continue ! Proc is not (or not yet fully) inferred - at=atype - + ! Check for infinite recursion with changing arg types - if(cnode_get_num(prc,pr_recurse)>max_recur) then - call infer_error_with_trace(coder,prc,& + if(cnode_get_num(procnode,pr_recurse)>max_recur) then + call inf_error_with_trace(coder,procnode,& 'Recursion appears to require infinite types') call code_num(coder,0) + call restore_proc_state return endif 20 continue ! Flag call to check for recursion - call cnode_incr_num(prc,pr_recurse,1) + call cnode_incr_num(procnode,pr_recurse,1) + + ! Get ready to type infer k=pm_idict_add(coder%context,coder%proc_cache,& key,keysize,pm_fast_tinyint(coder%context,sp_sig_in_process)) + + if(.not.pushed_stack_frame) then + call new_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) + endif ! Repeatedly type infer until complete - save_incomplete=coder%incomplete - save_taints=coder%taints do - if(debug_inference) write(*,*) 'TRY>',key(1),key(2),key(3),key(4),rtype + if(debug_inference) write(*,*) 'TRY>',key(1),key(2),rtype,trim(pm_name_as_string(coder%context,& + cnode_get_name(procnode,pr_name))) + + call init_stack_frame(coder,coder%base,last_key_index+1,coder%top) - ! Create stack frame - base=create_stack_frame(coder,at,cnode_get_num(prc,pr_max_index),taints) - ! Process code coder%incomplete=.false. coder%taints=taints - save_prc=coder%proc - coder%proc=prc - call prc_cblock(coder,cnode_arg(prc,1),base) - coder%proc=save_prc + coder%new_atype=-1 + coder%rtype=-1 + + call inf_cblock(coder,cnode_get(procnode,pr_cblock)) ! Check procedure record for recursion/completion - cnode=pm_dict_val(coder%context,coder%proc_cache,k) - if(.not.pm_fast_istiny(cnode)) then - write(*,*) cnode%data%vkind,k - call pm_panic('prc-proc bad cache') - endif - + cached=pm_dict_val(coder%context,coder%proc_cache,k) + if(debug_inference) then - write(*,*) 'TRY COMPLETE>',cnode%offset,& - coder%stack(base),coder%stack(base-1),nret + write(*,*) 'TRY COMPLETE>',cached%offset,nret,trim(pm_name_as_string(coder%context,& + cnode_get_name(procnode,pr_name))) endif - - if(cnode%offset==sp_sig_in_process) then - ! Not recursively called - rtype=coder%stack(base) - if(nret==0) rtype=0 - if(debug_inference) write(*,*) 'NOT RECURSIVE>',rtype,coder%incomplete - exit - else if(cnode%offset<=sp_sig_recursive) then - ! Recursively called - if(nret==0) coder%stack(base)=0 - - if(coder%stack(base)<0) then - ! No resolved type yet - ! flag cache entry - ! and break out - call pop_stack_frame(coder,base) - cnode%offset=sp_sig_break - call pm_dict_set_val(coder%context,& - coder%proc_cache,k,cnode) - coder%proc_par_depth=coder%par_depth - coder%incomplete=.true. - coder%taints=save_taints - rtype=error_type - if(debug_inference) write(*,*) 'NOT RESOLVED>' - return + + if(pm_fast_istiny(cached)) then + sp_code=cached%offset + if(sp_code==sp_sig_in_process) then + ! Not recursively called + rtype=coder%rtype + new_atype=coder%new_atype + taints=coder%taints + if(debug_inference) write(*,*) 'NOT RECURSIVE>',rtype,coder%incomplete + exit + else if(sp_code<=sp_sig_recursive) then + ! Recursively called + if(nret>0.and.coder%rtype<0) then + ! No resolved type yet + ! flag cache entry + ! and break out + call pop_stack_frame(coder) + sp_code=sp_sig_break + call pm_dict_set_val(coder%context,& + coder%proc_cache,k,cached) + call restore_proc_state + coder%incomplete=.true. + rtype=error_type + new_atype=-1 + if(debug_inference) write(*,*) 'NOT RESOLVED>' + return + endif + + ! Cache resolved return type, new "&" types, taints + rtn_cache(1)=coder%rtype + rtn_cache(2)=coder%new_atype + rtn_cache(3)=ior(coder%taints,proc_is_recursive) + call code_int_vec(coder,rtn_cache,1,3) + call pm_dict_set_val(coder%context,coder%proc_cache,k,top_code(coder)) + call drop_code(coder) endif - - ! Flag procedure as recursive - coder%taints=ior(coder%taints,proc_is_recursive) - - ! Cache resolved return type - cnode%offset=coder%stack(base) - call pm_dict_set_val(coder%context,coder%proc_cache,k,cnode) else ! Recursive call for which we ! already have a return type - ! check against type just returned - if(debug_inference) write(*,*) 'RT>',rtype,coder%stack(base) - rtype=cnode%offset - if(debug_inference) write(*,*) 'RECURSIVE WITH TYPE>',rtype - - ! This error should not happen - !(implies compiler bug as proc output type determined by args) - if(nret>0.and.rtype/=coder%stack(base)) then - call infer_error_with_trace(coder,prc,& - 'Internal Compiler Error: Procedure return type changed') + if(debug_inference) write(*,*) 'RT>',rtype,coder%stack(coder%base) + + if(pm_fast_vkind(cached)/=pm_int) call pm_panic('Bad cached proc kind') + + ! Get cached return types, changed "&" arg types and taints + rtype=cached%data%i(cached%offset) + new_atype=cached%data%i(cached%offset+1) + taints=cached%data%i(cached%offset+2) + + if(debug_inference) write(*,*) 'RECURSIVE WITH TYPE>',& + trim(pm_type_as_string(coder%context,rtype)),' FOR ',& + trim(pm_name_as_string(coder%context,cnode_get_num(procnode,pr_name))) + + ! If returning values or updating "&" arguments, need to check if types have changed + added=.false. + if(nret>0) then + rtype=pm_type_combine(coder%context,rtype,coder%rtype,ok,added) + if(.not.ok) then + call inf_error_with_trace(coder,procnode,& + 'Internal Compiler Error: Procedure return types changed: '//& + trim(pm_type_as_string(coder%context,rtype))//'<>'//& + trim(pm_type_as_string(coder%context,cached%data%i(cached%offset)))) + endif + endif + if(coder%new_atype/=-1) then + new_atype=pm_type_combine(coder%context,coder%new_atype,new_atype,ok,change_added) + if(.not.ok) then + call inf_error_with_trace(coder,procnode,& + 'Internal Compiler Error: Procedure returned "&" arg types changed') + endif + added=added.or.change_added + endif + if(ior(taints,coder%taints)/=taints) then + added=.true. + taints=ior(taints,coder%taints) + endif + if(added) then + cached%data%i(cached%offset)=rtype + cached%data%i(cached%offset+1)=new_atype + cached%data%i(cached%offset+2)=taints + cycle endif ! Flag procedure as recursive - coder%taints=ior(coder%taints,proc_is_recursive) + taints=ior(taints,proc_is_recursive) + + ! Inference is completed exit endif enddo if(debug_inference) then - write(*,*) 'COMPLETED>',coder%stack(base),& - coder%stack(base-1),base,oldbase,coder%stack(oldbase-1) + write(*,*) 'COMPLETED>',trim(pm_name_as_string(coder%context,& + cnode_get_name(procnode,pr_name))),' ',k,coder%incomplete endif ! Pass a break out if(coder%incomplete) then - if(debug_inference) then - write(*,*) 'OUTBREAK>',oldbase - endif - call pop_stack_frame(coder,base) + call pop_stack_frame(coder) ! clear cache entry - cnode%offset=sp_sig_break + cached%offset=sp_sig_break call pm_dict_set_val(coder%context,& - coder%proc_cache,k,cnode) + coder%proc_cache,k,cached) if(rtype>=0) then call code_num(coder,int(k)) endif + call restore_proc_state return endif - coder%incomplete=save_incomplete - ! Flag recursive calls with taints or keyword args as unfinished taints=iand(coder%taints,proc_taints) - if(iand(coder%taints,proc_is_recursive)/=0) then - if(taints>0.or.nkeys>0) then - coder%taints=ior(coder%taints,proc_unfinished) + + ! Determine a hash key with any polymorphic elements eliminated + added=.false. + base_key(1)=key(1) + do i=2,keysize + base_key(i)=pm_type_strip_poly(coder%context,key(i)) + added=added.or.(base_key(i)/=key(i)) + end do + + ! If the stripped-down hash key is different then need to create a record + ! of this + if(added) then + kk=pm_ivect_lookup(coder%context,coder%poly_cache,base_key,keysize) + if(kk>0) then + base_cache=pm_dict_val(coder%context,coder%poly_cache,kk) + base_cache=cnode_arg(base_cache,2) + do i=2,keysize + base_cache%data%i(base_cache%offset+i-1)=& + pm_type_combine(coder%context,& + base_cache%data%i(base_cache%offset+i-1),key(i),ok,change_added) + enddo + else + call code_val(coder,procnode) + call code_int_vec(coder,key,1,keysize) + rtn_cache(1)=rtype + rtn_cache(2)=new_atype + rtn_cache(3)=taints + call code_int_vec(coder,rtn_cache,1,3) + call make_code(coder,pm_null_obj,cnode_is_resolved_proc,3) + kk=pm_idict_add(coder%context,coder%poly_cache,& + base_key,keysize,top_code(coder)) + call drop_code(coder) endif endif - + ! Create record of type-annotated code - call code_val(coder,prc) - call code_int_vec(coder,coder%stack,base,coder%top) - call code_num(coder,& - ior(iand(cnode_get_num(prc,pr_flags),& - proc_is_comm+proc_run_shared+proc_run_local+proc_inline+& - proc_no_inline+proc_run_complete+proc_run_always),& - coder%taints)) - if(nkeys>0) then - call code_int_vec(coder,coder%wstack,& - coder%proc_key_base+1,coder%proc_key_base+nkeys) + call code_val(coder,procnode) + if(added) then + call code_num(coder,int(kk)) else - call code_null(coder) + call code_int_vec(coder,coder%stack,coder%base,coder%top) + rvec=top_code(coder) endif - call make_code(coder,pm_null_obj,cnode_is_resolved_proc,4) - cnode=top_code(coder) - if(iscomm) then - key(3)=coder%par_kind - key(4)=coder%par_kind2 + call code_num(coder,& + ior(iand(cnode_get_num(procnode,pr_flags),& + proccall_is_comm+proccall_is_inline+proccall_is_no_inline),& + coder%taints)) + call code_num(coder,rtype) + call code_num(coder,new_atype) + + if(added) then + call bprop(coder,cnode_get(procnode,pr_cblock),& + coder%stack(coder%base+1:coder%base+cnode_get_num(procnode,pr_max_index)),& + .false.) else - key(3)=coder%par_kind - key(4)=-1 + call bprop(coder,cnode_get(procnode,pr_cblock),& + rvec%data%i(rvec%offset+1:rvec%offset+cnode_get_num(procnode,pr_max_index)),& + .true.) endif - if(debug_inference) write(*,*) coder%par_kind,'CACHE AS>',key(1:keysize) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,keysize,cnode) + if(proc_nkeys==0) call code_null(coder) + call make_code(coder,pm_null_obj,cnode_is_resolved_proc,7) + call pm_dict_set_val(coder%context,coder%proc_cache,k,top_code(coder)) call drop_code(coder) + call code_num(coder,int(k)) + call pop_stack_frame(coder) + call cnode_incr_num(procnode,pr_recurse,-1) - ! For tainted recursive calls - ! or recursive calls with keywords need one final pass - if(iand(coder%taints,proc_is_recursive)/=0) then - if(taints>0.or.nkeys>0) then - save_redo_calls=coder%redo_calls - coder%redo_calls=.true. - call init_stack_frame(coder,base,at,taints) - call prc_cblock(coder,cnode_arg(prc,1),base) - coder%redo_calls=save_redo_calls - call cnode_set_num(cnode,cnode_args+2,& - ieor(cnode_num_arg(cnode,3),proc_unfinished)) - endif - endif + call restore_proc_state + + - ! Now we have complete taints can check if proc needs par_kind - if(iand(coder%taints,proc_needs_par)==0) then - ! If not include a new entry - this will shadow entries - ! specialised on par_kind due to search order - key(3)=-1 - key(4)=-1 - if(debug_inference) write(*,*) 'RECACHE AS>',key(1:keysize) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,keysize,cnode) - endif - - ! Process special cases of 'each' procedures - if(iand(coder%taints,proc_is_not_pure_each)==0) then - if(.not.cnode_flags_clear(prc,pr_flags,& - proc_is_thru_each+proc_is_empty_each+proc_is_dup_each)) then - cnode=pm_fast_tinyint(coder%context,sp_sig_dup) - if(cnode_flags_set(prc,pr_flags,proc_is_thru_each)) then - cnode%offset=sp_sig_thru - elseif(cnode_flags_set(prc,pr_flags,proc_is_empty_each)) then - cnode%offset=sp_sig_noop - endif - k=pm_idict_add(coder%context,coder%proc_cache,& - key,keysize,cnode) - k=cnode%offset - endif + if(debug_inference) then + write(*,*) 'ENDPROCNODE>',trim(pm_name_as_string(coder%context,& + cnode_get_name(procnode,pr_name))),k,coder%taints endif - call code_num(coder,int(k)) - call pop_stack_frame(coder,base) - call cnode_incr_num(prc,pr_recurse,-1) - - ! If calling (unresolved) proc is not the same as this proc - ! then this cannot be a pure each proc so taint it as such - if(.not.(prc==coder%proc)) then - coder%taints=ior(coder%taints,proc_is_not_pure_each) - endif - ! Pass out taint information coder%proc_taints=iand(coder%taints,proc_taints) coder%taints=ior(save_taints,coder%proc_taints) - - if(pm_debug_level>3) then - write(*,*) 'ENDPRC>',key(1),key(2),key(3),key(4),k - endif - + contains include 'fnewnc.inc' include 'fistiny.inc' @@ -549,274 +595,543 @@ function prc_proc(coder,prc,callnode,atype,ptype,nret,nkeys,& include 'fvkind.inc' include 'fesize.inc' include 'fisnull.inc' - end function prc_proc + + subroutine save_proc_state + save_loop_depth=coder%loop_depth + save_types_changed=coder%types_changed + save_incomplete=coder%incomplete + save_taints=coder%taints + save_procnode=coder%proc + save_atype=coder%atype + save_new_atype=coder%new_atype + save_rtype=coder%rtype + end subroutine save_proc_state + + subroutine restore_proc_state + coder%incomplete=save_incomplete + !coder%taints=save_taints + coder%proc=save_procnode + coder%atype=save_atype + coder%new_atype=save_new_atype + coder%rtype=save_rtype + coder%loop_depth=save_loop_depth + coder%types_changed=save_types_changed + end subroutine restore_proc_state + + end function inf_proc - ! ================================================== - ! Type infer builtin procedure - ! =================================================== - function prc_builtin(coder,prc,atype,ptype,oldbase) result(rtype) + !================================================== + ! Resolve all procs with poly arguments listed in + ! poly_cache + !================================================= + subroutine inf_poly_procs(coder) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: prc - integer,intent(in):: atype,ptype - integer,intent(in):: oldbase - integer:: rtype,mode - type(pm_ptr):: p - integer:: base,i - integer:: t1,t2 - integer,dimension(2):: key - integer:: k - integer:: sym - type(pm_ptr):: tv,tv2 - logical:: isstatic - type(pm_typ_einfo):: einfo - - - p=cnode_get(prc,bi_rcode) - if(pm_fast_istiny(p)) then - tv=pm_typ_vect(coder%context,atype) - tv=pm_typ_vect(coder%context,pm_tv_arg(tv,1)) - rtype=(pm_tv_arg(tv,int(p%offset))) - elseif(pm_fast_isnull(p)) then - rtype=cnode_get_num(prc,bi_rtype) - if(rtype<0) then - ! Cached concrete return type - rtype=-rtype - else - ! Convert type to concrete only representation and cache it - if(rtype/=0) then - rtype=pm_typ_as_concrete(coder%context,rtype,coder%wstack,& - isstatic) - if(isstatic) call cnode_set_num(prc,bi_rtype,int(-rtype)) + integer(pm_ln):: i,k,kk + integer:: j,n,atype,key_type,taints + type(pm_ptr):: cached,procnode,keys,rtns,keyargs,junk + logical:: ok + do i=pm_dict_size(coder%context,coder%poly_cache),1,-1 + ! Details of this proc + cached=pm_dict_val(coder%context,coder%poly_cache,i) + procnode=cnode_arg(cached,1) + keys=cnode_arg(cached,2) + rtns=cnode_arg(cached,3) + atype=keys%data%i(keys%offset+1) + n=pm_fast_esize(keys)-1 + taints=rtns%data%i(rtns%offset+2) + + ! For a recursive proc, make sure that there is an resolved entry in proc_cache + ! to handle any nested recursive calls + if(iand(taints,proc_is_recursive)/=0) then + junk=pm_dict_lookup(coder%context,coder%proc_cache,keys,kk) + if(kk==0) then + call code_val(coder,procnode) + call code_num(coder,int(i)) + call code_num(coder,taints) + call code_num(coder,rtns%data%i(rtns%offset)) + call code_num(coder,rtns%data%i(rtns%offset+1)) + call make_code(coder,pm_null_obj,cnode_is_resolved_proc,5) + call pm_dict_set(coder%context,coder%proc_cache,keys,top_code(coder),.true.,.true.,ok) + call drop_code(coder) endif endif - if(cnode_get_num(prc,bi_rsym)==sym_dash) then - tv=pm_typ_vect(coder%context,atype) - do i=1,pm_tv_numargs(tv) - tv2=pm_typ_vect(coder%context,pm_tv_arg(tv,i)) - if(pm_tv_kind(tv2)/=pm_typ_is_value) goto 20 + + call create_stack_frame(coder,cnode_get_num(procnode,pr_max_index)) + + ! Handle keyword arguments + if(n>0) then + call inf_arg_types(coder,procnode,atype) + keyargs=cnode_get(procnode,pr_keycall) + do j=1,n + call inf_cblock(coder,cnode_arg(keyargs,j*2-1+n+n)) + key_type=keys%data%i(keys%offset+j+1) + call set_var_type(coder,cnode_arg(keyargs,j),key_type) + call set_var_type(coder,cnode_arg(keyargs,j+n),key_type) enddo - call fold - if(pm_is_compiling) then - call code_num(coder,sp_sig_noop) - return + end if + + ! Infer main body + coder%atype=atype + coder%incomplete=.false. + call inf_cblock(coder,cnode_get(procnode,pr_cblock)) + + ! Set this entry in poly_cache to inference vector + call code_int_vec(coder,coder%stack,coder%base,coder%top) + call pm_dict_set_val(coder%context,coder%poly_cache,i,top_code(coder)) + call drop_code(coder) + enddo + contains + include 'fesize.inc' + end subroutine inf_poly_procs + + !================================================= + ! Infer conventional (non-keyword) argument types + ! (this routine mainly used as part of inferring + ! keyword argument types) + !================================================= + subroutine inf_arg_types(coder,procnode,atype) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: procnode + integer,intent(in):: atype + type(pm_ptr):: arglist,tv + integer:: nargs,totargs,i,j + arglist=cnode_get(procnode,pr_argcall) + if(.not.pm_fast_isnull(arglist)) then + nargs=cnode_numargs(arglist) + tv=pm_type_vect(coder%context,atype) + totargs=pm_tv_numargs(tv) + do i=1,nargs + call set_var_type(coder,cnode_arg(arglist,i),pm_tv_arg(tv,i)) + enddo + if(totargs>nargs) then + call push_word(coder,pm_type_is_tuple) + call push_word(coder,0) + j=0 + do i=nargs,totargs + call push_word(coder,pm_tv_arg(tv,i)) + j=j+1 + enddo + call make_type(coder,j+2) + call set_var_type(coder,cnode_arg(arglist,nargs),pop_word(coder)) + endif + endif + contains + include 'fisnull.inc' + end subroutine inf_arg_types + + !======================================================================= + ! Process keyword arguments + ! This requires type inference of default expressions before checking + ! and converting the arguments + !======================================================================= + subroutine inf_key_args(coder,callnode,procnode,atype,nkeys,call_keys,key_base,& + key_types,n,combine) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,procnode,call_keys + integer,intent(in):: atype,nkeys,key_base + integer,intent(out):: key_types(:),n + logical,intent(in):: combine + integer,dimension(size(key_types)):: keytypes + integer i,j,cname,pname,ctype,ptype,dtype,pdtype,mtype + logical:: nomatch,error,ok,added + type(pm_ptr):: callkeys,proc_keys,arglist,tv + integer:: nargs,totargs,tno,keytype + + proc_keys=cnode_get(procnode,pr_keys) + + ! Need to infer standard arguments in case they are + ! used in default expressions + call inf_arg_types(coder,procnode,atype) + + arglist=cnode_get(procnode,pr_keycall) + n=pm_fast_esize(proc_keys)/2 + keytypes(1:n)=undefined + callkeys=pm_name_val(coder%context,int(call_keys%offset)) + + ! Find matching keyword parameter for each call keyword argument + ! and set the type for that parameter + outer: do i=0,nkeys-1 + cname=callkeys%data%i(callkeys%offset+i) + ctype=coder%wstack(key_base+1+i) + do j=1,n + pname=proc_keys%data%i(proc_keys%offset+j-1) + if(cname==pname) then + keytypes(j)=ctype + cycle outer + endif + enddo + call inf_error(coder,callnode,'Keyword argument "'//& + trim(pm_name_as_string(coder%context,cname))//& + '" does not match a keyword in the procedure definition') + call inf_error(coder,procnode,& + 'Procedure definition corresponding to the above error') + enddo outer + + ! For each keyword parameter, infer the default type and then + ! determine keyword argument matching with any required conversions + ! - match_arg will leave conversion records on the vstack + do i=1,n + call inf_cblock(coder,cnode_arg(arglist,i*2-1+n+n)) + + dtype = pm_type_strip_literal(coder%context,& + get_arg_type(coder,callnode,cnode_arg(arglist,i*2+n+n))) + + if(keytypes(i)>=0) then + ptype=proc_keys%data%i(proc_keys%offset+i-1+n) + pdtype=merge(ptype,dtype,ptype>=0) + mtype=match_arg(coder,callnode,procnode,& + pdtype,keytypes(i),-i,3,nomatch,error) + if(nomatch) then + if(ptype>=0) then + call inf_error(coder,callnode,'Keyword argument "'//& + trim(pm_name_as_string(coder%context,proc_keys%data%i(proc_keys%offset)))//& + '" does not conform to the parameter type constraint') + else + call inf_error(coder,callnode,'Keyword argument "'//& + trim(pm_name_as_string(coder%context,proc_keys%data%i(proc_keys%offset)))//& + '" does not have the same type as the default value in the procedure definition') + endif + call more_error(coder%context,'Expected: '//trim(pm_type_as_string(coder%context,pdtype))) + call more_error(coder%context,'Got: '//& + trim(pm_type_as_string(coder%context,keytypes(i)))) + call inf_error(coder,procnode,'Definition corresponding to the above error') + call inf_trace(coder) + elseif(error) then + exit + else + keytype=mtype endif -20 continue + else + keytype=dtype + endif + if(combine) then + key_types(i)=pm_type_combine(coder%context,key_types(i),keytype,ok,added) + else + key_types(i)=keytype + endif + call set_var_type(coder,cnode_arg(arglist,i),key_types(i)) + call set_var_type(coder,cnode_arg(arglist,i+n),key_types(i)) + enddo + contains + include 'fesize.inc' + include 'fisnull.inc' + end subroutine inf_key_args + + ! ================================================== + ! Type infer builtin procedure + ! =================================================== + function inf_builtin(coder,procnode,callnode,atype,ptype,new_atype) result(rtype) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: procnode,callnode + integer,intent(in):: atype,ptype + integer,intent(out):: new_atype + integer:: rtype,mode,atype1 + integer,dimension(1):: key + integer:: k,t1,n,opcode + type(pm_ptr):: tv,v + logical:: isstatic,iscomm,ok,added + + new_atype=-1 + + if(debug_inference) then + write(*,*) 'BUILTIN>',& + trim(pm_name_as_string(coder%context,cnode_get_num(procnode,pr_name))) + endif + + rtype=cnode_get_num(procnode,pr_rtype) + if(rtype<0) then + ! Cached concrete return type + rtype=-rtype + else + ! Convert type to concrete only representation and cache it + if(rtype/=0) then + rtype=pm_type_as_concrete(coder%context,rtype,coder%wstack,& + isstatic) endif + endif + + opcode=cnode_get_num(procnode,bi_opcode) + + if(opcode==op_error_type) then + rtype=error_type + return + endif + + if(cnode_flags_set(procnode,pr_flags,proccall_is_comm)) then + atype1=pm_type_arg(coder%context,atype,1+num_comm_args) else - ! Process code for return expression to get base return type - base=create_stack_frame(coder,atype,cnode_num_arg(prc,2),0) - call prc_cblock(coder,cnode_get(prc,bi_rcode),base) - rtype=coder%stack(base) - call pop_stack_frame(coder,base) - - sym=cnode_get_num(prc,bi_rsym) - if(rtype/=error_type) then - ! Special processing of return type - ! Specified by special character in return spec - select case(sym) - case(sym_hash,sym_pct) - tv=pm_typ_vect(coder%context,rtype) - tv=pm_typ_vect(coder%context,pm_tv_arg(tv,1)) - if(sym==sym_hash) then - rtype=(pm_tv_arg(tv,2)) - else - rtype=(pm_tv_arg(tv,1)) - endif - case(sym_dim1:sym_dim7) - tv=pm_typ_vect(coder%context,rtype) - tv=pm_typ_vect(coder%context,pm_typ_strip_mode(coder%context,& - pm_tv_arg(tv,1),mode)) - if(pm_tv_kind(tv)==pm_typ_is_vect) then - tv=pm_typ_vect(coder%context,pm_tv_arg(tv,1)) - endif - rtype=pm_tv_arg(tv,int(sym-sym_dim1+1)) - case(sym_d1:sym_d7) - tv=pm_typ_vect(coder%context,rtype) - tv=pm_typ_vect(coder%context,pm_typ_strip_mode(coder%context,& - pm_tv_arg(tv,1),mode)) - if(pm_tv_kind(tv)==pm_typ_is_vect) then - rtype=pm_tv_arg(tv,1) - tv=pm_typ_vect(coder%context,rtype) - rtype=pm_typ_strip_mode(coder%context,pm_tv_arg(tv,int(sym-sym_d1+1)),mode) - if(modepm_tv_numargs(tv)) then + call inf_error(coder,callnode,& + '".element_at_index": index out of bounds: '//& + trim(pm_int_as_string(n))) + call more_error(coder%context,'Type being indexed: '//& + trim(pm_type_as_string(coder%context,t1))) + call inf_trace(coder) + rtype=error_type + else + rtype=pm_tv_arg(tv,n) + endif endif - endif + case(op_array,op_make_array,op_pack) + rtype=pm_new_arr_type(coder%context,sym_const,& + pm_type_for_var(coder%context,atype1,sym_private),& + pm_type_arg(coder%context,atype,3),int(pm_long)) + !write(*,*) 'make array',pm_type_as_string(coder%context,atype) + case(op_var_array) + rtype=pm_new_arr_type(coder%context,sym_var,& + pm_type_for_var(coder%context,atype1,sym_private),& + pm_type_for_var(coder%context,pm_type_arg(coder%context,atype,3),sym_private),int(pm_long)) + case(op_redim) + tv=pm_type_vect(coder%context,atype1) + rtype=pm_new_arr_type(coder%context,pm_tv_name(tv),& + pm_tv_arg(tv,1),& + pm_type_arg(coder%context,atype,3),int(pm_long)) + case(op_make_type_val) + rtype=pm_new_type_type(coder%context,atype1) + case(op_import_dref) + rtype=pm_type_strip_mode(coder%context,& + atype1,mode) + tv=pm_type_vect(coder%context,rtype) + if(pm_tv_kind(tv)==pm_type_is_vect) then + rtype=pm_tv_arg(tv,1) + endif + case(op_import_val) + t1=pm_type_strip_mode(coder%context,atype1,mode) + if(mode==sym_shared) then + rtype=pm_error_type_from_string(coder%context,'Cannot import '//& + '"shrd" value into a new parallel context') + else + rtype=pm_type_add_mode(coder%context,t1,& + merge(sym_shared,sym_invar,& + iand(pm_type_flags(coder%context,t1),pm_type_has_distributed)/=0)) + endif + case(op_export_param) + t1=pm_type_strip_mode(coder%context,atype1,mode) + if(mode1) then - arg2=pm_dict_val(coder%context,coder%context%tcache,& - int(pm_tv_arg(tv,2),pm_ln)) + subroutine infer_list_concat + call push_word(coder,pm_type_new_tuple) + call push_word(coder,0) + n=coder%wtop + call push_word(coder,pm_type_new_tuple+pm_type_is_list) + call push_word(coder,0) + tv=pm_type_vect(coder%context,atype1) + do k=1,pm_tv_numargs(tv) + call push_word(coder,pm_tv_arg(tv,k)) + enddo + t1=pm_type_strip_mode(coder%context,& + pm_type_arg(coder%context,atype,3),mode) + tv=pm_type_vect(coder%context,t1) + do k=1,pm_tv_numargs(tv) + call push_word(coder,pm_tv_arg(tv,k)) + enddo + call make_type_if_possible(coder,coder%wtop-n) + call make_type_if_possible(coder,3) + rtype=pop_word(coder) + end subroutine infer_list_concat + + subroutine infer_list_splice + type(pm_ptr):: tv,tv2,arg + integer:: k,base,i,siz,t1 + arg=pm_type_val(coder%context,& + pm_type_strip_mode(coder%context,& + pm_type_arg(coder%context,atype,4),mode)) + i=arg%data%ln(arg%offset) + arg=pm_type_val(coder%context,& + pm_type_strip_mode(coder%context,& + pm_type_arg(coder%context,atype,5),mode)) + siz=arg%data%ln(arg%offset) + tv=pm_type_vect(coder%context,atype1) + if(i<0.or.i>=pm_tv_numargs(tv)) then + call inf_error(coder,callnode,& + 'Internal error: Bad index in splice_list: '//& + trim(pm_int_as_string(i))//' with list size='//& + trim(pm_int_as_string(pm_tv_numargs(tv)))) endif - rtv=pm_typ_vect(coder%context,rtype) - rtyp=pm_tv_arg(rtv,1) - if(rtyp/=pm_logical) then - coder%temp=pm_fast_new(coder%context,int(rtyp,pm_p),1_pm_p) - call fold_value(cnode_get_num(prc,bi_opcode),& - coder%temp,arg1,arg2,ok,emess) - if(.not.ok) then - call infer_error_with_trace(coder,prc,& - 'Cannot combine run time values: '//trim(emess)) - else - rtype=(pm_new_value_typ(coder%context,coder%temp)) - endif - else - call fold_comparison(cnode_get_num(prc,bi_opcode),arg1,arg2,ok) - if(ok) then - rtype=(coder%true_name) - else - rtype=(coder%false_name) - endif + if(siz<0.or.i+siz>=pm_tv_numargs(tv)) then + call inf_error(coder,callnode,& + 'Internal error: Bad size in splice_list: '//& + trim(pm_int_as_string(siz))//& + ' with index='//trim(pm_int_as_string(i))//' and list size='//& + trim(pm_int_as_string(pm_tv_numargs(tv)))) endif - coder%temp=pm_null_obj - end subroutine fold + call push_word(coder,pm_type_new_tuple) + call push_word(coder,0) + base=coder%wtop + call push_word(coder,pm_type_new_tuple+pm_type_is_list) + call push_word(coder,0) + + do k=1,i + call push_word(coder,pm_tv_arg(tv,k)) + enddo + t1=pm_type_strip_mode(coder%context,& + pm_type_arg(coder%context,atype,3),mode) + tv2=pm_type_vect(coder%context,t1) + do k=1,pm_tv_numargs(tv2) + call push_word(coder,pm_tv_arg(tv2,k)) + enddo + do k=i+2+siz,pm_tv_numargs(tv) + call push_word(coder,pm_tv_arg(tv,k)) + enddo + call make_type_if_possible(coder,coder%wtop-base) + call make_type_if_possible(coder,3) + rtype=pop_word(coder) + end subroutine infer_list_splice - end function prc_builtin + end function inf_builtin !========================================== ! Type infer code block !========================================== - subroutine prc_cblock(coder,cblock,base) + subroutine inf_cblock(coder,cblock) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: cblock - integer,intent(in):: base - integer:: nvars,i,newbase + integer:: save_taints type(pm_ptr):: p if(pm_fast_isnull(cblock)) return + save_taints=coder%taints + coder%taints=0 p=cnode_get(cblock,cblock_first_call) do while(.not.pm_fast_isnull(p)) - call prc_call(coder,cblock,p,base) + call inf_call(coder,cblock,p) p=cnode_get(p,call_link) enddo + coder%stack(coder%base+cnode_get_num(cblock,cblock_index))=coder%taints + coder%taints=ior(save_taints,coder%taints) contains include 'fisnull.inc' - end subroutine prc_cblock + end subroutine inf_cblock - !======================================================= - ! Type infer call - ! (calls include control structures as a special case) + !========================================== + ! Return tainta associated with a block + ! - inference on block must be complete + !========================================== + function cblock_taints(coder,cblock) result(taints) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock + integer:: taints + taints=coder%stack(coder%base+cnode_get_num(cblock,cblock_index)) + end function cblock_taints + + !======================================================= + ! Type infer general calls + ! (which include control structures as a special case) !======================================================== - subroutine prc_call(coder,cblock,callnode,base) + subroutine inf_call(coder,cblock,callnode) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: callnode,cblock - integer,intent(in):: base integer:: sig integer:: tno,tno2,tno3,tno4,name,off,flags,mode,mode2 type(pm_ptr):: args,t,t2,tv,list,list2,namep - integer:: i,j,n,nret,nargs,nextra,slot,slot2,tbase,wbase + integer:: i,j,n,nret,nargs,slot,slot2,tbase,wbase integer:: vbase_check,tbase_check,counter,nerrors - integer:: save_par_kind integer,dimension(2):: key logical:: ok,isstatic,mayfail,undef_arg,cond integer(pm_ln):: k character(len=100):: str - type(pm_typ_einfo):: einfo if(pm_debug_checks) then vbase_check=coder%vtop tbase_check=coder%wtop endif - + nret=cnode_get_num(callnode,call_nret) sig=-cnode_get_num(callnode,call_sig) args=cnode_get(callnode,call_args) @@ -829,637 +1144,404 @@ subroutine prc_call(coder,cblock,callnode,base) ! Negative signatures indicate a control structure/special case ! call (with symbol sig) select case(sig) - case(sym_while) - list=cnode_arg(args,2) - list2=cnode_arg(args,4) + case(sym_while,sym_while_invar) + call check_loop_writes(4) + list=cnode_arg(args,1) + list2=cnode_arg(args,3) + coder%loop_depth=coder%loop_depth+1 counter=0 do - call clear_cblock_mark(list) - call clear_cblock_mark(list2) - call prc_cblock(coder,list,base) - call check_logical(3) - if(arg_type(3)==coder%false_name) return - call prc_cblock(coder,list2,base) - if(.not.(cblock_marked(list).or.& - cblock_marked(list2))) exit + if(coder%loop_depth==1) coder%types_changed=.false. + call inf_cblock(coder,list) + call check_logical(2,sig==sym_while_invar) + if(arg_type(2)==coder%false_fix) return + call inf_cblock(coder,list2) + if(.not.coder%types_changed.or.coder%loop_depth>1) exit counter=counter+1 if(counter>max_recur) then - call infer_error_with_trace(coder,args,& + call inf_error_with_trace(coder,args,& '"while" appears to lead to infinite types') exit endif enddo - if(cblock_has_comm(cnode_arg(args,2))& - .or.cblock_has_comm(cnode_arg(args,4))) then - call set_call_sig(merge(1,0,coder%par_kind2<=par_mode_conc)) - else - call set_call_sig(0) - endif - case(sym_until,sym_each) - list=cnode_arg(args,2) + coder%loop_depth=coder%loop_depth-1 + if(sig/=sym_while) call mark_loop_cond(5) + case(sym_until,sym_until_invar,sym_each) + call check_loop_writes(3) + list=cnode_arg(args,1) + coder%loop_depth=coder%loop_depth+1 counter=0 do - call clear_cblock_mark(list) - call prc_cblock(coder,list,base) - if(.not.cblock_marked(list)) exit + if(coder%loop_depth==1) coder%types_changed=.false. + call inf_cblock(coder,list) + if(.not.coder%types_changed.or.coder%loop_depth>1) exit counter=counter+1 if(counter>max_recur) then - call infer_error_with_trace(coder,args,& + call inf_error_with_trace(coder,args,& trim(sym_names(sig))//' appears to lead to infinite types') exit endif enddo - call check_logical(3) - if(cblock_has_comm(list)) then - call set_call_sig(merge(1,0,coder%par_kind<=par_mode_conc)) - else - call set_call_sig(0) - endif + call check_logical(2,sig==sym_until_invar) + coder%loop_depth=coder%loop_depth-1 + if(sig/=sym_until) call mark_loop_cond(5) case(sym_if,sym_if_invar) - call check_logical(1) - tno=arg_type(1) - list=cnode_arg(args,2) - if(tno/=coder%false_name) then - call prc_cblock(coder,list,base) - endif - list=cnode_arg(args,3) - if(tno/=coder%true_name) then - call prc_cblock(coder,list,base) - endif - case(sym_do,sym_for,sym_also) - call prc_cblock(coder,cnode_arg(args,1),base) - case(sym_sync) - call prc_cblock(coder,cnode_arg(args,2),base) - case(sym_over) - call prc_cblock(coder,cnode_arg(args,1),base) - call prc_cblock(coder,cnode_arg(args,2),base) - case(sym_import_val,sym_import_param) - tno=pm_typ_strip_mode(coder%context,arg_type_with_mode(2),mode) - coder%stack(get_slot(1))=pm_typ_add_mode(coder%context,tno,sym_shared,.false.) - if(tno>0.and.(coder%par_kind==par_mode_conc)) then - if(iand(pm_typ_flags(coder%context,tno),& - pm_typ_has_distributed)/=0) then - tno=pm_typ_strip_mode(coder%context,arg_type_with_mode(3),mode) - if(iand(pm_typ_flags(coder%context,tno),& - pm_typ_has_distributed)==0) then - if(cnode_get_name(callnode,cnode_modl_name)/=sym_pm_system) then - call infer_error_with_trace(coder,callnode,& - 'Cannot import distributed value into mirrored "forall"') - coder%stack(get_slot(1))=error_type - endif - endif - endif - endif - call flag_import_export(tno) - case(sym_import_varg) - tno=arg_type(2) - if(tno>0) then - t=pm_typ_vect(coder%context,arg_type(2)) - n=pm_tv_numargs(t) - call push_word(coder,pm_typ_new_tuple) - call push_word(coder,0) - do i=1,n - tno=pm_typ_strip_mode(coder%context,pm_tv_arg(t,i),mode) - if(iand(pm_typ_flags(coder%context,tno),pm_typ_has_distributed)/=0) then - call infer_error_with_trace(coder,callnode,& - 'Cannot use a distibuted shared value as an argument'//& - ' to a non-communicating operation') - endif - call push_word(coder,& - pm_typ_add_mode(coder%context,tno,sym_shared,.false.)) - enddo - call make_type(coder,n+2) - tno=pop_word(coder) - coder%stack(get_slot(1))=tno - call flag_import_export(tno) - endif - case(sym_import_shared) - tno=pm_typ_strip_mode(coder%context,arg_type_with_mode(2),mode) - coder%stack(get_slot(1))=pm_typ_add_mode(coder%context,tno,sym_shared,.false.) - call flag_import_export(tno) - case(sym_export) - tno=arg_type_with_mode(1) - mode=pm_typ_get_mode(coder%context,tno) - if(mode/=sym_coherent.and.mode/=sym_partial) then - call infer_error(coder,callnode,& - 'Cannot modify "'//trim(sym_names(mode))//'" variable as a "shared" value '//& - 'in a nested parallel statement: '//& - trim(pm_name_as_string(coder%context,& - cnode_get_name(cnode_arg(args,1),var_name)))) - call infer_error_with_trace(coder,cnode_arg(args,1),& - 'Definition of variable in above error') - endif - call flag_import_export(0) - case(sym_export_as_new,sym_export_param) - coder%stack(get_slot(1))=arg_type_with_mode(2) - call flag_import_export(arg_type(1)) - case(sym_amp_error) - if(nargs>0) then - coder%stack(get_slot(1))=arg_type_with_mode(2) - endif - call infer_error_with_trace(coder,callnode,& - 'Cannot change variable in different parallel context') + call inf_if(count_updates(cnode_arg(args,4),2),sig==sym_if_invar) + case(sym_pm_for,sym_pm_over) + call inf_cblock(coder,cnode_arg(args,2)) + case(sym_task) + do i=1,nargs,3 + call inf_cblock(coder,cnode_arg(args,i+1)) + call inf_cblock(coder,cnode_arg(args,i+2)) + enddo + case(sym_do) + call inf_cblock(coder,cnode_arg(args,1)) + case(sym_sync,sym_pm_shared,sym_pm_shared_always,sym_pm_chan,sym_pm_chan_always) + call inf_cblock(coder,cnode_arg(args,2)) + case(sym_pct) + call inf_cblock(coder,cnode_arg(args,2)) + case(sym_null) + do i=1,nret + coder%stack(get_slot(i))=pm_null + enddo case(sym_pm_send:sym_pm_serve) call check_long(5) coder%taints=ior(coder%taints,proc_is_impure) coder%stack(get_slot(1))=pm_long - tno=pm_typ_strip_mode_and_vect(coder%context,arg_type(4)) - t=pm_typ_vect(coder%context,tno) - if(pm_tv_kind(t)/=pm_typ_is_dref) then - call infer_error(coder,callnode,'Internal compiler error: Not a d-ref.') + tno=pm_type_strip_mode_and_vect(coder%context,arg_type(4)) + t=pm_type_vect(coder%context,tno) + if(pm_tv_kind(t)/=pm_type_is_dref) then + call inf_error(coder,callnode,'Internal compiler error: Not a d-ref.') endif - coder%stack(get_slot(2))=pm_typ_strip_mode_and_vect(coder%context,arg_type(4)) + coder%stack(get_slot(2))=pm_type_strip_mode_and_vect(coder%context,arg_type(4)) if(sig==sym_pm_send.or.sig==sym_pm_collect) then - coder%stack(get_slot(3))=pm_typ_strip_mode_and_vect(coder%context,arg_type(6)) + coder%stack(get_slot(3))=pm_type_strip_mode_and_vect(coder%context,arg_type(6)) else - coder%stack(get_slot(3))=pm_typ_strip_mode(coder%context,pm_tv_arg(t,1),mode) + coder%stack(get_slot(3))=pm_type_strip_mode(coder%context,pm_tv_arg(t,1),mode) endif - call prc_cblock(coder,cnode_arg(args,8),base) + call inf_cblock(coder,cnode_arg(args,8)) case(sym_pm_bcast) coder%taints=ior(coder%taints,proc_is_impure) coder%stack(get_slot(1))=arg_type(3) coder%stack(get_slot(2))=arg_type(4) call check_long(5) - call prc_cblock(coder,cnode_arg(args,6),base) + call inf_cblock(coder,cnode_arg(args,6)) case(sym_pm_recv_req) coder%taints=ior(coder%taints,proc_is_impure) coder%stack(get_slot(1))=pm_long - coder%stack(get_slot(2))=pm_typ_strip_mode_and_vect(coder%context,arg_type(3)) - call prc_cblock(coder,cnode_arg(args,5),base) + coder%stack(get_slot(2))=pm_type_strip_mode_and_vect(coder%context,arg_type(3)) + call inf_cblock(coder,cnode_arg(args,5)) case(sym_pm_recv_assn) coder%taints=ior(coder%taints,proc_is_impure) coder%stack(get_slot(1))=pm_long - coder%stack(get_slot(2))=pm_typ_strip_mode_and_vect(coder%context,arg_type(4)) - coder%stack(get_slot(3))=pm_typ_strip_mode_and_vect(coder%context,arg_type(5)) - call prc_cblock(coder,cnode_arg(args,7),base) + coder%stack(get_slot(2))=pm_type_strip_mode_and_vect(coder%context,arg_type(4)) + coder%stack(get_slot(3))=pm_type_strip_mode_and_vect(coder%context,arg_type(5)) + call inf_cblock(coder,cnode_arg(args,7)) case(sym_pm_do,sym_pm_do_at) do i=merge(1,3,sig==sym_pm_do),nargs-1,2 - coder%stack(get_slot(i))=pm_typ_strip_mode_and_vect(coder%context,arg_type(i+1)) + coder%stack(get_slot(i))=pm_type_strip_mode_and_vect(coder%context,arg_type(i+1)) enddo - call prc_cblock(coder,cnode_arg(args,nargs),base) + call inf_cblock(coder,cnode_arg(args,nargs)) case(sym_pm_head_node) - call prc_cblock(coder,cnode_arg(args,1),base) - case(sym_pm_dref:sym_pm_ref) - call push_word(coder,pm_typ_new_dref) - slot=coder%wtop - call push_word(coder,sym_pm_dref-sig-1) - if(nargs==3) then - t=pm_typ_vect(coder%context,arg_type(3)) - call push_word(coder,arg_type_with_mode(2)) - call push_word(coder,arg_type_with_mode(3)) - call push_word(coder,arg_type_with_mode(4)) - call push_word(coder,pm_tv_arg(t,4)) - call push_word(coder,pm_tv_arg(t,5)) - tno=0 - tno2=pm_tv_flags(t) - coder%wstack(slot)=ior(coder%wstack(slot),tno) - call make_type_if_possible(coder,7) - else - do i=1,nargs - call push_word(coder,arg_type_with_mode(i+1)) - enddo - if(debug_inference) then - do i=4,0,-1 - write(*,*) 'DREF[',i,']',& - trim(pm_typ_as_string(coder%context,coder%wstack(coder%wtop-i))) - enddo - endif - call make_type_if_possible(coder,nargs+2) - endif - if(debug_inference) write(*,*) 'DREF=',& - trim(pm_typ_as_string(coder%context,top_word(coder))) - coder%stack(get_slot(1))=pop_word(coder) - case(sym_hash) - if(arg_type(2)/=pm_null) then - call prc_cblock(coder,cnode_arg(args,1),base) - endif - case(sym_for_stmt) - coder%taints=ior(coder%taints,proc_needs_par) - tno=coder%par_kind - coder%stack(get_slot(1))=pm_long - coder%stack(get_slot(2))=tno - if(tno==error_type) tno=pm_null - if(tno>par_mode_multi_node.or.arg_type(7)==pm_null) then - save_par_kind=coder%par_kind2 - coder%par_kind2=coder%par_kind - if(tno>par_mode_multi_node) then - coder%par_kind=par_mode_inner - else - coder%par_kind=par_mode_conc - endif - slot=get_slot(1) - coder%stack(slot)=pm_long - slot=get_slot(2) - coder%stack(slot)=pm_null - call prc_cblock(coder,cnode_arg(args,4),base) - call prc_cblock(coder,cnode_arg(args,3),base) - call make_code(coder,pm_null_obj,cnode_is_any_sig,0) - coder%par_kind=coder%par_kind2 - coder%par_kind2=save_par_kind - else - save_par_kind=coder%par_kind2 - coder%par_kind2=coder%par_kind - coder%par_kind=par_mode_multi_node - nerrors=coder%num_errors - call prc_cblock(coder,cnode_arg(args,4),base) - list=cnode_arg(args,8) - list=cnode_arg(list,1) - slot=list%data%i(list%offset) - slot2=list%data%i(list%offset+1) - coder%stack(base+slot:base+slot2)=undefined - call prc_cblock(coder,cnode_arg(args,3),base) - coder%par_kind2=save_par_kind - if(coder%num_errors==nerrors) then - call code_int_vec(coder,coder%stack,base+slot,base+slot2) - coder%stack(base+slot:base+slot2)=undefined - coder%par_kind=par_mode_single_node - call prc_cblock(coder,cnode_arg(args,3),base) - if(coder%num_errors==nerrors) then - call code_int_vec(coder,coder%stack,base+slot,base+slot2) - call prc_cblock(coder,cnode_arg(args,5),base) - coder%par_kind=coder%par_kind2 - coder%par_kind2=save_par_kind - if(coder%num_errors==nerrors) then - call make_code(coder,pm_null_obj,cnode_is_any_sig,2) - else - call drop_code(coder) - call drop_code(coder) - return - endif - else - coder%par_kind=coder%par_kind2 - coder%par_kind2=save_par_kind - call drop_code(coder) - return - endif - else - coder%par_kind=coder%par_kind2 - coder%par_kind2=save_par_kind - return - endif - endif - list=pop_code(coder) - key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,1,list) - call set_call_sig(int(k)) - case(sym_pct) - if(nargs==1) then - call prc_cblock(coder,cnode_arg(args,1),base) - else - tno=arg_type(3) - slot=get_slot(1) - coder%stack(slot)=tno - call prc_cblock(coder,cnode_arg(args,2),base) - endif - case(sym_struct,sym_rec) + call inf_cblock(coder,cnode_arg(args,1)) + case(sym_pm_ref) + call push_word(coder,pm_type_new_dref) + call push_word(coder,cnode_num_arg(args,2)) + do i=2,nargs + call push_word(coder,arg_type_with_mode(i+1)) + enddo + call make_type(coder,nargs+1) + call combine_types(cnode_arg(args,1),pop_word(coder)) + case(sym_pm_each_index) + call inf_each_index + case(sym_pm_set_dotdotdot) + coder%stack(get_slot(1))=arg_type(2) + case(sym_rec) t=cnode_arg(args,2) t=cnode_arg(t,1) if(cnode_num_arg(args,3)>=0) then - tno=pm_user_typ_body(coder%context,cnode_num_arg(args,3)) - t2=pm_typ_vect(coder%context,tno) + tno=pm_user_type_body(coder%context,cnode_num_arg(args,3)) + t2=pm_type_vect(coder%context,tno) else tno=t%data%i(t%offset+1) - t2=pm_typ_vect(coder%context,pm_tv_arg(pm_typ_vect(coder%context,tno),1)) + t2=pm_type_vect(coder%context,pm_tv_arg(pm_type_vect(coder%context,tno),1)) endif name=t%data%i(t%offset+2) - if(sig==sym_struct) then - call push_word(coder,pm_typ_new_struct+t%data%i(t%offset+4)) - else - call push_word(coder,pm_typ_new_rec+t%data%i(t%offset+4)) - endif + call push_word(coder,pm_type_new_rec+t%data%i(t%offset+4)) call push_word(coder,t%data%i(t%offset)) - do i=1,nargs-2 - call push_word(coder,arg_type_with_mode(i+3)) + do i=1,nargs-3 + call push_word(coder,arg_type_with_mode(i+4)) enddo - mode=pm_typ_combine_modes(coder%context,& - coder%wstack(coder%wtop-nargs+3:coder%wtop),.false.,& - cnode_flags_set(callnode,call_flags,proc_run_complete),& - cnode_flags_set(callnode,call_flags,call_is_cond),& - cnode_flags_set(callnode,call_flags,call_is_unlabelled)) + mode=pm_type_combine_modes(coder%context,& + coder%wstack(coder%wtop-nargs+4:coder%wtop),& + cnode_flags_set(callnode,call_flags,call_is_cond).or.arg_type(4)==pm_logical,& + .false.) if(mode<0) then if(mode>-1000) then namep=pm_name_val(coder%context,pm_tv_name(t2)) - call infer_error_with_trace(coder,callnode,& - 'Cannot use a shared distributed value'//& + call inf_error_with_trace(coder,callnode,& + 'Cannot use a shared value'//& ' in "new" to initialise: '//& trim(pm_name_as_string(coder%context,& namep%data%i(namep%offset-mode)))) else - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& 'Cannot use a "prtl" value in "new" '//& 'in a "cplt" context to initialise: '//& trim(pm_name_as_string(coder%context,& namep%data%i(namep%offset-mode)))) endif - mode=sym_mirrored + mode=sym_invar endif - do i=1,nargs-2 - tno2=pm_typ_strip_mode(coder%context,coder%wstack(coder%wtop-nargs+2+i),mode2) + do i=1,nargs-3 + tno2=pm_type_strip_mode(coder%context,coder%wstack(coder%wtop-nargs+3+i),mode2) tno3=pm_tv_arg(t2,i) if(tno2==pm_tiny_int) then tno2=tno3 - if(tno2==0.or.iand(pm_typ_flags(coder%context,tno2),& - pm_typ_has_storage)/=0) then + if(tno2==0.or.iand(pm_type_flags(coder%context,tno2),& + pm_type_has_storage)/=0) then namep=pm_name_val(coder%context,pm_tv_name(t2)) - call infer_error(coder,callnode,'Element "'//& + call inf_error(coder,callnode,'Element "'//& trim(pm_name_as_string(coder%context,& namep%data%i(namep%offset+i)))//& - ':'//trim(pm_typ_as_string(coder%context,tno2))//'" of "'//& + ':'//trim(pm_type_as_string(coder%context,tno2))//'" of "'//& trim(pm_name_as_string(coder%context,name))//& '" needs to be initialised') endif endif - -!!$ tno4=pm_typ_convert(coder%context,tno3,tno2,sig==sym_struct) -!!$ if(tno4>0) then -!!$ if(iand(pm_typ_flags(coder%context,tno4),pm_typ_has_params)/=0) then -!!$ namep=pm_name_val(coder%context,pm_tv_name(t2)) -!!$ call infer_error(coder,callnode,'Element "'//& -!!$ trim(pm_name_as_string(coder%context,& -!!$ namep%data%i(namep%offset+i)))//& -!!$ ':'//trim(pm_typ_as_string(coder%context,tno4))//'" of "'//& -!!$ trim(pm_name_as_string(coder%context,name))//& -!!$ '" cannot be initialised') -!!$ call more_error(coder%context,& -!!$ 'unless the "new" statement supplies explict parameters for the type: new T(...) { }"') -!!$ endif -!!$ tno2=tno4 -!!$ !write(*,*) 'Converted to:',trim(pm_typ_as_string(coder%context,tno4)) -!!$ endif - - coder%wstack(coder%wtop-nargs+2+i)=tno2 + coder%wstack(coder%wtop-nargs+3+i)=tno2 enddo - call make_type_if_possible(coder,nargs) + call make_type_if_possible(coder,nargs-1) tno2=pop_word(coder) if(tno2>0) then - if(.not.pm_typ_includes(coder%context,tno,tno2,& - pm_typ_incl_val,einfo)) then - call infer_error(coder,callnode,& - '"'//trim(sym_names(sig))//& - '" initial expression has wrong type for: ',& - pm_fast_name(coder%context,name)) - call pm_typ_error(coder%context,einfo) - call infer_trace(coder) - tno2=error_type - endif - endif - tno2=pm_typ_add_mode(coder%context,tno2,mode,& - cnode_flags_set(callnode,call_flags,call_is_cond)) + if(.not.pm_type_includes(coder%context,tno,tno2,& + pm_type_incl_val)) then + call inf_error(coder,callnode,& + '"'//trim(sym_names(sig))//& + '" initial expression has wrong type for: ',& + pm_fast_name(coder%context,name)) + call more_error(coder%context,'Expected: '//trim(pm_type_as_string(coder%context,tno))) + call more_error(coder%context,'Got: '//trim(pm_type_as_string(coder%context,tno2))) + call inf_trace(coder) + tno2=error_type + endif + endif + tno2=pm_type_add_mode(coder%context,tno2,mode) call combine_types(cnode_arg(args,1),tno2) - case(sym_dot,sym_dot_ref,sym_get_dot,sym_get_dot_ref) - if(sig==sym_get_dot.or.sig==sym_get_dot_ref) then - tno=arg_type(3) - if(tno/=error_type) then - namep=pm_typ_vect(coder%context,arg_type(3)) - name=pm_tv_name(namep) - namep=pm_fast_name(coder%context,name) + case(sym_pm_list) + call push_word(coder,pm_type_new_tuple+pm_type_is_list) + call push_word(coder,0) + do i=1,nargs + call push_word(coder,arg_type_with_mode(i+1)) + enddo + mode=pm_type_mix_modes(coder%context,& + coder%wstack(coder%wtop-nargs+1:coder%wtop)) + call make_type_if_possible(coder,nargs+2) + tno2=pop_word(coder) + tno2=pm_type_add_mode(coder%context,tno2,mode) + call combine_types(cnode_arg(args,1),tno2) + case(sym_dot,sym_dot_ref) + name=arg_type(3) + tno=arg_type_with_mode(2) + if(tno==error_type.or.name==error_type) then + call set_arg_to_error_type(1) + else + if(tno>0) then + call set_call_sig(resolve_elem(cnode_arg(args,2),tno,name,& + sig==sym_dot_ref,.false.,tno2)) + call combine_types(cnode_arg(args,1),tno2) else call set_arg_to_error_type(1) - return endif - else - namep=cnode_arg(cnode_arg(args,3),1) - name=namep%offset endif - tno=pm_typ_strip_mode_and_cond(coder%context,& - arg_type_with_mode(2),mode,cond) + case(sym_open_brace) + ! Used in .{ } + ! Check type is literal string or literal integer + ! Cater for literal string of the form "_name" + tno=arg_type(2) if(tno>0) then - call set_call_sig(resolve_elem(tno,name,& - sig==sym_dot_ref.or.sig==sym_get_dot_ref,.false.,tno2)) - call combine_types(cnode_arg(args,1),& - pm_typ_add_mode(coder%context,tno2,mode,cond)) - else - call set_arg_to_error_type(1) + if(pm_type_kind(coder%context,tno)/=pm_type_is_single_name) then + tv=pm_type_vect(coder%context,arg_type(2)) + if(pm_tv_kind(tv)==pm_type_is_literal_value.or.pm_tv_kind(tv)==pm_type_is_fix_value) then + tno2=pm_tv_arg(tv,1) + if(tno2==pm_string_type) then + tno=pm_name_type_from_literal_string(coder%context,tno,& + cnode_module_name(callnode)) + if(tno<0) then + call inf_error(coder,callnode,& + 'String value in ".{}" is not a valid name') + tno=error_type + endif + elseif(tno2/=pm_long) then + call inf_error(coder,callnode,& + 'Expression in ".{}" must be a literal string or integer') + call more_error(coder%context,'Got: '//trim(pm_type_as_string(coder%context,tno2))) + call inf_trace(coder) + tno=error_type + endif + else + call inf_error(coder,callnode,& + 'Expression in ".{}" must be a literal string or integer') + call more_error(coder%context,'Got: '//trim(pm_type_as_string(coder%context,arg_type(2)))) + call inf_trace(coder) + tno=error_type + endif + endif endif - case(sym_method_call) - tno=arg_type(2) - namep=cnode_arg(cnode_arg(args,3),1) - name=namep%offset - slot=resolve_elem(tno,name,.false.,.false.,tno2) - if(slot/=0) then - call combine_types(cnode_arg(args,1),tno2) + coder%stack(get_slot(1))=tno + case(sym_dotdotdot) + ! Used in var ...x=y + ! Checks existing value of var + ! if it is an unintialised value type then convert to type-value + ! otherwise give an error + tno=get_var_type(coder,callnode,cnode_arg(args,2),init=.true.) + if(tno==error_type) then + call set_arg_to_error_type(1) + else + tv=pm_type_vect(coder%context,tno) + if(pm_tv_kind(tv)==pm_type_is_uninitialised) then + coder%stack(get_slot(1))=pm_tv_arg(tv,1) + else + call inf_error(coder,callnode,'Cannot initialise "var..." or "let..." twice') + endif endif - call set_call_sig(slot) - case(sym_default) - tno=cnode_num_arg(cnode_arg(args,2),1) - slot=get_slot(1) - coder%stack(slot)=tno case(sym_cast) ! Arg 3 is type to cast to (-ve if in a conditional context) +!!$ write(*,*) 'CAST',pm_type_as_string(coder%context,arg_type(2)),& +!!$ pm_type_as_string(coder%context,arg_type(3)) tno=arg_type(3) if(tno==error_type) then call set_arg_to_error_type(1) return endif - if(pm_typ_kind(coder%context,tno)==pm_typ_is_type) then - tno=pm_typ_arg(coder%context,tno,1) + if(pm_type_kind(coder%context,tno)==pm_type_is_type) then + tno=pm_type_arg(coder%context,tno,1) else - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& '"as" second argument is not a type') call set_arg_to_error_type(1) return endif - tno2=pm_typ_strip_mode_and_cond(coder%context,& - arg_type_with_mode(2),mode,cond) - k=prc_cast(coder,callnode,tno,tno2,.true.) + tno2=pm_type_strip_mode(coder%context,& + arg_type_with_mode(2),mode) + k=inf_cast(coder,callnode,tno,tno2,.true.) call set_call_sig(int(k)) call combine_types(cnode_arg(args,1),& - pm_typ_add_mode(coder%context,tno2,mode,cond)) + pm_type_add_mode(coder%context,tno2,mode)) case(sym_var_set_mode) mode2=cnode_num_arg(args,2) - coder%stack(get_slot(1))=pm_typ_add_mode(coder%context,& - pm_typ_strip_mode(coder%context,& - arg_type_with_mode(1),mode),mode2,.false.) - if(mode==sym_partial.or.& - mode2>=sym_mirrored.and.mode=sym_invar.and.mode=sym_mirrored) then - call infer_error(coder,callnode,& + case(sym_var) + tno=cnode_num_arg(args,nargs+nret) + do i=1,nret + call set_arg_to_type(i,tno) + enddo + case(sym_const) + tno=arg_type(1) + if(pm_type_kind(coder%context,tno)/=pm_type_is_uninitialised) then + call inf_error(coder,callnode,& + 'Cannot initialise constant twice in succession: ',& + cnode_get(cnode_arg(args,1),var_name)) + endif + case(sym_pm_assign) + tno=pm_type_get_mode(coder%context,arg_type_with_mode(1)) + if(tno>=sym_invar) then + call inf_error(coder,callnode,& 'Assignments to "'//trim(sym_names(tno))//& '" variables are not allowed outside of a "sync" statement') elseif(tno>=sym_chan) then - call infer_error(coder,callnode,& + call inf_error(coder,callnode,& 'Assignments to "'//trim(sym_names(tno))//& '" variables must be labelled in a conditional context') endif case(sym_type_val) tno=cnode_num_arg(cnode_arg(args,2),1) call combine_types(cnode_arg(args,1),& - pm_new_type_typ(coder%context,tno)) + pm_new_type_type(coder%context,tno)) case(sym_any) - list2=cnode_arg(args,4) - list2=cnode_arg(list2,1) - slot=list2%data%i(list2%offset) - slot2=list2%data%i(list2%offset+1) - tno=pm_typ_strip_mode_and_cond(coder%context,arg_type(3),mode,cond) - t=check_poly(coder,tno) - if(tno/=error_type.and..not.pm_fast_isnull(t)) then - n=pm_set_size(coder%context,t) - do i=1,n - list=pm_set_key(coder%context,t,int(i,pm_ln)) - tno=list%data%i(list%offset) - coder%stack(base+slot:base+slot2)=undefined - coder%stack(get_slot(1))=& - pm_typ_add_mode(coder%context,tno,mode,cond) - call prc_cblock(coder,cnode_arg(args,2),base) - call code_int_vec(coder,coder%stack,base+slot,base+slot2) - enddo - call make_code(coder,pm_null_obj,cnode_is_any_sig,n) - list=pop_code(coder) - if(.not.coder%incomplete) then - key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,1,list) - call set_call_sig(int(k)) - endif - else - coder%stack(base+slot:base+slot2)=undefined - call set_arg_to_error_type(1) - call prc_cblock(coder,cnode_arg(args,2),base) - endif - case(sym_each_proc) ! this controls body for proc.. each() - t=cnode_arg(args,nret+4) - t=cnode_arg(t,1) - slot=t%data%i(t%offset) - slot2=t%data%i(t%offset+1) - tno=arg_type(nret+5) - if(tno<=0) then - do i=1,nret - call set_arg_to_error_type(i) - enddo - return - endif - t=pm_typ_vect(coder%context,tno) - tno2=pm_tv_kind(t) - flags=iand(pm_tv_flags(t),pm_typ_has_embedded) - name=pm_tv_name(t) - n=nargs-4 - if(tno2==pm_typ_is_struct.or.tno2==pm_typ_is_rec) then - do i=nret+7,nargs-1,2 - tno=arg_type(i) - t2=pm_typ_vect(coder%context,tno) - if(pm_tv_kind(t2)/=tno2) then - if(coder%num_errors==0) & - call infer_error_with_trace(coder,callnode,& - '"proc <>" arguments cannot mix "struct" and "rec"') - endif - if(pm_tv_name(t2)/=name) then - if(coder%num_errors==0) & - call infer_error_with_trace(coder,callnode,& - '"proc <>" arguments must have the same "struct" or "rec" name') - endif - enddo - n=pm_tv_numargs(t) - if(nret>0) then - call check_wstack(coder,nret*(n+2)) - tbase=coder%wtop - coder%wtop=coder%wtop+nret*(n+2) - do i=1,nret - coder%wstack(tbase+(i-1)*(n+2)+1)=ior(tno2,flags) - coder%wstack(tbase+(i-1)*(n+2)+2)=name - enddo - endif - do i=1,n - do j=nret+5,nargs-1,2 - tno=arg_type(j) - t2=pm_typ_vect(coder%context,tno) - tno=pm_tv_arg(t2,i) - coder%stack(get_slot(j+1))=tno - enddo - call prc_cblock(coder,cnode_arg(args,nret+3),base) - do j=1,nret - coder%wstack(tbase+(j-1)*(n+2)+i+2)=arg_type(nargs+j) - enddo - call code_int_vec(coder,coder%stack,base+slot,base+slot2) - enddo - call make_code(coder,pm_null_obj,cnode_is_any_sig,n) - list=pop_code(coder) - key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,1,list) - slot=cnode_get_num(callnode,call_index) - coder%stack(base+slot)=k - tno3=pm_typ_from_recorded_name(coder%context,name) - do i=nret,1,-1 - call make_type_if_possible(coder,n+2) - if(.not.pm_typ_includes(coder%context,tno3,tno2,pm_typ_incl_val,einfo)) then - call infer_error(coder,args,& - '"'//trim(sym_names(tno2))//& - '" initial expression has wrong type for: ',& - pm_fast_name(coder%context,name)) - call pm_typ_error(coder%context,einfo) - call infer_trace(coder) - endif - coder%stack(get_slot(i))=pop_word(coder) - enddo - call prc_cblock(coder,cnode_arg(args,nret+1),base) - else - call prc_cblock(coder,cnode_arg(args,nret+2),base) - slot=cnode_get_num(callnode,call_index) - coder%stack(base+slot)=0 - endif + call inf_any(count_updates(cnode_arg(args,5),2)) case(sym_test) - call prc_cblock(coder,cnode_arg(args,1),base) + call inf_cblock(coder,cnode_arg(args,1)) case(sym_check) if(.not.pm_fast_isnull(cnode_arg(args,2))) then - call prc_cblock(coder,cnode_arg(args,2),base) + call inf_cblock(coder,cnode_arg(args,2)) endif - call prc_cblock(coder,cnode_arg(args,4),base) + call inf_cblock(coder,cnode_arg(args,4)) tno=arg_type(3) - if(arg_type(1)/=pm_string_type.and.arg_type(1)/=error_type) then - call infer_error_with_trace(coder,cnode_arg(args,1),& - 'Check message is not a string, got:'//& - trim(pm_typ_as_string(coder%context,arg_type(1)))) - elseif(tno==coder%false_name) then - if(cnode_get_kind(cnode_arg(args,1))==cnode_is_const) then - call pm_strval(cnode_arg(cnode_arg(args,1),1),str) - call infer_error_with_trace(coder,callnode,str(1:len_trim(str)-1)) + if(tno==coder%false_fix.or.tno==coder%false_literal) then + tno2=pm_type_strip_mode(coder%context,arg_type(1),mode) + t=pm_type_vect(coder%context,tno2) + if(pm_tv_kind(t)==pm_type_is_literal_value) then + if(pm_tv_arg(t,1)==pm_string_type) then + call pm_strval(pm_type_val(coder%context,tno2),str) + call inf_error_with_trace(coder,callnode,str(1:len_trim(str))) + else + call inf_error_with_trace(coder,callnode,& + 'Check condition will always fail and check message is not a string') + endif else - call infer_error_with_trace(coder,callnode,& + write(*,*) '@',pm_tv_kind(t),tno2 + call inf_error_with_trace(coder,callnode,& 'Check condition will always fail') endif - elseif(tno/=coder%true_name) then - call check_logical(3) - coder%stack(base-2)=ior(coder%stack(base-2),proc_is_impure) + elseif(pm_type_strip_to_basic(coder%context,arg_type(1))/=pm_string_type& + .and.arg_type(1)/=error_type) then + call inf_error_with_trace(coder,cnode_arg(args,1),& + 'Check message is not a string, got:'//& + trim(pm_type_as_string(coder%context,arg_type(1)))) + elseif(tno/=coder%true_fix.and.tno/=coder%true_literal) then + call check_logical(3,.false.) + coder%taints=ior(coder%taints,proc_is_impure) endif - case(sym_dash) + case(sym_fix,sym_literal) tno=arg_type(2) - t=pm_typ_vect(coder%context,tno) - if(iand(pm_tv_flags(t),pm_typ_has_storage)/=0) then - call infer_error_with_trace(coder,callnode,& - 'Value after '' cannot be determined at compile time') + t=pm_type_vect(coder%context,tno) + if(iand(pm_tv_flags(t),pm_type_has_storage)/=0) then + call inf_error_with_trace(coder,callnode,& + 'Value in "'//trim(sym_names(sig))//'" cannot be determined at compile time: '//& + trim(pm_type_as_string(coder%context,tno))) + endif + if(pm_tv_kind(t)==pm_type_is_literal_value) then + if(sig==sym_fix) then + tno=pm_new_fix_value_type(coder%context,pm_type_val(coder%context,tno),& + pm_tv_name(t)) + endif + else + tno=pm_new_literal_value_type(coder%context,pm_null_obj,0,tno) endif coder%stack(get_slot(1))=tno case(sym_dcaret) - coder%stack(get_slot(1))=pm_new_vect_typ(coder%context,arg_type(2)) + coder%stack(get_slot(1))=pm_type_add_mode(coder%context,& + pm_new_vect_type(coder%context,arg_type(2)),sym_shared) case(sym_open) if(nargs>0) then - t=pm_typ_vect(coder%context,coder%stack(base)) + t=pm_type_vect(coder%context,coder%atype) n=pm_tv_numargs(t) do i=1,nargs slot=get_slot(i) @@ -1469,7 +1551,7 @@ subroutine prc_call(coder,cblock,callnode,base) pm_tv_arg(t,i+n-nargs),pm_tv_numargs(t) enddo if(n>nargs) then - call push_word(coder,pm_typ_is_tuple) + call push_word(coder,pm_type_is_tuple) call push_word(coder,0) j=0 do i=nargs,n @@ -1481,77 +1563,39 @@ subroutine prc_call(coder,cblock,callnode,base) coder%stack(slot)=pop_word(coder) endif endif - coder%stack(base)=undefined case(sym_key) - t=cnode_arg(args,2) - t=cnode_arg(t,1) - slot2=coder%wstack(coder%proc_key_base+t%data%i(t%offset)) - coder%stack(get_slot(1))=slot2 + ! This is inferred in trav_proc + continue case(sym_present) - t=cnode_arg(args,4) - t=cnode_arg(t,1) - slot2=coder%wstack(coder%proc_key_base+t%data%i(t%offset)) - slot=arg_type(5) - if(slot/=slot2) then - if(slot2==pm_tiny_int) then - coder%wstack(coder%proc_key_base+t%data%i(t%offset))=slot - elseif(nargs>3) then - t=cnode_arg(args,6) - t=cnode_arg(t,1) - if(.not.pm_typ_includes(coder%context,t%data%i(t%offset),& - slot2,pm_typ_incl_val,& - einfo)) then - call infer_error(coder,callnode,'Keyword argument type mismatch:',& - cnode_get(cnode_arg(args,1),var_name)) - call more_error(coder%context,'Mismatched argument: '//& - trim(pm_typ_as_string(coder%context,slot2))) - call more_error(coder%context,'Parameter type constraint: '//& - trim(pm_typ_as_string(coder%context,t%data%i(t%offset)))) - call infer_trace(coder) - endif - slot=slot2 - else - t=cnode_arg(args,1) - t=cnode_get(t,var_name) - call infer_error(coder,callnode,& - 'Keyword argument type mismatch:',t) - call more_error(coder%context,'Mismatched argument: '//& - trim(pm_typ_as_string(coder%context,slot2))) - call more_error(coder%context,'Mismatched parameter: '//& - trim(pm_typ_as_string(coder%context,slot))) - call infer_trace(coder) - endif - endif - coder%stack(get_slot(1))=slot - coder%stack(get_slot(2))=pm_logical + call combine_types(cnode_arg(args,1),int(pm_logical)) case(sym_result) call get_arg_types_and_modes call make_type_if_possible(coder,nargs+2) - coder%stack(base)=pop_word(coder) + coder%rtype=pop_word(coder) + case(sym_amp) + call get_arg_types_and_modes + call make_type_if_possible(coder,nargs+2) + coder%new_atype=pop_word(coder) case(sym_start_loop) - coder%stack(get_slot(2))=pm_logical - case(sym_underscore,sym_colon,sym_end_loop,sym_init_var) + coder%stack(get_slot(2))=pm_logical + case(sym_underscore,sym_colon,sym_end_loop) continue - case(sym_arg) - call combine_types(cnode_arg(args,1),arg_type(2)) case(first_pragma:last_pragma) if(sig==sym_infer_type.or.sig==sym_infer_type_and_stack) then - call prc_cblock(coder,cnode_arg(args,1),base) + call inf_cblock(coder,cnode_arg(args,1)) endif if(sig==sym_infer_stack) then call cnode_error(coder,callnode,'Type inference stack trace:',warn=.true.) endif if(sig==sym_infer_type_and_stack.or.sig==sym_infer_stack) then - call infer_trace(coder) + call inf_trace(coder) endif case(sym_pm_dump) - if(coder%first_pass) then - if(arg_type_with_mode(1)>0) then - call cnode_error(coder,callnode,'Type inference gives: '//& - trim(pm_typ_as_string(coder%context,arg_type_with_mode(1))),warn=.true.) - else - call cnode_error(coder,callnode,'Type inference fails',warn=.true.) - endif + if(arg_type_with_mode(1)>0) then + call cnode_error(coder,callnode,'Type inference gives: '//& + trim(pm_type_as_string(coder%context,arg_type_with_mode(1))),warn=.true.) + else + call cnode_error(coder,callnode,'Type inference fails',warn=.true.) endif case default if(sig>=0.and.sig<=num_sym) then @@ -1564,7 +1608,7 @@ subroutine prc_call(coder,cblock,callnode,base) end select else ! A positive signature (so sig<0) is a conventional procedure call - call prc_proc_call(coder,cblock,callnode,-sig,args,nargs,nret,base) + call inf_proc_call(coder,cblock,callnode,-sig,args,nargs,nret) endif ! Check stacks are in proper state (no stack leaks) @@ -1572,15 +1616,15 @@ subroutine prc_call(coder,cblock,callnode,base) if(vbase_check/=coder%vtop) then if(sig>0) write(*,*) 'in',sym_names(sig) write(*,*) 'MISMATCH-vstack',coder%vtop,vbase_check - call pm_panic('prc_call') + call pm_panic('inf_call') endif if(tbase_check/=coder%wtop) then if(sig>0) write(*,*) 'in',sym_names(sig) write(*,*) 'MISMATCH-wstack',coder%wtop,tbase_check - call pm_panic('prc_call') + call pm_panic('inf_call') endif endif - + contains include 'ftypeof.inc' include 'fesize.inc' @@ -1590,6 +1634,176 @@ subroutine prc_call(coder,cblock,callnode,base) include 'ftiny.inc' include 'ftypeno.inc' + subroutine inf_if(nupdates,isinvar) + integer,intent(in):: nupdates + logical,intent(in):: isinvar + integer,dimension(nupdates):: save_var_types + integer:: i,tno,typ + type(pm_ptr):: changelist,writelist,p,var + call check_logical(1,isinvar) + tno=arg_type(1) + changelist=cnode_arg(args,4) + writelist=cnode_arg(changelist,2) + if(tno/=coder%false_fix) then + if(tno==coder%true_fix.or.pm_fast_isnull(cnode_arg(args,3))) then + call inf_cblock(coder,cnode_arg(args,2)) + else + i=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + save_var_types(i)=get_var_type(coder,callnode,var,init=.true.) + p=p%data%ptr(p%offset+1) + i=i+1 + end do + call inf_cblock(coder,cnode_arg(args,2)) + i=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + typ=save_var_types(i) + save_var_types(i)=get_var_type(coder,callnode,var,init=.true.) + call set_var_type(coder,var,typ) + p=p%data%ptr(p%offset+1) + i=i+1 + end do + call inf_cblock(coder,cnode_arg(args,3)) + i=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + call combine_var_type(coder,callnode,var,save_var_types(i),no_init=.true.) + p=p%data%ptr(p%offset+1) + i=i+1 + end do + endif + else + call inf_cblock(coder,cnode_arg(args,3)) + endif + end subroutine inf_if + + subroutine inf_any(nupdates) + integer,intent(in):: nupdates + integer,dimension(nupdates):: init_var_types,final_var_types + integer:: i,j,slot,slot2 + type(pm_ptr):: changelist,writelist,list,list2,var,p,tv + list2=cnode_arg(args,4) + list2=cnode_arg(list2,1) + changelist=cnode_arg(args,5) + writelist=cnode_arg(changelist,2) + slot=list2%data%i(list2%offset) + slot2=list2%data%i(list2%offset+1) + tno=pm_type_strip_mode(coder%context,arg_type(3),mode) + if(tno/=error_type) then + tv=pm_type_vect(coder%context,tno) + n=pm_tv_numargs(tv) + j=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + init_var_types(j)=get_var_type(coder,callnode,var) + p=p%data%ptr(p%offset+1) + j=j+1 + end do + do i=1,n + j=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + call set_var_type(coder,var,init_var_types(j)) + p=p%data%ptr(p%offset+1) + j=j+1 + end do + coder%stack(coder%base+slot:coder%base+slot2)=undefined + call set_arg_to_type(1,pm_type_add_mode(coder%context,pm_tv_arg(tv,i),mode)) + call inf_cblock(coder,cnode_arg(args,2)) + call code_int_vec(coder,coder%stack,coder%base+slot,coder%base+slot2) + + if(i>1) then + j=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + call combine_var_type(coder,callnode,var,final_var_types(j)) + p=p%data%ptr(p%offset+1) + j=j+1 + end do + endif + j=1 + p=writelist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + final_var_types(j)=get_var_type(coder,callnode,var) + p=p%data%ptr(p%offset+1) + j=j+1 + end do + enddo + call make_code(coder,pm_null_obj,cnode_is_any_sig,n) + if(.not.coder%incomplete) then + list=top_code(coder) + key(1)=pm_dict_size(coder%context,coder%proc_cache) + k=pm_idict_add(coder%context,coder%proc_cache,& + key,1,list) + call set_call_sig(int(k)) + endif + call drop_code(coder) + else + coder%stack(coder%base+slot:coder%base+slot2)=undefined + call set_arg_to_error_type(1) + call inf_cblock(coder,cnode_arg(args,2)) + endif + end subroutine inf_any + + subroutine inf_each_index() + type(pm_ptr):: p,tv + integer:: start,finish,tno,tno2,i,n,k,key(1) +!!! need to handle modes + + p=cnode_arg(args,nret+3) + p=cnode_arg(p,1) + start=p%data%i(p%offset) + finish=p%data%i(p%offset+1) + tno=arg_type(nret+1) + if(tno>0) then + k=pm_type_kind(coder%context,tno) + if(k==pm_type_is_literal_value.or.k==pm_type_is_fix_value) then + p=pm_type_val(coder%context,tno) + n=p%data%ln(p%offset) + else + call inf_error(coder,callnode,& + 'Internal error: PM__each_index: not a literal or fix int parameter') + endif + else + n=0 + endif + if(nret>1) then + call push_word(coder,pm_type_new_tuple+pm_type_is_list) + call push_word(coder,0) + endif + do i=1,n + coder%stack(coder%base+start:coder%base+finish)=undefined + coder%temp=pm_fast_newnc(coder%context,pm_long,1) + coder%temp%data%ln(coder%temp%offset)=i + coder%stack(get_slot(nret))=pm_new_fix_value_type(coder%context,coder%temp) + coder%temp=pm_null_obj + call inf_cblock(coder,cnode_arg(args,nret+2)) + call code_int_vec(coder,coder%stack,coder%base+start,coder%base+finish) + if(nret>1) then + call push_word(coder,arg_type_with_mode(nret+4)) + endif + enddo + if(nret>1) then + call make_type_if_possible(coder,n+2) + coder%stack(get_slot(1))=pop_word(coder) + endif + call make_code(coder,pm_null_obj,cnode_is_any_sig,n) + p=pop_code(coder) + key(1)=pm_dict_size(coder%context,coder%proc_cache) + k=pm_idict_add(coder%context,coder%proc_cache,& + key,1,p) + call set_call_sig(k) + end subroutine inf_each_index + !=================================================================== ! Push argument types with modes for all arguments !================================================================== @@ -1599,7 +1813,7 @@ subroutine get_arg_types_and_modes if(coder%wtop+nargs+2>max_code_stack) then call pm_panic('Program too complex') endif - coder%wstack(coder%wtop+1)=pm_typ_is_tuple + coder%wstack(coder%wtop+1)=pm_type_is_tuple coder%wstack(coder%wtop+2)=0 do i=1,nargs coder%wstack(coder%wtop+i+2)=arg_type_with_mode(nret+i) @@ -1613,24 +1827,25 @@ end subroutine get_arg_types_and_modes function arg_type_with_mode(m) result(tno) integer,intent(in):: m integer:: tno - integer:: slot - slot=get_slot_or_type(m) - if(slot<0) then - tno=-slot - else - tno=coder%stack(slot) - if(pm_debug_checks) then - if(tno==undefined) then - call qdump_code_tree(coder,pm_null_obj,6,& - cnode_arg(args,m),2) - call infer_error_with_trace(coder,args,'Internal Compiler Error: Broken type resulution::') - !!call pm_panic('Broken type resolution chain') - endif - endif - endif +!!$ integer:: slot + tno=get_arg_type(coder,callnode,cnode_arg(args,m)) +!!$ slot=get_slot_or_type(m) +!!$ if(slot<0) then +!!$ tno=-slot +!!$ else +!!$ tno=coder%stack(slot) +!!$ if(pm_debug_checks) then +!!$ if(tno==undefined) then +!!$ call qdump_code_tree(coder,pm_null_obj,6,& +!!$ cnode_arg(args,m),2) +!!$ call inf_error_with_trace(coder,args,& +!!$ 'Internal Compiler Error: Broken type resulution::') +!!$ !!call pm_panic('Broken type resolution chain') +!!$ endif +!!$ endif +!!$ endif end function arg_type_with_mode - !=================================================================== ! Return the type for argument m (errors are checked) !================================================================== @@ -1638,61 +1853,61 @@ function arg_type(m) result(tno) integer,intent(in):: m integer:: tno integer:: mode - tno=pm_typ_strip_mode(coder%context,arg_type_with_mode(m),mode) + tno=pm_type_strip_mode(coder%context,arg_type_with_mode(m),mode) end function arg_type - - !=================================================================== - ! Return the type and mode for arguement m (no error check) - !================================================================== - function arg_type_noerr(m) result(tno) - integer,intent(in):: m - integer:: tno - integer:: slot - slot=get_slot_or_type(m) - if(slot<0) then - tno=-slot - else - tno=coder%stack(slot) - endif - end function arg_type_noerr - - !=================================================================== - ! Return the slot for arguement m (or -ve of typeno for a constant) - !================================================================== - function get_slot_or_type(m) result(slotno) - integer,intent(in):: m - integer:: slotno - type(pm_ptr):: v - v=cnode_arg(args,m) - - if(cnode_get_kind(v)==cnode_is_const) then - slotno=-cnode_num_arg(v,2) - else - slotno=cnode_get_num(v,var_index)+base - endif - end function get_slot_or_type - - !=================================================================== - ! Return the slot and type for arguement m - ! - slot will be -ve for a constant - !================================================================== - subroutine get_slot_and_type(m,slot,tno) - integer,intent(in):: m - integer,intent(out):: slot - integer,intent(out):: tno - slot=get_slot_or_type(m) - if(slot<0) then - tno=-slot - else - tno=coder%stack(slot) - if(pm_debug_checks) then - if(tno==undefined) then - call infer_error_with_trace(coder,args,'Internal Compiler Error: Broken type resulution::') - endif - endif - endif - end subroutine get_slot_and_type +!!$ !=================================================================== +!!$ ! Return the type and mode for arguement m (no error check) +!!$ !================================================================== +!!$ function arg_type_noerr(m) result(tno) +!!$ integer,intent(in):: m +!!$ integer:: tno +!!$ integer:: slot +!!$ slot=get_slot_or_type(m) +!!$ if(slot<0) then +!!$ tno=-slot +!!$ else +!!$ tno=coder%stack(slot) +!!$ endif +!!$ end function arg_type_noerr + +!!$ !=================================================================== +!!$ ! Return the slot for arguement m (or -ve of typeno for a constant) +!!$ !================================================================== +!!$ function get_slot_or_type(m) result(slotno) +!!$ integer,intent(in):: m +!!$ integer:: slotno +!!$ type(pm_ptr):: v +!!$ v=cnode_arg(args,m) +!!$ +!!$ if(cnode_get_kind(v)==cnode_is_const) then +!!$ slotno=-cnode_num_arg(v,2) +!!$ else +!!$ slotno=cnode_get_num(v,var_index)+coder%base +!!$ endif +!!$ end function get_slot_or_type + +!!$ !=================================================================== +!!$ ! Return the slot and type for arguement m +!!$ ! - slot will be -ve for a constant +!!$ !================================================================== +!!$ subroutine get_slot_and_type(m,slot,tno) +!!$ integer,intent(in):: m +!!$ integer,intent(out):: slot +!!$ integer,intent(out):: tno +!!$ slot=get_slot_or_type(m) +!!$ if(slot<0) then +!!$ tno=-slot +!!$ else +!!$ tno=coder%stack(slot) +!!$ if(pm_debug_checks) then +!!$ if(tno==undefined) then +!!$ call inf_error_with_trace(coder,args,& +!!$ 'Internal Compiler Error: Broken type resulution::') +!!$ endif +!!$ endif +!!$ endif +!!$ end subroutine get_slot_and_type !=================================================================== ! Return the slot for arguement m (which must be a var) @@ -1706,30 +1921,52 @@ function get_slot(m) result(slotno) if(cnode_get_kind(v)/=cnode_is_var) & call pm_panic('get_slot') endif - slotno=cnode_get_num(v,var_index)+base + slotno=cnode_get_num(v,var_index)+coder%base end function get_slot !================================================================== ! Check if argument m has logical type (bool in PM) !================================================================== - subroutine check_logical(m) + subroutine check_logical(m,isinvar) integer,intent(in):: m - integer:: slt - integer:: ty - integer:: i - type(pm_ptr):: tv - integer:: tno - tno=arg_type(m) + logical,intent(in):: isinvar + integer:: tno,mode + tno=arg_type_with_mode(m) if(tno/=error_type) then - if(tno/=pm_logical.and.& - tno/=coder%true_name.and.tno/=coder%false_name) then - call infer_error_with_trace(coder,callnode,& + tno=pm_type_strip_mode(coder%context,tno,mode) + if(tno/=pm_logical.and.tno/=coder%true_literal.and.tno/=coder%false_literal.and.& + tno/=coder%true_fix.and.tno/=coder%false_fix) then + call inf_error_with_trace(coder,callnode,& 'Expecting boolean expression, got: '//& - trim(pm_typ_as_string(coder%context,tno))) + trim(pm_type_as_string(coder%context,tno))) + endif + if(isinvar.and.mode/=sym_invar) then + call inf_error_with_trace(coder,callnode,& + 'Expecting "invar" expression, got: '//& + trim(sym_names(mode))) endif endif end subroutine check_logical + + !================================================================== + ! Set loop call signature to 1 if it is in a conditional + ! (incling masked) context + !================================================================== + subroutine mark_loop_cond(m) + integer,intent(in):: m + integer:: tno,mark + tno=arg_type(m) + if(tno==pm_logical) then + mark=1 + elseif(cnode_flags_set(callnode,call_flags,call_is_cond)) then + mark=1 + else + mark=0 + endif + call set_call_sig(mark) + end subroutine mark_loop_cond + !================================================================== ! Check if argument m has long type (int type in PM) !================================================================== @@ -1743,27 +1980,29 @@ subroutine check_long(m) tno=arg_type(m) if(tno/=error_type) then if(tno/=pm_long) then - call infer_error_with_trace(coder,callnode,& + call inf_error_with_trace(coder,callnode,& 'Expecting long expression, got: '//& - trim(pm_typ_as_string(coder%context,tno))) + trim(pm_type_as_string(coder%context,tno))) endif endif end subroutine check_long - - subroutine clear_cblock_mark(list) - type(pm_ptr),intent(in):: list - integer:: slot - slot=base+cnode_get_num(list,cblock_index) - coder%stack(slot)=0 - end subroutine clear_cblock_mark - function cblock_marked(list) result(marked) - type(pm_ptr),intent(in):: list - logical:: marked - integer:: slot - slot=base+cnode_get_num(list,cblock_index) - marked=coder%stack(slot)/=0 - end function cblock_marked + !======================================================================= + ! Check that variables updated in a loop call are not uninitialised + ! Arg #arg must contain the changelist + !======================================================================= + subroutine check_loop_writes(arg) + integer,intent(in):: arg + type(pm_ptr):: changelists,p,var + changelists=cnode_arg(args,arg) + p=cnode_arg(changelists,2) + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + tno=get_var_type(coder,callnode,var) + p=p%data%ptr(p%offset+1) + enddo + end subroutine check_loop_writes + !================================================================== ! Flag if an import or export option actually @@ -1773,9 +2012,9 @@ end function cblock_marked subroutine flag_import_export(tno) integer,intent(in):: tno integer:: tkind - tkind=pm_typ_kind(coder%context,tno) + tkind=pm_type_kind(coder%context,tno) call set_call_sig(& - merge(1,0,tkind/=pm_typ_is_dref.and.tkind/=pm_typ_is_vect)) + merge(1,0,tkind/=pm_type_is_dref.and.tkind/=pm_type_is_vect)) end subroutine flag_import_export !================================================================== @@ -1783,56 +2022,74 @@ end subroutine flag_import_export !================================================================== subroutine set_call_sig(k) integer,intent(in):: k - coder%stack(base+cnode_get_num(callnode,call_index))=k + coder%stack(coder%base+cnode_get_num(callnode,call_index))=k end subroutine set_call_sig !================================================================== ! Resolve signature for item.name - ! This is either 2.. for regular structures/records - ! or pm_typ_dref_offset + 2 .. for offset into a dref - ! (starting at 2 is for historical reasons and is horrible) !================================================================== - recursive function resolve_elem(tno,name,isref,isopt,elem_type) result(sig) - integer,intent(in):: tno,name + recursive function resolve_elem(var,tno,nametyp,isref,isopt,elem_type) result(sig) + type(pm_ptr),intent(in):: var + integer,intent(in):: tno,nametyp logical,intent(in):: isref,isopt - integer,intent(out):: elem_type - integer:: sig - integer:: base,key(2) + integer:: sig,tk type(pm_ptr):: svec - base=coder%wtop - sig=pm_typ_find_elem(coder%context,tno,name,isref,& - coder%wstack,coder%wtop,max_code_stack,elem_type,einfo) - if(sig<0) then - key(1)=-name - key(2)=tno - sig=-pm_ivect_lookup(coder%context,coder%proc_cache,key,2) - if(sig==0) then - svec=pm_fast_newnc(coder%context,pm_int,& - coder%wtop-base+1) - svec%data%i(svec%offset)=elem_type - svec%data%i(svec%offset+1:svec%offset+pm_fast_esize(svec))=& - coder%wstack(base+1:coder%wtop) - sig=-pm_idict_add(coder%context,coder%proc_cache,& - key,2,svec) - endif - elseif(sig==0) then + sig=pm_type_find_elem(coder%context,tno,nametyp,isref,& + elem_type) + if(sig==0) then if(.not.isopt) then - call infer_error_with_trace(coder,callnode,& - 'Error accessing element "'//& - trim(pm_name_as_string(coder%context,name))//& - '" of type "'//& - trim(pm_typ_as_string(coder%context,tno))//'"') - call pm_typ_error(coder%context,einfo) + tk=pm_type_kind(coder%context,tno) + if(tk==pm_type_is_error) then + call inf_type_error(coder,callnode,tno,var) + coder%stack(cnode_get_num(var,var_index)+coder%base)=error_type + elseif(tk==pm_type_is_uninitialised) then + call inf_error(coder,callnode,& + 'Cannot take an element of an uninitialised value: ',& + cnode_get(var,var_name)) + coder%stack(cnode_get_num(var,var_index)+coder%base)=error_type + elseif(tk/=pm_type_is_rec.and.tk/=pm_type_is_tuple) then + call inf_error(coder,callnode,& + 'Cannot take an element of a value of type: "'//& + trim(pm_type_as_string(coder%context,tno))//'": ',& + cnode_get(var,var_name)) + else + sig=pm_type_find_elem(coder%context,tno,nametyp,.false.,& + elem_type) + if(sig==0) then + call inf_error_with_trace(coder,callnode,& + 'An object of type "'//trim(pm_type_as_string(coder%context,tno))//'"'//& + ' does not have element "'//& + trim(pm_type_as_string(coder%context,nametyp))//'"') + else + call inf_error_with_trace(coder,callnode,& + 'Cannot modify element "'//& + trim(pm_type_as_string(coder%context,nametyp))//& + '" of type "'//& + trim(pm_type_as_string(coder%context,tno))//'"') + sig=0 + endif + endif endif elem_type=error_type endif - coder%wtop=base end function resolve_elem !================================================================== - ! Set argument m to have error type + ! Set argument m (which must be a var) to have type t + ! - overwrites original -- generally use combine_types + !================================================================== + subroutine set_arg_to_type(m,t) + integer:: m,t + integer:: slot + type(pm_ptr):: ptr + slot=get_slot(m) + coder%stack(slot)=t + end subroutine set_arg_to_type + + !================================================================== + ! Set argument m (which must be a var) to have error type !================================================================== subroutine set_arg_to_error_type(m) integer:: m @@ -1845,114 +2102,103 @@ end subroutine set_arg_to_error_type !================================================================== ! Augment the type stored in a given variable vararg by adding typ !================================================================== - subroutine combine_types(vararg,typ) + subroutine combine_arg_types(m,typ,no_init) + integer,intent(in):: m,typ + logical,intent(in),optional:: no_init + call combine_types(cnode_arg(args,m),typ,no_init=no_init) + end subroutine combine_arg_types + + !=================================================================== + ! Augment the type stored in a given variable vararg by adding typ + !================================================================== + subroutine combine_types(vararg,typ,no_init) type(pm_ptr),intent(in)::vararg integer,intent(in):: typ - integer:: slot - integer:: typ0,n - type(pm_ptr):: tv,p,q,var - if(typ==undefined) call pm_panic('combine types') - var=vararg - if(pm_debug_level>3) then - write(*,*) 'COMBINE TYPES> ',& - trim(pm_name_as_string(coder%context,cnode_get_name(var,var_name))) - endif - slot=base+cnode_get_num(var,var_index) - typ0=coder%stack(slot) - if(typ0<0) then - coder%stack(slot)=typ - elseif(typ/=typ0.and.typ/=error_type.and.typ0/=error_type.and.& - coder%num_errors==0) then - call cnode_error(coder,var,'Variable changed type:',& - cnode_get(var,var_name)) - call more_error(coder%context,& - trim(pm_typ_as_string(coder%context,typ))//' <> '//& - trim(pm_typ_as_string(coder%context,typ0))) - endif - + logical,intent(in),optional:: no_init + call combine_var_type(coder,cblock,vararg,typ,no_init=no_init) end subroutine combine_types - - end subroutine prc_call + + + end subroutine inf_call !================================================================== ! Conventional procedure call !================================================================== - subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) + subroutine inf_proc_call(coder,cblock,callnode,sig,args,num_args,nret) type(code_state),intent(inout):: coder type(pm_ptr),intent(in):: callnode,cblock,args - integer,intent(in):: sig,num_args,nret,base - logical:: is_comm,is_complete,is_cond,is_unlabelled,run_shared,ignore_rules - integer:: name,mode,mode2,expected_mode,i,j,tno,tno2,slot,flags - integer:: nargs,nkey,nextra,ressig,pdepth - logical:: undef_arg - type(pm_ptr):: arg,amps,proclist,t,tv + integer,intent(in):: sig,num_args,nret + logical:: is_comm,is_cond,is_unlabelled,ignore_rules + integer:: name,mode,mode2,i,j,tno,tno2,slot,flags + integer:: nargs,nkey,keybase,ressig,amps + logical:: undef_arg,bad_amp + type(pm_ptr):: arg,keys,keynames,amplocs,proclist,t,tv + nargs=num_args + if(debug_inference) then write(*,*) 'PROCESS PROC CALL>',& trim(sig_name_str(coder,int(sig))),'@',& callnode%data%ptr(callnode%offset+cnode_lineno)%offset if(cnode_get_kind(args)/=cnode_is_arglist) call pm_panic('not arglist') - call qdump_code_tree(coder,pm_null_obj,6,callnode,2) + !call qdump_code_tree(coder,pm_null_obj,6,callnode,2) endif + + ! extract characteristics of call + amps=cnode_get_num(callnode,call_amp) flags=cnode_get_num(callnode,call_flags) - is_comm=iand(flags,call_is_comm)/=0 - is_complete=iand(flags,proc_run_complete)/=0 - is_cond=iand(flags,call_is_cond+proc_run_complete+proc_run_shared)==call_is_cond + is_comm=iand(flags,proccall_is_comm)/=0 + is_cond=iand(flags,call_is_cond)/=0 is_unlabelled=iand(flags,call_is_unlabelled)/=0 ignore_rules=cnode_flags_set(callnode,call_flags,call_ignore_rules) - run_shared=iand(flags,proc_run_shared)/=0 - proclist=pm_dict_val(coder%context,coder%sig_cache,int(sig,pm_ln)) - nkey=cnode_get_num(callnode,call_nkeys) - nextra=0 - call push_word(coder,pm_typ_is_tuple) - call push_word(coder,0) - call check_wstack(coder,nargs) + if(sig/=0) then + proclist=pm_dict_val(coder%context,coder%sig_cache,int(sig,pm_ln)) + endif + undef_arg=.false. + bad_amp=.false. + + keys=cnode_get(callnode,call_keys) + keynames=cnode_get(callnode,call_key_names) + keybase=coder%wtop + if(.not.pm_fast_isnull(keys)) then + nkey=cnode_numargs(keys) + do i=1,nkey + tno=get_arg_type(coder,callnode,cnode_arg(keys,i)) + call push_word(coder,tno) + undef_arg=undef_arg.or.tno<=0 + enddo + else + nkey=0 + endif + + ! Push arguments types to stack + call push_word(coder,pm_type_is_tuple) + call push_word(coder,amps) + call check_wstack(coder,nargs) + do i=1,nargs - tno=arg_type_with_mode(i+nret) + tno=get_arg_type(coder,callnode,cnode_arg(args,i+nret)) coder%wstack(coder%wtop+i)=tno undef_arg=undef_arg.or.tno<=0 enddo - if(is_comm) then - pdepth=cnode_get_num(cnode_arg(args,1+nret),var_par_depth) - ! Modify modes of arguments if necessary - do i=3,nargs - arg=cnode_arg(args,i+nret) - ! Set arguments from outside this context to shared - if(cnode_get_kind(arg)==cnode_is_var) then - if(cnode_get_num(arg,var_par_depth)==pdepth) then - coder%wstack(coder%wtop+i)=& - pm_typ_replace_mode(coder%context,& - coder%wstack(coder%wtop+i),& - sym_shared,.false.) - endif - endif - ! In an unlabelled conditional context, set coherent to partial - if(is_unlabelled.and.& - pm_typ_get_mode(coder%context,coder%wstack(coder%wtop+i))==sym_coherent) then - coder%wstack(coder%wtop+i)=& - pm_typ_replace_mode(coder%context,& - coder%wstack(coder%wtop+i),& - sym_partial,.false.) + + if(is_comm) then + if(is_cond) then + coder%wstack(coder%wtop+num_comm_args)=pm_logical + else + if(coder%wstack(coder%wtop+num_comm_args)/=pm_logical) then + is_cond=.false. endif - enddo - elseif(run_shared) then - do i=1,nargs - if(cnode_get_kind(cnode_arg(args,i+nret))==cnode_is_var) then - if(.not.cnode_flags_set(cnode_arg(args,i+nret),var_flags,var_is_imported)) then - coder%wstack(coder%wtop+i)=& - pm_typ_replace_mode(coder%context,& - coder%wstack(coder%wtop+i),& - sym_shared,.false.) - endif - endif - enddo + endif endif + + ! Error return for error argument if(undef_arg) then do i=1,nret call set_arg_to_error_type(i) enddo - coder%wtop=coder%wtop-2 + coder%wtop=coder%wtop-2-nkey if(debug_inference) then write(*,*) 'END PROC CALL (FAILED ERR ARG)>',& trim(sig_name_str(coder,int(sig))),coder%stack(4),coder%vtop @@ -1962,89 +2208,59 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) ! Standard calls if(.not.is_comm) then + if(debug_inference) then do i=1,nargs write(*,*) 'PRE-STRIPPED',& - trim(pm_typ_as_string(coder%context,coder%wstack(coder%wtop+i))) + trim(pm_type_as_string(coder%context,coder%wstack(coder%wtop+i))) enddo endif ! Suspend 'no shared import' rule in system module code - ignore_rules=ignore_rules.or.cnode_get_name(callnode,cnode_modl_name)==sym_pm_system - +!!$ ignore_rules=ignore_rules.or.& +!!$ cnode_get_name(callnode,cnode_modl_name)==sym_pm_system +!!$ ! Implement mode combination rule for standard procedures - mode=pm_typ_combine_modes(coder%context,& - coder%wstack(coder%wtop+1:coder%wtop+nargs),& - ignore_rules.or.run_shared,is_complete,is_cond,is_unlabelled) + mode=pm_type_combine_modes(coder%context,& + coder%wstack(coder%wtop+1:coder%wtop+nargs),is_cond,& + ignore_rules) if(mode<0) then - if(mode>-1000) then - call call_error('Cannot pass a shared distributed value to a standard procedure') - call infer_error_with_trace(coder,cnode_arg(args,nret-mode),& - 'Cannot pass a shared distributed value to a standard procedure') - elseif(mode>-2000) then - call infer_error_with_trace(coder,cnode_arg(args,nret-mode-1000),& - 'Cannot pass a "partial" value to a "complete" procedure'//& - trim(sig_name_str(coder,int(sig)))) - elseif(.not.ignore_rules) then - call infer_error_with_trace(coder,cnode_arg(args,nret-mode-2000),& - 'Cannot pass a "coherent" value to a "complete" procedure in an unlabelled call in a conditional context: '//& - trim(sig_name_str(coder,int(sig)))) - endif - mode=sym_coherent - endif - - ! Argument mode rules for specialised run modes - if(.not.ignore_rules) then - if(is_complete.and.mode==sym_partial) then - call call_error(& - 'Cannot pass "partial" value to a procedure with "<>" attribute') - elseif(run_shared.and.mode>" attribute') - endif + call call_error('Cannot pass a shared value to a standard procedure') + call inf_error_with_trace(coder,cnode_arg(args,nret-mode),& + 'Cannot pass a shared value to a standard procedure') + mode=sym_private endif ! Rules for "&" arguments - !!! -- Need better error positioning - amps=cnode_get(callnode,call_amp) - if(.not.pm_fast_isnull(amps).and..not.ignore_rules) then - amps=pm_name_val(coder%context,int(amps%offset)) - do i=0,pm_fast_esize(amps) - tno2=pm_typ_strip_mode(coder%context,& - coder%wstack(coder%wtop+amps%data%i(amps%offset+i)+nkey),mode2) +!!! -- Need better error positioning + if(amps/=0.and..not.ignore_rules) then + amplocs=pm_name_val(coder%context,amps) + do i=0,pm_fast_esize(amplocs) + tno2=pm_type_strip_mode(coder%context,& + coder%wstack(coder%wtop+amplocs%data%i(amplocs%offset+i)+nkey),mode2) if(tno2>0) then - tv=pm_typ_vect(coder%context,tno2) - if(pm_tv_kind(tv)==pm_typ_is_dref) then + tv=pm_type_vect(coder%context,tno2) + if(pm_tv_kind(tv)==pm_type_is_dref) then do while(pm_tv_name(tv)>0) tno2=pm_tv_arg(tv,2) - tv=pm_typ_vect(coder%context,tno2) + tv=pm_type_vect(coder%context,tno2) enddo - if(pm_tv_kind(tv)==pm_typ_is_dref.and.& + if(pm_tv_kind(tv)==pm_type_is_dref.and.& pm_tv_name(tv)/=pm_dref_is_ref) then call call_error(& 'Cannot pass a mixed-mode reference as an "&" argument - must use "&&"') - coder%wstack(coder%wtop+amps%data%i(amps%offset+i)+nkey)=pm_tv_arg(tv,1) + coder%wstack(coder%wtop+amplocs%data%i(amplocs%offset+i)+nkey)=pm_tv_arg(tv,1) endif endif endif - if(is_complete) then - if(mode2/=sym_coherent.and.mode2/=sym_chan) then - call call_error('Cannot have "'//trim(sym_names(mode2))//& - '" "&" parameter alongside "<>" call attribute') - endif - elseif(run_shared) then - if(mode2/=sym_shared) then - call call_error('Cannot have "'//trim(sym_names(mode2))//& - '" "&" parameter alongside "<>" call attribute') - endif - elseif(mode2/=sym_partial.and.mode2/=sym_coherent.and.(mode2/=sym_chan.or.is_unlabelled)) then + if(mode2/=sym_private.and.(mode2/=sym_chan.or.is_unlabelled)) then if(mode2==sym_chan) then call call_error('Cannot change "chan" variable in an unlabelled conditional context') else call call_error('Cannot change "'//trim(sym_names(mode2))//& '" "&" variable outside of a "sync" statement') endif + bad_amp=.true. endif enddo endif @@ -2052,7 +2268,7 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) ! As this is standard call strip argument modes before passing do i=1,nargs coder%wstack(coder%wtop+i)=& - pm_typ_strip_mode(coder%context,coder%wstack(coder%wtop+i),mode2) + pm_type_strip_mode(coder%context,coder%wstack(coder%wtop+i),mode2) enddo endif @@ -2062,8 +2278,8 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) ! Deal with arg... if(cnode_flags_set(callnode,call_flags,call_is_vararg)) then if(top_word(coder)>0) then - t=pm_typ_vect(coder%context,top_word(coder)) - if(pm_tv_kind(t)==pm_typ_is_tuple) then + t=pm_type_vect(coder%context,top_word(coder)) + if(pm_tv_kind(t)==pm_type_is_tuple) then call drop_word(coder) do i=1,pm_tv_numargs(t) tno2=pm_tv_arg(t,i) @@ -2076,49 +2292,51 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) endif endif endif - + ! Now run the call itself do j=1,nret coder%stack(get_slot(j))=undefined enddo - if(cnode_flags_set(proclist,cnode_args+1,proc_is_var)) then - ressig=var_call(proclist,& - pm_dict_key(coder%context,coder%sig_cache,int(sig,pm_ln))) - else + if(sig==0) then + ressig=var_call(callnode) + else ressig=simple_proc_call(sig,proclist) - if(debug_inference) write(*,*) 'RESSIG>',ressig,coder%incomplete,& + endif + + if(debug_inference) then + write(*,*) 'RESSIG>',ressig,coder%incomplete,& 'for', trim(sig_name_str(coder,int(sig))) endif ! Standard procedure return modes if(.not.is_comm) then -!!$ ! If procedure just called is tainted 'variant' set return modes to private -!!$ if(iand(coder%proc_taints,proc_is_variant)/=0) then -!!$ mode=merge(sym_partial,sym_complete,is_cond) -!!$ endif ! Apply return mode to returned values - if(mode/=sym_coherent) then + if(mode/=sym_private) then do j=1,nret - coder%stack(get_slot(j))=pm_typ_replace_mode(coder%context,& - coder%stack(get_slot(j)),mode,is_cond) + coder%stack(get_slot(j))=pm_type_replace_mode(coder%context,& + coder%stack(get_slot(j)),mode) enddo endif + endif - ! Tidy up + if(debug_inference) then do j=1,nret write(*,*) 'RETURN',j,& - trim(pm_typ_as_string(coder%context,coder%stack(get_slot(j)))) + trim(pm_type_as_string(coder%context,coder%stack(get_slot(j)))) enddo endif - coder%wtop=coder%wtop-nargs-2 - slot=base+cnode_get_num(callnode,call_index) + + ! Tidy up + coder%wtop=coder%wtop-nargs-nkey-2 + slot=coder%base+cnode_get_num(callnode,call_index) coder%stack(slot)=ressig + if(debug_inference) then write(*,*) 'END PROC CALL>',& - trim(sig_name_str(coder,int(sig))),coder%stack(4),coder%vtop + trim(sig_name_str(coder,int(sig))),coder%stack(4),coder%vtop,ressig,slot,coder%base endif contains @@ -2127,394 +2345,143 @@ subroutine prc_proc_call(coder,cblock,callnode,sig,args,num_args,nret,base) include 'fisnull.inc' include 'ftiny.inc' - !=================================================================== - ! Return type, without mode, for argument m - !================================================================== - function arg_type(m) result(tno) - integer,intent(in):: m - integer:: tno - integer:: mode - tno=pm_typ_strip_mode(coder%context,arg_type_with_mode(m),mode) - end function arg_type - - !=================================================================== - ! Return type and mode for arguement m - !================================================================== - function arg_type_with_mode(m) result(tno) - integer,intent(in):: m - integer:: tno - integer:: slot - slot=get_slot_or_type(m) - if(slot<0) then - tno=-slot - else - tno=coder%stack(slot) - if(pm_debug_checks) then - if(tno==undefined) then - write(*,*) m,slot,pm_main_process - call qdump_code_tree(coder,pm_null_obj,6,& - cnode_arg(args,m),2) - call infer_error_with_trace(coder,args,'Broken::') - !call pm_panic('Broken type resolution chain') - endif - endif - endif - end function arg_type_with_mode - - !=================================================================== - ! Return the slot for arguement n (which must be a var) - !================================================================== - function get_slot(m) result(slotno) - integer,intent(in):: m - integer:: slotno - type(pm_ptr):: v - v=cnode_arg(args,m) - if(pm_debug_checks) then - if(cnode_get_kind(v)/=cnode_is_var) & - call pm_panic('get_slot') - endif - slotno=cnode_get_num(v,var_index)+base - end function get_slot - - !=================================================================== - ! Return the slot for arguement n (or -ve of typeno for a constant) - !================================================================== - function get_slot_or_type(m) result(slotno) - integer,intent(in):: m - integer:: slotno - type(pm_ptr):: v - v=cnode_arg(args,m) - - if(cnode_get_kind(v)==cnode_is_const) then - slotno=-cnode_num_arg(v,2) - else - slotno=cnode_get_num(v,var_index)+base - endif - end function get_slot_or_type - - !=================================================================== - ! Set argument m to the error type - !================================================================== - subroutine set_arg_to_error_type(m) - integer:: m - integer:: slot - type(pm_ptr):: ptr - slot=get_slot(m) - coder%stack(slot)=error_type - end subroutine set_arg_to_error_type - - !=================================================================== - ! Augment the type stored in a given variable vararg by adding typ - !================================================================== - subroutine combine_types(vararg,typ) - type(pm_ptr),intent(in)::vararg - integer,intent(in):: typ - integer:: slot - integer:: typ0,n - type(pm_ptr):: tv,p,q,var - if(typ==undefined) call pm_panic('combine types') - var=vararg - if(pm_debug_level>3) then - write(*,*) 'COMBINE TYPES> ',& - trim(pm_name_as_string(coder%context,cnode_get_name(var,var_name))) - endif - slot=base+cnode_get_num(var,var_index) - typ0=coder%stack(slot) - if(typ0<0) then - coder%stack(slot)=typ - elseif(typ/=typ0.and.typ/=error_type.and.typ0/=error_type.and.& - coder%num_errors==0) then - call cnode_error(coder,var,'Variable changed type:',& - cnode_get(var,var_name)) - call more_error(coder%context,& - trim(pm_typ_as_string(coder%context,typ))//' <> '//& - trim(pm_typ_as_string(coder%context,typ0))) - endif - - end subroutine combine_types - - !========================================= - ! Print error message for a call - !========================================= - subroutine call_error(str) - character(len=*):: str - call infer_error(coder,callnode,str) - call print_call_details(coder,callnode,coder%wtop,nargs) - call infer_trace(coder) - end subroutine call_error - - !================================================ - ! Call with variable procedure name: v.(args) - !================================================ - function var_call(prlist,callsig) result(k) - type(pm_ptr),intent(in):: prlist,callsig - integer:: k - integer:: i,sig,rsig - type(pm_ptr):: pr,var,tv,tv2 - integer:: tno,tno2,name - logical:: err - ! Get value for procedure name (actually its type) - var=cnode_get(callnode,call_var) - if(cnode_get_kind(var)==cnode_is_var) then - tno=coder%stack(cnode_get_num(var,var_index)+base) - else - tno=cnode_num_arg(var,2) - endif - if(tno==error_type) then - do i=1,nret - call set_arg_to_error_type(i) - enddo - return - endif - tv=pm_typ_vect(coder%context,tno) - if(pm_tv_kind(tv)==pm_typ_is_par_kind) then - tno=pm_tv_arg(tv,1) - tv=pm_typ_vect(coder%context,tno) - endif - coder%wstack(coder%wtop-nargs)=tno - if(pm_tv_kind(tv)/=pm_typ_is_proc) then - call infer_error_with_trace(coder,callnode,& - 'Value does not hold proc name; got: '//& - trim(pm_typ_as_string(coder%context,tno))) - do i=1,nret - call set_arg_to_error_type(i) - enddo - k=undefined - return - endif - name=abs(pm_tv_name(tv)) - - ! Now look for a signature with this name and process it - rsig=undefined - do i=5,cnode_numargs(prlist),2 - if(name==cnode_num_arg(prlist,i)) then - sig=cnode_num_arg(prlist,i+1) - pr=pm_dict_val(coder%context,coder%sig_cache,int(sig,pm_ln)) - if(pm_tv_name(tv)>=0) then - rsig=simple_proc_call(sig,pr,issig=.true.) - else - tno2=pm_tv_arg(tv,1) - tv2=pm_typ_vect(coder%context,tno2) - rsig=simple_proc_call(sig,pr,sigpars=pm_tv_arg(tv2,1),& - sigtyp=tno,issig=.true.) - if(rsig>0) call check_call_against_sig(tno,tv,callsig) - endif - k=rsig - return - endif - enddo - call infer_error_with_trace(coder,callnode,& - 'No match found for ".()" call using procedure name: '//& - trim(pm_name_as_string(coder%context,name))) - k=undefined - end function var_call - - !======================================================= - ! If a call is v.(args) with v of a signature type - ! then it is necessary to check the call against - ! the signature - !======================================================= - subroutine check_call_against_sig(tno,tvp,callsig) - integer,intent(in):: tno - type(pm_ptr),intent(in):: tvp,callsig - integer:: tno2,i,k,tno3 - type(pm_ptr):: tv,tv2,tv3,amplocs - type(pm_typ_einfo):: einfo - integer:: nret,flags,n,mode,argmode - - tv=pm_typ_vect(coder%context,pm_tv_arg(tvp,1)) - - ! Get information on call - i=callsig%offset+pm_fast_esize(callsig) - nret=callsig%data%i(i-1) - flags=callsig%data%i(i-3) - - ! Check type of call - name=pm_tv_name(tv) - if(iand(flags,call_is_comm)/=0) then - if(name/=sym_pct) then - call infer_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_typ_as_string(coder%context,tno)) - call more_error(coder%context,& - 'Expecting communicating "%" procedure') - goto 10 - endif - elseif(name/=sym_proc) then - call infer_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_typ_as_string(coder%context,tno)) - call more_error(coder%context,& - 'Not expecting communicating "%" procedure') - goto 10 - endif - - ! Check returns - tno2=pm_tv_arg(tv,2) - tv2=pm_typ_vect(coder%context,tno2) - n=pm_tv_numargs(tv2) - if(nret/=n) then - call infer_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_typ_as_string(coder%context,tno)) - call more_error(coder%context,'Different number of return values') - goto 10 - endif - do i=1,n - if(.not.pm_typ_includes(coder%context,pm_tv_arg(tv2,i),& - arg_type(i),pm_typ_incl_val,einfo)) then - - !!!! Check conversion to interface/proc_sig - - call infer_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_typ_as_string(coder%context,tno)) - call more_error(coder%context,& - 'Return type mismatch: '//& - trim(pm_typ_as_string(coder%context,pm_tv_arg(tv2,i)))//& - ' vs: '//& - trim(pm_typ_as_string(coder%context,arg_type(i)))) - endif - enddo - - return -10 continue - - call infer_error(coder,callnode,& - 'Call does not match procedure type: '//& - pm_typ_as_string(coder%context,tno)) - call infer_trace(coder) - - end subroutine check_call_against_sig - !======================================================================== ! Procedure call for which signature has been resolved ! (either simple in the first place or an option for a vcall) ! - If err is present then no error messages - set err to true instead - ! - If sigpars/sigtyp present then introduce a signature type into the - ! procedure matching process - ! - If issig is present then disable visibility rule (for "." call) + ! - If sig_start is present then disable visibility rule (for "." call) !======================================================================== - function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) + function simple_proc_call(sig,procs,err,sig_start) result(ressig) integer,intent(in):: sig type(pm_ptr),intent(in):: procs logical,intent(out),optional:: err - integer,intent(in),optional:: sigpars,sigtyp - logical,intent(in),optional:: issig - integer:: k + integer,intent(in),optional:: sig_start + integer:: ressig - integer:: h,i,j,m,start,slot,pcheck,nkey_sig,jpass + integer:: h,i,j,m,start,slot,pcheck,nkey_sig,jpass,nconsidered integer:: vbase,wbase - type(pm_ptr):: v,proc,rtvect - integer:: rt,rt2,pars,mpars,apars,tno,match_pars - logical:: ok,found,visible,found_has_no_rtypes - integer:: save_proc_key_base,save_par_kind,save_par_kind2 - type(pm_ptr):: keynames - type(pm_typ_einfo):: einfo + type(pm_ptr):: tv,v,proc,match_proc,rtvect + integer:: rt,rt2,pars,mpars,apars,new_apars,tno,match_pars,pflags + logical:: ok,found,visible,found_has_no_rtypes,when_no_match integer,dimension(1):: key integer:: memo - - ! Save some state information - save_proc_key_base=coder%proc_key_base - coder%proc_key_base=coder%wtop-nargs - save_par_kind=coder%par_kind - save_par_kind2=coder%par_kind2 - + if(present(err)) err=.false. start=coder%vtop - keynames=cnode_arg(procs,1) - if(pm_fast_isnull(keynames)) then - nkey_sig=0 - else - nkey_sig=pm_set_size(coder%context,keynames) - endif + if(present(sig_start)) start=sig_start - ! For shared calls, step back par kinds - if(cnode_flags_set(callnode,call_flags,proc_run_shared)) then - coder%par_kind=coder%par_kind2 - endif + ! For procedure signature "." call then don't check visibility + ! .. also do not check visibility for yield(...) call + visible=present(sig_start).or.iand(flags,proccall_is_yield)/=0 ! Find matching signature - ! This is done in multiple passes with broader matching allowed in pass 2 - if(pm_debug_level>4) write(*,*) 'Checking',cnode_numargs(procs),' sigs' + ! This is done in multiple passes with increasingly broader matching + ! allowed in passes 1..3 + + if(debug_inference) write(*,*) 'Checking',cnode_numargs(procs),' sigs' found=.false. - ! For procedure signature "." call then don't check visibility - visible=present(issig) - do jpass=0,3 + apars=0 + + outer: do jpass=0,3 if(debug_inference) write(*,*) 'MATCH PASS> ',jpass - do i=3,cnode_numargs(procs),2 - pars=cnode_num_arg(procs,i) - - ! If this call is for a proc signature, then restrict matching to that signature - if(present(sigpars)) then - if(pm_typ_includes(coder%context,& - pars,sigpars,pm_typ_incl_typ,einfo)) then - mpars=sigpars - elseif(pm_typ_includes(coder%context,& - sigpars,pars,pm_typ_incl_typ,einfo)) then - mpars=pars - else - cycle - endif - else - mpars=pars - endif + nconsidered=0 + do i=1,cnode_numargs(procs) + proc=cnode_arg(procs,i) + if(debug_inference) write(*,*) 'CHECK nret',cnode_get_num(proc,pr_nret),nret,& + 'amps',cnode_get_num(proc,pr_amps),amps,& + 'comm',cnode_flags_set(proc,pr_flags,proccall_is_comm),is_comm,& + 'cflags',iand(cnode_get_num(proc,pr_flags),proccall_is_comm+proccall_is_ref+proccall_is_general),& + iand(flags,proccall_is_comm+proccall_is_ref+proccall_is_general) +!!$ call pm_dump_tree(coder%context,6,pm_name_val(coder%context,cnode_get_num(proc,pr_amps)),2) +!!$ call pm_dump_tree(coder%context,6,pm_name_val(coder%context,amps),2) + + if(cnode_get_num(proc,pr_nret)/=nret) cycle + if(cnode_get_num(proc,pr_amps)/=amps) cycle + pflags=cnode_get_num(proc,pr_flags) + if(iand(pflags,proccall_is_comm+proccall_is_ref+proccall_is_general)/=& + iand(flags,proccall_is_comm+proccall_is_ref+proccall_is_general)) cycle + if(iand(pflags,proc_is_cond)/=0.and..not.is_cond.or.& + iand(pflags,proc_is_uncond)/=0.and.is_cond) cycle + nconsidered=nconsidered+1 + + pars=cnode_get_num(proc,pr_ptype) if(debug_inference) then write(*,*) 'CHECKING SIG',(i-1)/2,& ' OF ',(cnode_numargs(procs)-2)/2,& - ' FOR>',trim(sig_name_str(coder,int(sig))) - write(*,*) '>> ',trim(pm_typ_as_string(coder%context,pars)) + ' FOR> ',trim(sig_name_str(coder,int(sig))) + write(*,*) '>> ',trim(pm_type_as_string(coder%context,pars)) endif wbase=coder%wtop vbase=coder%vtop - apars=check_call_sig(coder,callnode,cnode_arg(procs,i+1),& - mpars,nargs-nkey,nextra,jpass) + apars=match_call_sig(coder,callnode,proc,& + pars,nargs,call_flags,jpass) + if(apars>=0) then ! Check for a visible match - if(is_visible(coder,callnode,cnode_arg(procs,i+1))) visible=.true. + if(is_visible(coder,callnode,proc)) visible=.true. - ! If this is a second (or later) match, then check for compatibility + !!$ ! If this is a second (or later) match, then check for compatibility if(found) then - if(pm_typ_includes(coder%context,pars,& - match_pars,pm_typ_incl_typ,einfo)) then + if(debug_inference) write(*,*) 'SECOND MATCH>',& + trim(pm_type_as_string(coder%context,pars)),'AFTER>',& + trim(pm_type_as_string(coder%context,match_pars)) + if(pm_type_includes(coder%context,pars,& + match_pars,pm_type_incl_type)) then coder%wtop=wbase coder%vtop=vbase ! Have to also check compatibility of return types ! in the case where the enclosing procedure defines return types ! and the first-match procedure does not define them if(nret>0.and.rt>0.and.found_has_no_rtypes) then - rt2=abs(cnode_get_num(cnode_arg(procs,i+1),pr_rtype)) - if(pm_typ_kind(coder%context,rt2)/=pm_typ_is_undef_result) then - if(.not.pm_typ_includes(coder%context,rt2,rt,pm_typ_incl_typ,einfo)) then - call infer_error(coder,proc,& + rt2=abs(cnode_get_num(proc,pr_rtype)) + if(pm_type_kind(coder%context,rt2)/=pm_type_is_undef_result) then + if(.not.pm_type_includes(coder%context,rt2,rt,pm_type_incl_type)) then + call inf_error(coder,proc,& 'Procedure returns type(s) not compatible'//& ' with an enclosing procedure to which it conforms') - call pm_typ_error(coder%context,einfo) - call infer_error(coder,cnode_arg(procs,i+1),& + call inf_error(coder,cnode_arg(procs,i+1),& 'Enclosing procedure referenced in above error') call more_error(coder%context,' ') - call print_call_details(coder,callnode,coder%proc_key_base,nargs) - call infer_trace(coder) + call print_call_details(coder,callnode,keybase,nargs) + call inf_trace(coder) + endif + endif + endif + if(pm_type_has_when(coder%context,pars)) then + if(pm_type_includes(coder%context,match_pars,& + pars,pm_type_incl_type)) then + ! Two equally specific when procs - the second must have when(false) + coder%trace_depth=coder%trace_depth+1 + if(coder%trace_depth0.and.rt<0) then if(debug_inference) then write(*,*) 'INCOMPLETE PROC>',coder%vtop,start,coder%incomplete endif @@ -2559,19 +2525,26 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) call set_arg_to_error_type(j) enddo coder%vtop=start - coder%proc_key_base=save_proc_key_base coder%wtop=wbase - k=1234567 + ressig=undefined return else - if(coder%vtop/=pcheck+1) call pm_panic('pcheck mismatch') + !if(coder%vtop/=pcheck+1) call pm_panic('pcheck mismatch') endif - endif + endif + + found=.true. + match_pars=pars + match_proc=proc + found_has_no_rtypes=& + pm_type_kind(coder%context,cnode_get_num(match_proc,pr_rtype))==& + pm_type_is_undef_result if(nret>0) then if(rt>0) then - rtvect=pm_typ_vect(coder%context,rt) - if(pm_tv_kind(rtvect)==pm_typ_is_tuple) then + rtvect=pm_type_vect(coder%context,rt) + if(pm_tv_kind(rtvect)==pm_type_is_tuple.and.& + iand(pm_tv_flags(rtvect),pm_type_is_list)==0) then do j=1,nret v=cnode_arg(args,j) call combine_types(v,& @@ -2586,6 +2559,24 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) enddo endif endif + if(new_apars>0.and.amps/=0.and..not.bad_amp) then +!!$ write(*,*) 'Changing to',trim(pm_type_as_string(coder%context,new_apars)) + amplocs=pm_name_val(coder%context,amps) + rtvect=pm_type_vect(coder%context,new_apars) + if(pm_tv_kind(rtvect)==pm_type_is_tuple.and.& + iand(pm_tv_flags(rtvect),pm_type_is_list)==0) then + do j=0,pm_fast_esize(amplocs) + m=amplocs%data%i(amplocs%offset+j) + call combine_types(cnode_arg(args,m),pm_tv_arg(rtvect,j+1)) + enddo + else + m=amplocs%data%i(amplocs%offset) + call combine_types(cnode_arg(args,m),new_apars) + endif + endif + elseif(apars==error_type) then + if(debug_inference) write(*,*) 'TERMINATED>' + exit outer else ! Not this one - keep looking coder%vtop=vbase @@ -2595,52 +2586,64 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) if(debug_inference) write(*,*) 'CHECKED SIG' enddo if(found) exit - enddo + enddo outer if(debug_inference) then write(*,*) 'ALL SIGS CHECKED>',trim(sig_name_str(coder,int(sig))) endif - if(.not.found.or..not.visible) then + if(apars==error_type) then + do i=1,nret + call set_arg_to_error_type(i) + enddo + ressig=undefined + elseif(.not.found.or..not.visible) then ! If nothing found print error message ! or return error flag - if(.not.present(err)) then + if(present(err)) then + err=.true. + elseif(iand(flags,proccall_is_yield)==0) then if(.not.found) then call cnode_error(coder,callnode,& - 'No matching procedure:') + 'No matching procedure returning '//trim(pm_int_as_string(nret))//' value'//& + merge(': ','s:',nret==1)) else call cnode_error(coder,callnode,& - 'No matching procedure visible to module containing call') + 'No matching procedure is visible to the module containing the call') + call more_error(coder%context,'(expecting '//trim(pm_int_as_string(nret))//' return value'//& + merge(': ','s:',nret==1)) endif m=coder%wtop call make_type(coder,nargs+2) - call print_call_details(coder,callnode,coder%proc_key_base,nargs) + call print_call_details(coder,callnode,keybase,nargs) coder%wtop=m - if(present(sigtyp)) then - call more_error(coder%context,'Matching: '//& - trim(pm_typ_as_string(coder%context,sigtyp))) - else call more_error(coder%context,'Procedures considered:') - do m=3,cnode_numargs(procs),2 - pars=cnode_num_arg(procs,m) - call print_proc_details(coder,cnode_arg(procs,m+1),& - sig,& - cnode_flags_set(callnode,call_flags,call_is_comm),& - pars) - if(m>pm_opts%proc_list.and..not.pm_opts%see_all_procs) then + do m=1,cnode_numargs(procs) + proc=cnode_arg(procs,m) + if(nconsidered/=0) then + if(cnode_get_num(proc,pr_nret)/=nret) cycle + if(cnode_get_num(proc,pr_amps)/=amps) cycle + if(iand(cnode_get_num(proc,pr_flags),proccall_is_comm+proccall_is_ref+proccall_is_general)/=& + iand(flags,proccall_is_comm+proccall_is_ref+proccall_is_general)) cycle + endif + pars=cnode_get_num(proc,pr_ptype) + call print_proc_details(coder,proc) + if(m>pm_opts%proc_list.and..not.pm_opts%show_all_procs) then call more_error(coder%context,& - '... (to see all procedures use -fsee-all-procs)') + '... (to see all procedures use -fshow-all-procs)') exit endif enddo - endif - call infer_trace(coder) + + call inf_trace(coder) do i=1,nret call set_arg_to_error_type(i) enddo - k=undefined + ressig=undefined else - err=.true. + call cnode_error(coder,callnode,'Yield statement does not conform to supplied block') + call print_call_details(coder,callnode,keybase,nargs) + call inf_trace(coder) endif else ! Otherwise create resolved procedure cnode @@ -2648,355 +2651,394 @@ function simple_proc_call(sig,procs,err,sigpars,sigtyp,issig) result(k) call make_code(coder,pm_null_obj,cnode_is_autoconv_sig,& coder%vtop-start) key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,key,1,top_code(coder)) + ressig=pm_idict_add(coder%context,coder%proc_cache,key,1,top_code(coder)) else - k=coder%vstack(coder%vtop)%offset + ressig=coder%vstack(coder%vtop)%offset endif endif ! Tidy up coder%vtop=start - coder%proc_key_base=save_proc_key_base - coder%par_kind=save_par_kind - coder%par_kind2=save_par_kind2 - + end function simple_proc_call - - end subroutine prc_proc_call - + !================================================ + ! Call with variable procedure name: v.(args) + !================================================ + function var_call(callnode) result(ressig) + type(pm_ptr),intent(in):: callnode + integer:: ressig + integer:: i,sig,rsig,apars + type(pm_ptr):: pr,var,tv,tv2 + integer:: proctyp,tno,name,start,arg(1) + logical:: err - !================================================================= - ! Is procnode directly visible from module containing callnode? - !================================================================= - function is_visible(coder,callnode,procnode) result(ok) - type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: callnode,procnode - logical:: ok - integer:: callmodule,procmodule - integer:: key(2) - integer(pm_ln):: j - callmodule=cnode_get_name(callnode,cnode_modl_name) - procmodule=cnode_get_name(procnode,cnode_modl_name) - if(callmodule==procmodule.or.procmodule==sym_pm_system) then - ok=.true. - else - key(1)=callmodule - key(2)=procmodule - j=pm_ivect_lookup(coder%context,coder%visibility,key,2) - ok=j>0 - endif - end function is_visible - - ! ================================================================================ - ! Set up type inference frame - ! Three control slots: - ! base-2 == taints for current procedure - ! base-1 == break value -- flags changing types, resolution not complete if /= 0 - ! base == argument (on entry) return (on exit) types - ! Remaining slots: - ! base+index == resolution information according to var or call index - ! ================================================================================= - function create_stack_frame(coder,argtype,max_index,init_taints) result(base) - type(code_state),intent(inout):: coder - integer,intent(in):: argtype,max_index,init_taints - integer:: base - base=coder%top+3 - coder%top=base+max_index - if(coder%top>max_code_stack) & - call pm_panic('Program too complex (nested calls)') - call init_stack_frame(coder,base,argtype,init_taints) - end function create_stack_frame + ! Get value for procedure name (actually its type) + var=cnode_get(callnode,call_var) + if(cnode_get_kind(var)==cnode_is_var) then + proctyp=coder%stack(cnode_get_num(var,var_index)+coder%base) + else + proctyp=cnode_num_arg(var,2) + endif + if(proctyp==error_type) then + goto 999 + endif + tv=pm_type_vect(coder%context,proctyp) + if(pm_tv_kind(tv)==pm_type_is_par_kind) then + proctyp=pm_tv_arg(tv,1) + tv=pm_type_vect(coder%context,proctyp) + endif + coder%wstack(coder%wtop-nargs)=proctyp - !=============================================================== - ! (Re)initialise current stack frame - !=============================================================== - subroutine init_stack_frame(coder,base,argtype,init_taints) - type(code_state),intent(inout):: coder - integer,intent(in):: base,argtype,init_taints - integer:: i - coder%stack(base-2)=init_taints - coder%stack(base-1)=0 - coder%stack(base)=argtype - do i=base+1,coder%top - coder%stack(i)=undefined - enddo - end subroutine init_stack_frame + if(pm_tv_kind(tv)/=pm_type_is_proc) then + call inf_error_with_trace(coder,callnode,& + 'Value for ".()" call does not hold proc name, got: '//& + trim(pm_type_as_string(coder%context,proctyp))) + goto 999 + endif + name=abs(pm_tv_name(tv)) + arg(1)=name + sig=pm_ivect_lookup(coder%context,coder%sig_cache,arg,1) + if(sig>0) then + pr=pm_dict_val(coder%context,coder%sig_cache,int(sig,pm_ln)) + if(pm_tv_name(tv)>=0) then + start=coder%vtop + ressig=simple_proc_call(sig,pr,sig_start=start) + else + tno=pm_tv_arg(tv,1) + tv2=pm_type_vect(coder%context,tno) + call check_call_against_sig(proctyp,tv,callnode) + start=coder%vtop + apars=match_call_sig(coder,callnode,callnode,pm_tv_arg(tv2,1),nargs,& + cnode_get_num(callnode,call_flags),3,issig=.true.) + if(apars>0) then + ressig=simple_proc_call(sig,pr,sig_start=start) + if(ressig>0) call check_returns_against_sig(proctyp,tv,callnode) + ! Pop off extra set of arg types pushed by match_call_sig + coder%wtop=coder%wtop-nargs-2 + else + call inf_error(coder,callnode,& + 'Call arguments do not match procedure type'//& + ' and no conversions are available: '//& + pm_type_as_string(coder%context,proctyp)) + goto 999 + endif + endif + return + else + call inf_error_with_trace(coder,callnode,& + 'No match found for ".()" call using procedure name: '//& + trim(pm_name_as_string(coder%context,name))) + endif +999 continue + do i=1,nret + call set_arg_to_error_type(i) + enddo + ressig=undefined - !=============================================================== - ! Pop off current stack frame - !=============================================================== - subroutine pop_stack_frame(coder,base) - type(code_state),intent(inout):: coder - integer,intent(in):: base - coder%top=base-3 - end subroutine pop_stack_frame + write(*,*) 'var call end>',coder%wtop + end function var_call - !=============================================================== - ! Perform poly type conversion from typ2 to typ1 if possible - ! Return converted type or -1 on failure - !=============================================================== - function convert_poly(coder,typ1,typ2,conv_poly) result(typ3) - type(code_state),intent(inout):: coder - integer,intent(in):: typ1,typ2 - logical,intent(in):: conv_poly - integer:: typ3 - type(pm_ptr):: tv1,tv2 - type(pm_typ_einfo):: einfo - typ3=-1 - tv1=pm_typ_vect(coder%context,typ1) - tv2=pm_typ_vect(coder%context,typ2) - if(pm_tv_kind(tv1)==pm_typ_is_poly) then - if(pm_tv_kind(tv2)==pm_typ_is_poly) then - if(conv_poly.and.pm_typ_includes(coder%context,& - pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& - pm_typ_incl_typ,einfo)) then - if(add_poly_to_poly(coder,typ1,typ2)) then - coder%types_finished=.false. - endif - typ3=typ1 - endif - else - if(pm_typ_includes(coder%context,& - pm_tv_arg(tv1,1),typ2,& - pm_typ_incl_typ,einfo)) then - if(add_type_to_poly(coder,typ1,typ2)) then - coder%types_finished=.false. + !======================================================= + ! If a call is v.(args) with v of a signature type + ! then it is necessary to check call characteristics + ! against the signature + !======================================================= + subroutine check_call_against_sig(tno,tvp,callnode) + integer,intent(in):: tno + type(pm_ptr),intent(in):: tvp,callnode + type(pm_ptr):: tv + integer:: flags,kind + + tv=pm_type_vect(coder%context,pm_tv_arg(tvp,1)) + + ! Get information on call + flags=cnode_get_num(callnode,call_flags) + if(iand(flags,proccall_is_ref)/=0) then + kind=sym_dot + elseif(iand(flags,proccall_is_general)/=0) then + kind=sym_dash + elseif(iand(flags,proccall_is_comm)/=0) then + kind=sym_pct + else + kind=sym_proc + endif + + if(pm_tv_name(tv)/=kind) then + call inf_error(coder,callnode,& + 'Call does not match procedure type ("'//& + trim(pm_name_as_string(coder%context,pm_tv_name(tv)))//'" vs "'//& + trim(pm_name_as_string(coder%context,kind))//'"):'//& + trim(pm_type_as_string(coder%context,tno))) + endif + + if(iand(pm_tv_flags(tv),pm_type_is_yield)/=0.neqv.& + cnode_flags_set(callnode,call_flags,proccall_is_block)) then + call inf_error(coder,callnode,& + 'Call does not match procedure type ("yield")'//& + trim(pm_type_as_string(coder%context,tno))) + endif + + end subroutine check_call_against_sig + + !======================================================= + ! If a call is v.(args) with v of a signature type + ! then it is necessary to check the returned values against + ! the signature + !======================================================= + subroutine check_returns_against_sig(tno,tvp,callnode) + integer,intent(in):: tno + type(pm_ptr),intent(in):: tvp,callnode + type(pm_ptr):: tv2 + integer:: tno2,nret + integer:: tno3,i,k,n,at + + nret=cnode_get_num(callnode,call_nret) + + ! Check returns + tno2=pm_type_arg(coder%context,pm_tv_arg(tvp,1),2) + tv2=pm_type_vect(coder%context,tno2) + if(pm_tv_kind(tv2)==pm_type_is_undef_result) then + if(nret/=pm_tv_name(tv2)) then + call inf_error(coder,callnode,& + 'Call does not match procedure type: '//& + pm_type_as_string(coder%context,tno)) + call more_error(coder%context,'Call has a different number of return values: '//& + trim(pm_int_as_string(nret))//' vs '//trim(pm_int_as_string(pm_tv_name(tv2)))) + return + endif + else + n=pm_tv_numargs(tv2) + if(nret/=n) then + call inf_error(coder,callnode,& + 'Call does not match procedure type: '//& + pm_type_as_string(coder%context,tno)) + call more_error(coder%context,'Different number of return values: '//& + trim(pm_int_as_string(nret))//' vs '//trim(pm_int_as_string(n))) + return + endif + + do i=1,n + at=get_var_type(coder,callnode,cnode_arg(args,i)) + if(.not.pm_type_includes(coder%context,pm_tv_arg(tv2,i),& + at,pm_type_incl_val)) then + + call inf_error(coder,callnode,& + 'Call does not match procedure type: '//& + pm_type_as_string(coder%context,tno)) + call more_error(coder%context,& + 'Return type mismatch: '//& + trim(pm_type_as_string(coder%context,pm_tv_arg(tv2,i)))//& + ' vs: '//& + trim(pm_type_as_string(coder%context,at))) endif - typ3=typ1 - endif - endif - endif - end function convert_poly + enddo + endif + return +10 continue + + call inf_error(coder,callnode,& + 'Call does not match procedure type: '//& + pm_type_as_string(coder%context,tno)) + call inf_trace(coder) + + end subroutine check_returns_against_sig + +!!$ !=================================================================== +!!$ ! Return type, without mode, for argument m +!!$ !================================================================== +!!$ function arg_type(m) result(tno) +!!$ integer,intent(in):: m +!!$ integer:: tno +!!$ integer:: mode +!!$ tno=pm_type_strip_mode(coder%context,arg_type_with_mode(m),mode) +!!$ end function arg_type +!!$ +!!$ !=================================================================== +!!$ ! Return type and mode for arguement m +!!$ !================================================================== +!!$ function arg_type_with_mode(m) result(tno) +!!$ integer,intent(in):: m +!!$ integer:: tno +!!$ integer:: slot +!!$ slot=get_slot_or_type(m) +!!$ if(slot<0) then +!!$ tno=-slot +!!$ else +!!$ tno=coder%stack(slot) +!!$ if(pm_debug_checks) then +!!$ if(tno==undefined) then +!!$ write(*,*) m,slot,pm_main_process +!!$ call qdump_code_tree(coder,pm_null_obj,6,& +!!$ cnode_arg(args,m),2) +!!$ call inf_error_with_trace(coder,args,'Broken::') +!!$ !call pm_panic('Broken type resolution chain') +!!$ endif +!!$ endif +!!$ endif +!!$ end function arg_type_with_mode +!!$ + !=================================================================== + ! Return the slot for arguement n (which must be a var) + !================================================================== + function get_slot(m) result(slotno) + integer,intent(in):: m + integer:: slotno + type(pm_ptr):: v + v=cnode_arg(args,m) + if(pm_debug_checks) then + if(cnode_get_kind(v)/=cnode_is_var) & + call pm_panic('get_slot') + endif + slotno=cnode_get_num(v,var_index)+coder%base + end function get_slot +!!$ +!!$ !=================================================================== +!!$ ! Return the slot for arguement n (or -ve of typeno for a constant) +!!$ !================================================================== +!!$ function get_slot_or_type(m) result(slotno) +!!$ integer,intent(in):: m +!!$ integer:: slotno +!!$ type(pm_ptr):: v +!!$ v=cnode_arg(args,m) +!!$ +!!$ if(cnode_get_kind(v)==cnode_is_const) then +!!$ slotno=-cnode_num_arg(v,2) +!!$ else +!!$ slotno=cnode_get_num(v,var_index)+coder%base +!!$ endif +!!$ end function get_slot_or_type - !============================================================== - ! Return the working set for a given poly type - ! Returns a set type - !============================================================== - function check_poly(coder,poly_type) result(ptr) - type(code_state),intent(inout):: coder - integer,intent(in):: poly_type - type(pm_ptr):: ptr - integer(pm_ln):: j - integer,dimension(1):: key - key(1)=poly_type - j=pm_ivect_lookup(coder%context,coder%poly_cache,key,1) - if(j==0) then - ptr=pm_null_obj - else - ptr=pm_dict_val(coder%context,coder%poly_cache,j) - endif - end function check_poly + !=================================================================== + ! Set argument m to the error type + !================================================================== + subroutine set_arg_to_error_type(m) + integer:: m + integer:: slot + type(pm_ptr):: ptr + slot=get_slot(m) + coder%stack(slot)=error_type + end subroutine set_arg_to_error_type - !======================================================= - ! Add a type to the working set for a given poly type - ! Return whether working set has changed - !====================================================== - function add_type_to_poly(coder,poly_type,mtyp) result(changed) - type(code_state),intent(inout):: coder - integer,intent(in):: poly_type,mtyp - logical:: changed - integer,dimension(1):: key - integer(pm_ln):: j - type(pm_ptr):: v - key(1)=poly_type - j=pm_ivect_lookup(coder%context,coder%poly_cache,key,1) - if(j==0) then - coder%temp=pm_set_new(coder%context,32_pm_ln) - j=pm_idict_add(coder%context,& - coder%poly_cache,& - key,1,coder%temp) - key(1)=mtyp - j=pm_iset_add(coder%context,& - coder%temp,key,1) - changed=.true. - else - key(1)=mtyp - v=pm_dict_val(coder%context,coder%poly_cache,j) - j=pm_iset_add(coder%context,v,key,1,changed) - endif - end function add_type_to_poly - - !======================================================= - ! Add all types in poly_type2 to the working set for - ! poly type poly_type - ! Return whether working set has changed - !====================================================== - function add_poly_to_poly(coder,poly_type,poly_type2) result(changed) - type(code_state),intent(inout):: coder - integer,intent(in):: poly_type,poly_type2 - logical:: changed - type(pm_ptr):: typeset1,typeset2,type_entry - integer(pm_ln):: i,j,n - integer,dimension(1):: key - changed=.false. - typeset2=check_poly(coder,poly_type2) - if(pm_fast_isnull(typeset2)) return - typeset1=check_poly(coder,poly_type) - if(pm_fast_isnull(typeset1)) then - coder%temp=pm_set_new(coder%context,32_pm_ln) - key(1)=poly_type - j=pm_idict_add(coder%context,& - coder%poly_cache,& - key,1,coder%temp) - typeset1=coder%temp - endif - call pm_set_merge(coder%context,typeset1,typeset2,changed) - contains - include 'fisnull.inc' - end function add_poly_to_poly + !=================================================================== + ! Augment the type stored in a given variable vararg by adding typ + !================================================================== + subroutine combine_types(vararg,typ,no_init) + type(pm_ptr),intent(in)::vararg + integer,intent(in):: typ + logical,intent(in),optional:: no_init + call combine_var_type(coder,cblock,vararg,typ,no_init=no_init) + end subroutine combine_types + + !========================================= + ! Print error message for a call + !========================================= + subroutine call_error(str) + character(len=*):: str + call inf_error(coder,callnode,str) + call print_call_details(coder,callnode,coder%wtop,nargs) + call inf_trace(coder) + end subroutine call_error + + end subroutine inf_proc_call !==================================================== - ! Find procedure matching a given call signature - ! Call argument types must be on wstack + ! Check if a procedure matches a given call signature + ! - defined by parameter tuple type pars + ! Call argument types must be nargs entries on wstack + ! Returns tuple of argument types (after any conversion) + ! Conversions are covered by ipass (see match_arg) + ! !==================================================== - function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,ipass) result(tno) + function match_call_sig(coder,callnode,procnode,pars,& + nargs,flags,ipass,issig) result(argtyp) type(code_state),intent(inout):: coder - type(pm_ptr),intent(in):: callnode,matchnode + type(pm_ptr),intent(in):: callnode,procnode integer,intent(in):: pars - integer,intent(in):: nargs,ignore,ipass - integer:: tno - integer:: at,at2,pt,pt2,slot - type(pm_ptr):: pv,amb,av,vec - integer:: i,rel,n,base,wbase,pk,pk2,dbase,status - logical:: ok - type(pm_typ_einfo):: einfo + integer,intent(in):: nargs,flags,ipass + logical,intent(in),optional:: issig + integer:: argtyp + + logical:: nomatch,error + integer:: i,n,at,at2,pt,pk,wbase + type(pm_ptr):: pv + if(pars==error_type) then - tno=undefined + argtyp=undefined return endif - pv=pm_typ_vect(coder%context,pars) + pv=pm_type_vect(coder%context,pars) pk=pm_tv_kind(pv) + n=pm_tv_numargs(pv) + + if(n>nargs) then + argtyp=undefined + return + endif if(pm_debug_checks) then - if(pk/=pm_typ_is_tuple.and.& - pk/=pm_typ_is_vtuple) & + if(pk/=pm_type_is_tuple.and.& + pk/=pm_type_is_vtuple) & call pm_panic('check-sig') endif if(debug_inference) then - write(*,*) 'Check call sig: (' - write(*,*) pars,' ',trim(pm_typ_as_string(coder%context,pars)) + write(*,*) 'Check call sig: [ipass=',ipass,'] (' + write(*,*) pars,' ',trim(pm_type_as_string(coder%context,pars)) write(*,*) '----' do i=1,nargs at=coder%wstack(coder%wtop-nargs+i) - write(*,*) at,' ',trim(pm_typ_as_string(coder%context,at)) + write(*,*) at,' ',trim(pm_type_as_string(coder%context,at)) enddo write(*,*) ')' endif + ! Allocate space for new argument types on wstack wbase=coder%wtop if(coder%wtop+nargs+2>max_code_stack) then - call pm_panic('Program too complex (check-sig)') + call pm_panic('Program too complex (match-sig)') endif - - ! Start building return type on wstack coder%wtop=coder%wtop+nargs+2 - coder%wstack(wbase+1)=pm_typ_is_tuple + coder%wstack(wbase+1)=pm_type_is_tuple coder%wstack(wbase+2)=0 - n=pm_tv_numargs(pv) - if(n+ignore>nargs) then - tno=undefined - return - endif + + ! Process each argument, converting if required do i=1,nargs at=coder%wstack(wbase-nargs+i) - if(i<=ignore) then - coder%wstack(wbase+i+2)=at - cycle - endif if(at==undefined) call pm_panic('broken type resolution chain') if(at==error_type) then pt=0 cycle endif - if(i>n+ignore) then - if(pk/=pm_typ_is_vtuple) then - tno=undefined + if(i>n) then + if(pk/=pm_type_is_vtuple) then + argtyp=undefined goto 10 endif else - pt=pm_tv_arg(pv,i-ignore) + pt=pm_tv_arg(pv,i) endif - if(pm_typ_includes(coder%context,& - pt,at,pm_typ_incl_val,einfo)) then - coder%wstack(wbase+i+2)=at - if(debug_inference) then - write(*,*) 'Match',trim(pm_typ_as_string(coder%context,pt)),'<>',& - trim(pm_typ_as_string(coder%context,at)) - endif - else - if(einfo%kind==pm_typ_err_ambig) then - call cnode_error(coder,matchnode,& - 'Ambiguous match to proc definition ( match in multiple alternatives)') - call cnode_error(coder,callnode,'... call being processed') - elseif(ipass>=1) then - pt2=pm_typ_strip_to_basic(coder%context,pt) - at2=pm_typ_convert(coder%context,pt2,at,.false.) - if(at2/=undefined) then - coder%wstack(wbase+2+i)=at2 - goto 5 - endif - if(ipass==1) then - tno=undefined - goto 10 - elseif(ipass>=2) then - base=coder%wtop - ! Push index value for autoconv signature - call push_word(coder,nargs-i) - ! Check indirect inclusion - call pm_indirect_include(coder%context,pt,at,coder%wstack,max_code_stack,& - coder%wtop,einfo,at2,status) - if(status/=pm_elem_not_found) then - if(status==pm_elem_clash) then - call ambiguous_match_error(coder,callnode,pt,at,at2) - endif - ! Match with indirect inclusion - ! Make autoconv object - call code_int_vec(coder,coder%wstack,base+1,coder%wtop) - coder%wtop=base - ! Correct parameter type to post-conversion value - coder%wstack(wbase+i+2)=at2 - else - if(ipass==3) then - ! On third pass check for poly conversions - at2=convert_poly(coder,pt2,at,.false.) - if(at2/=-1) then - call push_word(coder,at2) - call code_int_vec(coder,coder%wstack,base+1,coder%wtop) - ! Correct parameter type to post-conversion value - coder%wstack(wbase+i+2)=at2 - goto 5 - endif - endif - - ! No match found - if(debug_inference) then - write(*,*) 'Does not include',& - trim(pm_typ_as_string(coder%context,pt)),'<>',& - trim(pm_typ_as_string(coder%context,at)) - endif - tno=undefined - goto 10 - endif - endif - else - ! No match found (pass 1) - if(debug_inference) then - write(*,*) 'Does not include',& - trim(pm_typ_as_string(coder%context,pt)),'<>',& - trim(pm_typ_as_string(coder%context,at)) - endif - tno=undefined - goto 10 - endif + + at2=match_arg(coder,callnode,procnode,pt,at,i,ipass,nomatch,error) + if(error.or.nomatch) then + argtyp=undefined + goto 10 endif -5 continue + coder%wstack(wbase+i+2)=at2 + enddo + + if(.not.present(issig)) then - ! Bundle arguments into a single type - tno=pm_new_typ(coder%context,coder%wstack(wbase+1:& - wbase+nargs+2)) + ! Bundle arguments into a single type + argtyp=pm_new_type(coder%context,coder%wstack(wbase+1:& + wbase+nargs+2)) + + else + argtyp=1 + return + + endif ! Error exit point 10 continue @@ -3007,90 +3049,588 @@ function check_call_sig(coder,callnode,matchnode,pars,nargs,ignore,ipass) result include 'fisnull.inc' include 'fnewnc.inc' include 'fesize.inc' - end function check_call_sig + end function match_call_sig + + !================================================================ + ! Match a single argument of type at to parameter type pt + ! applying automatic conversions as required + ! Returns converted argument type + ! nomatch - match failed + ! error - actual error raised (such as ambiguous match) + ! Any conversions will result in conversion record pushed on vstack + ! convesion record will refer to argument #ielem + ! Conversions applied are determined by ipass + ! 0 -- none + ! 1 -- lexical to basic + ! 2 -- proc type conversion + ! 3 -- convert to poly type + !================================================================ + function match_arg(coder,callnode,procnode,pt,old_at,ielem,ipass,nomatch,error) result(new_at) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,procnode + integer,intent(in):: pt,old_at,ielem,ipass + logical,intent(out):: nomatch,error + integer:: new_at + integer:: at,pt2,at2,base,status,flags + logical:: converted_to_poly + at=old_at + nomatch=.false. + error=.false. + flags=cnode_get_num(callnode,call_flags) + + if(iand(flags,call_is_fixed)==0) then + at2=pm_type_convert(coder%context,pt,at,iand(flags,call_keep_literals)==0,ipass>=2,.false.) + if(at2>0) at=at2 + endif + if(pm_type_includes(coder%context,& + pt,at,pm_type_incl_val)) then + if(debug_inference) then + write(*,*) 'Match',trim(pm_type_as_string(coder%context,pt)),'<>',& + trim(pm_type_as_string(coder%context,at)) + endif + new_at=at + return + else + at2=pm_type_convert(coder%context,pt,at,& + iand(flags,call_keep_literals+call_is_fixed)==0,ipass>=2,ipass>=3,converted_to_poly) + if(at2>0) then + if(pm_type_includes(coder%context,pt,at2,pm_type_incl_val)) then + if(debug_inference) then + write(*,*) 'Converted',trim(pm_type_as_string(coder%context,pt)),'<>',& + trim(pm_type_as_string(coder%context,at2)) + endif + if(converted_to_poly) then + base=coder%wtop + call push_word(coder,ielem) + call push_word(coder,at2) + call code_int_vec(coder,coder%wstack,base+1,coder%wtop) + ! Correct parameter type to post-conversion value + coder%wtop=base + endif + new_at=at2 + return + endif + endif + + ! No match found + if(debug_inference) then + write(*,*) 'Does not include',& + trim(pm_type_as_string(coder%context,pt)),'<>',& + trim(pm_type_as_string(coder%context,at)) + endif + nomatch=.true. + !coder%wtop=base + return + endif + end function match_arg + + + !================================================================= + ! Is procnode directly visible from module containing callnode? + !================================================================= + function is_visible(coder,callnode,procnode) result(ok) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,procnode + logical:: ok + integer:: callmodule,procmodule + integer:: key(2) + integer(pm_ln):: j + callmodule=cnode_get_name(callnode,cnode_modl_name) + procmodule=cnode_get_name(procnode,cnode_modl_name) + if(callmodule==procmodule.or.procmodule==sym_pm_system) then + ok=.true. + else + key(1)=callmodule + key(2)=procmodule + j=pm_ivect_lookup(coder%context,coder%visibility,key,2) + ok=j>0 + endif + end function is_visible + + + !=============================================================== + ! Create but do not intialise current stack frame + !=============================================================== + subroutine new_stack_frame(coder,max_index) + type(code_state),intent(inout):: coder + integer,intent(in):: max_index + coder%stack(coder%top+1)=coder%base + coder%base=coder%top+1 + coder%top=coder%base+max_index + if(coder%top>max_code_stack) & + call pm_panic('Program too complex (nested calls)') + end subroutine new_stack_frame + + !=============================================================== + ! Create and initialise a stack frame + !=============================================================== + subroutine create_stack_frame(coder,max_index) + type(code_state),intent(inout):: coder + integer,intent(in):: max_index + call new_stack_frame(coder,max_index) + call init_stack_frame(coder,coder%base,1,coder%top) + end subroutine create_stack_frame + + !=============================================================== + ! (Re)initialise current stack frame + ! Only slots first..last are initialised (as are control slots) + !=============================================================== + subroutine init_stack_frame(coder,base,first,last) + type(code_state),intent(inout):: coder + integer,intent(in):: base,first,last + integer:: i + do i=base+first,last + coder%stack(i)=undefined + enddo + end subroutine init_stack_frame + + !=============================================================== + ! Pop off current stack frame + !=============================================================== + subroutine pop_stack_frame(coder) + type(code_state),intent(inout):: coder + coder%top=coder%base-1 + coder%base=coder%stack(coder%base) + if(coder%base==0) call pm_panic('xxx') + end subroutine pop_stack_frame - ! =============================================================== - ! Error message for ambiguous match - ! (assumes wstack holds results from pm_indirect_include) - ! =============================================================== - subroutine ambiguous_match_error(coder,callnode,pt,at,at2) +!!$ !=============================================================== +!!$ ! Perform poly type conversion from typ2 to typ1 if possible +!!$ ! Return converted type or -1 on failure +!!$ !=============================================================== +!!$ function convert_poly(coder,typ1,typ2,conv_poly) result(typ3) +!!$ type(code_state),intent(inout):: coder +!!$ integer,intent(in):: typ1,typ2 +!!$ logical,intent(in):: conv_poly +!!$ integer:: typ3 +!!$ type(pm_ptr):: tv1,tv2 +!!$ if(typ1<=0) return +!!$ typ3=-1 +!!$ tv1=pm_type_vect(coder%context,typ1) +!!$ tv2=pm_type_vect(coder%context,typ2) +!!$ if(pm_tv_kind(tv1)==pm_type_is_poly) then +!!$ if(pm_tv_kind(tv2)==pm_type_is_poly) then +!!$ if(conv_poly.and.pm_type_includes(coder%context,& +!!$ pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& +!!$ pm_type_incl_type)) then +!!$ if(add_poly_to_poly(coder,typ1,typ2)) then +!!$ coder%types_finished=.false. +!!$ endif +!!$ typ3=typ1 +!!$ endif +!!$ else +!!$ if(pm_type_includes(coder%context,& +!!$ pm_tv_arg(tv1,1),typ2,& +!!$ pm_type_incl_type)) then +!!$ if(add_type_to_poly(coder,typ1,typ2)) then +!!$ coder%types_finished=.false. +!!$ endif +!!$ typ3=typ1 +!!$ endif +!!$ endif +!!$ endif +!!$ end function convert_poly +!!$ +!!$ !============================================================== +!!$ ! Return the working set for a given poly type +!!$ ! Returns a set type +!!$ !============================================================== +!!$ function check_poly(coder,poly_type) result(ptr) +!!$ type(code_state),intent(inout):: coder +!!$ integer,intent(in):: poly_type +!!$ type(pm_ptr):: ptr +!!$ integer(pm_ln):: j +!!$ integer,dimension(1):: key +!!$ key(1)=poly_type +!!$ j=pm_ivect_lookup(coder%context,coder%poly_cache,key,1) +!!$ if(j==0) then +!!$ ptr=pm_null_obj +!!$ else +!!$ ptr=pm_dict_val(coder%context,coder%poly_cache,j) +!!$ endif +!!$ end function check_poly +!!$ +!!$ !======================================================= +!!$ ! Add a type to the working set for a given poly type +!!$ ! Return whether working set has changed +!!$ !====================================================== +!!$ function add_type_to_poly(coder,poly_type,mtyp) result(changed) +!!$ type(code_state),intent(inout):: coder +!!$ integer,intent(in):: poly_type,mtyp +!!$ logical:: changed +!!$ integer,dimension(1):: key +!!$ integer(pm_ln):: j +!!$ type(pm_ptr):: v +!!$ key(1)=poly_type +!!$ j=pm_ivect_lookup(coder%context,coder%poly_cache,key,1) +!!$ if(j==0) then +!!$ coder%temp=pm_set_new(coder%context,32_pm_ln) +!!$ j=pm_idict_add(coder%context,& +!!$ coder%poly_cache,& +!!$ key,1,coder%temp) +!!$ key(1)=mtyp +!!$ j=pm_iset_add(coder%context,& +!!$ coder%temp,key,1) +!!$ changed=.true. +!!$ else +!!$ key(1)=mtyp +!!$ v=pm_dict_val(coder%context,coder%poly_cache,j) +!!$ j=pm_iset_add(coder%context,v,key,1,changed) +!!$ endif +!!$ end function add_type_to_poly +!!$ +!!$ !======================================================= +!!$ ! Add all types in poly_type2 to the working set for +!!$ ! poly type poly_type +!!$ ! Return whether working set has changed +!!$ !====================================================== +!!$ function add_poly_to_poly(coder,poly_type,poly_type2) result(changed) +!!$ type(code_state),intent(inout):: coder +!!$ integer,intent(in):: poly_type,poly_type2 +!!$ logical:: changed +!!$ type(pm_ptr):: typeset1,typeset2,type_entry +!!$ integer(pm_ln):: i,j,n +!!$ integer,dimension(1):: key +!!$ changed=.false. +!!$ typeset2=check_poly(coder,poly_type2) +!!$ if(pm_fast_isnull(typeset2)) return +!!$ typeset1=check_poly(coder,poly_type) +!!$ if(pm_fast_isnull(typeset1)) then +!!$ coder%temp=pm_set_new(coder%context,32_pm_ln) +!!$ key(1)=poly_type +!!$ j=pm_idict_add(coder%context,& +!!$ coder%poly_cache,& +!!$ key,1,coder%temp) +!!$ typeset1=coder%temp +!!$ endif +!!$ call pm_set_merge(coder%context,typeset1,typeset2,changed) +!!$ contains +!!$ include 'fisnull.inc' +!!$ end function add_poly_to_poly + + !================================================= + ! Get currently resolved type (&mode) for argument + ! (variable or constant) + !================================================= + function get_arg_type(coder,callnode,arg) result(tno) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,arg + integer:: tno + if(cnode_get_kind(arg)==cnode_is_var) then + tno=get_var_type(coder,callnode,arg) + else + if(pm_debug_checks) then + if(cnode_get_kind(arg)/=cnode_is_const) then + call pm_panic('get_arg_type') + endif + endif + tno=cnode_num_arg(arg,2) + endif + end function get_arg_type + + !============================================================================ + ! Get currently resolved type (&mode) for variable + ! Can pass call flags through init parameter + ! - call_takes_init - no error for unitialised value + ! - call_converts_uninit - Convert uninitialsed value to a type value + !============================================================================ + function get_var_type(coder,callnode,var,init) result(tno) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,var + logical,intent(in),optional:: init + integer:: tno + integer:: tk + tno=coder%stack(cnode_get_num(var,var_index)+coder%base) +!!$ if(tno==undefined) then +!!$ call cnode_error(coder,callnode,& +!!$ 'Internal error: broken type resolution chain') +!!$ write(*,*) '###',cnode_get_num(var,var_index),cnode_get_num(var,var_index)+coder%base +!!$ tno=error_type +!!$ return +!!$ endif + tk=pm_type_kind(coder%context,tno) + if(tk==pm_type_is_uninitialised.and..not.present(init)) then + call cnode_error(coder,callnode,& + 'Attempt to use "var..." or "const..." before it is initialised: ',& + cnode_get(var,var_name)) + call cnode_error(coder,var,& + 'Definition statement relating to above error') + coder%stack(cnode_get_num(var,var_index)+coder%base)=error_type + tno=error_type + elseif(tk==pm_type_is_error) then + call inf_type_error(coder,callnode,tno,var) + coder%stack(cnode_get_num(var,var_index)+coder%base)=error_type + tno=error_type + endif + end function get_var_type + + !=============================================== + ! Set resolved type (& mode) for variable + !=============================================== + subroutine set_var_type(coder,var,tno) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: var + integer:: tno + coder%stack(cnode_get_num(var,var_index)+coder%base)=tno + end subroutine set_var_type + + !=============================================== + ! Return count of entries in an update list + !=============================================== + function count_updates(changelist,listno) result(n) + type(pm_ptr),intent(in):: changelist + integer,intent(in):: listno + integer:: n + type(pm_ptr):: p + p=cnode_arg(changelist,listno) + n=0 + do while(.not.pm_fast_isnull(p)) + n=n+1 + p=p%data%ptr(p%offset+1) + enddo + contains + include 'fisnull.inc' + end function count_updates + + !=============================================== + ! Combine a new type into the type recorded + ! for a given variable + !=============================================== + subroutine combine_var_type(coder,cnode,var,typ,no_init) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cnode,var + integer,intent(in):: typ + logical,intent(in),optional:: no_init + integer:: typ0,typ2 + logical:: ok,added + typ0=get_var_type(coder,cnode,var,init=.true.) + typ2=typ0 +!!$ write(*,*) 'Combining...',trim(pm_type_as_string(coder%context,typ0)),'<>',& +!!$ trim(pm_type_as_string(coder%context,typ)) + if(typ/=typ0) then + if(typ0<=0) then + typ2=typ + elseif(typ>0) then + if(present(no_init).or.& + pm_type_kind(coder%context,typ0)/=pm_type_is_uninitialised) then + if(pm_type_kind(coder%context,typ0)==pm_type_is_uninitialised.or.& + pm_type_kind(coder%context,typ)==pm_type_is_uninitialised) then + call cnode_error(coder,cnode,& + 'Variable/constant is not intialised in '//& + ' all branches of a conditional statment:',& + cnode_get(var,var_name)) + typ2=error_type + else + typ2=pm_type_combine(coder%context,typ0,typ,ok,added) + if(.not.ok) then + call cnode_error(coder,var,'Value does not have consistent type:',& + cnode_get(var,var_name)) + call more_error(coder%context,& + 'First: '//trim(pm_type_as_string(coder%context,typ0))) + call more_error(coder%context,& + 'Then: '//trim(pm_type_as_string(coder%context,typ))) + if(present(no_init)) then + call cnode_error(coder,cnode,& + 'Above type is inconsistent between branches of this statement') + else + call cnode_error(coder,cnode,'Type inconsistency occurs here') + endif + typ2=error_type + call inf_trace(coder) + elseif(added) then + coder%types_changed=.true. + endif + endif + endif + + endif + endif +!!$ write(*,*) '....to',trim(pm_type_as_string(coder%context,typ2)) + call set_var_type(coder,var,typ2) + if(cnode_flags_set(var,var_flags,var_is_reference)) then + call combine_subvar_type(coder,cnode_get(var,var_extra_info),typ0,typ2) + endif + end subroutine combine_var_type + + !=========================================================== + ! For a given variable, change any subelement of oldtype + ! to newtype + !=========================================================== + subroutine combine_subvar_type(coder,var,oldtype,newtype) type(code_state):: coder - type(pm_ptr):: callnode - integer,intent(in):: pt,at,at2 - call infer_error(coder,callnode,'Ambiguous match to embedded value:') - call typ_ambiguous_match_error(coder%context,pt,at,at2,coder%wstack,coder%wtop) - call infer_trace(coder) - end subroutine ambiguous_match_error + type(pm_ptr),intent(in):: var + integer,intent(in):: oldtype,newtype + integer:: vartype + if(oldtype==newtype) return + vartype=get_var_type(coder,var,var,init=.true.) + if(vartype<=0.or.oldtype<=0.or.newtype<=0) return + vartype=pm_type_replace(coder%context,vartype,oldtype,newtype) + call set_var_type(coder,var,vartype) + end subroutine combine_subvar_type + !=========================================================== ! Type constraint / Cast !=========================================================== - function prc_cast(coder,node,tno1,tno2,isvar) result(k) + function inf_cast(coder,node,tno1,tno2,isvar) result(k) type(code_state):: coder type(pm_ptr),intent(in):: node integer,intent(in):: tno1 integer,intent(inout):: tno2 logical,intent(in):: isvar integer:: k - logical:: ok - integer:: tno1b,tno3,base,status,key(1) - type(pm_typ_einfo):: einfo + logical:: ok,converted_to_poly + integer:: tno3,base,key(1) k=0 if(tno1<0.or.tno2<=0) then return endif - ok=pm_typ_includes(coder%context,tno1,tno2,pm_typ_incl_val,& - einfo) + if(debug_inference) then + write(*,*) 'Cast:',trim(pm_type_as_string(coder%context,tno2)),' to: ',trim(pm_type_as_string(coder%context,tno1)) + endif + tno3=pm_type_convert(coder%context,tno1,tno2,.true.,.false.,.false.) + if(tno3>=0) tno2=tno3 + ok=pm_type_includes(coder%context,tno1,tno2,pm_type_incl_val) if(.not.ok) then - tno1b=pm_typ_strip_to_basic(coder%context,tno1) - tno3=pm_typ_convert(coder%context,tno1b,tno2,.true.) - if(tno3==undefined) then - base=coder%wtop - call pm_indirect_include(coder%context,tno1,tno2,& - coder%wstack,max_code_stack,coder%wtop,& - einfo,tno3,status) - if(status/=pm_elem_not_found) then - if(status==pm_elem_clash) then - call ambiguous_match_error(coder,node,tno1,tno2,tno3) - ok=.true. ! To supress error message - else - call code_int_vec(coder,coder%wstack,base+1,coder%wtop) - call make_code(coder,pm_null_obj,cnode_is_any_sig,1) - key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,1,pop_code(coder)) - tno2=tno3 - ok=.true. - endif - else - tno3=convert_poly(coder,tno1b,tno2,.true.) - if(tno3/=-1) then - call push_word(coder,tno3) - call code_int_vec(coder,coder%wstack,coder%wtop,coder%wtop) - call make_code(coder,pm_null_obj,cnode_is_any_sig,1) - key(1)=pm_dict_size(coder%context,coder%proc_cache) - k=pm_idict_add(coder%context,coder%proc_cache,& - key,1,pop_code(coder)) - tno2=tno3 - ok=.true. - endif + tno3=pm_type_convert(coder%context,tno1,tno2,.true.,.true.,.true.,converted_to_poly) + if(converted_to_poly) k=tno3 + if(tno3>=0) then + tno2=tno3 + ok=.true. + endif + endif + if(.not.ok) then + call inf_error(coder,node,& + 'Value of type "'//trim(pm_type_as_string(coder%context,tno2))//& + '" cannot be converted to type "'//trim(pm_type_as_string(coder%context,tno1))//'"') + call inf_trace(coder) + endif + if(debug_inference) write(*,*) 'Cast Converts to:',trim(pm_type_as_string(coder%context,tno2)) + contains + include 'fisnull.inc' + end function inf_cast + + !============================================= + ! Compile time computation of expressions + ! atype - tuple of argument types + ! rstypes - typle of declared result types + ! rtype - actual result type + !============================================= + function fold(coder,procnode,atype,rstype) result(rtype) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: procnode + integer,intent(in):: atype,rstype + integer:: rtype + integer:: i,n,opcode,errno,tno,tk,num_elem + type(pm_ptr):: tv,arg1,arg2 + type(pm_ptr):: result + logical:: ok + character(len=100):: emess + type(pm_ptr):: rtv + integer:: rtyp + + tv=pm_type_vect(coder%context,atype) + n=pm_tv_numargs(tv)-1 + opcode=cnode_get_num(procnode,bi_opcode) + if(opcode==op_num_elems_fold) then + coder%temp=pm_fast_newnc(coder%context,pm_long,1) + tno=pm_tv_arg(tv,2) + tk=pm_type_kind(coder%context,tno) + if(tk/=pm_type_is_rec.and.tk/=pm_type_is_tuple) then + call inf_error_with_trace(coder,procnode,& + 'Can only apply "num_elements" to a "rec", not: '//& + pm_type_as_string(coder%context,tno)) + num_elem=1 + else + num_elem=pm_type_numargs(coder%context,tno) + endif + coder%temp%data%ln(coder%temp%offset)=num_elem + rtype=pm_new_fix_value_type(coder%context,coder%temp) + return + elseif(opcode==op_type_include_fold) then + ok=pm_type_includes(coder%context,& + pm_type_arg(coder%context,& + pm_type_arg(coder%context,atype,2),1),& + pm_type_arg(coder%context,& + pm_type_arg(coder%context,atype,3),1),& + pm_type_incl_type) + if(ok) then + rtype=coder%true_literal + else + rtype=coder%false_literal + endif + return + elseif(opcode==op_same_type_fold) then + ok=pm_type_equal(coder%context,pm_type_arg(coder%context,atype,2),pm_type_arg(coder%context,atype,3)) + if(ok) then + rtype=coder%true_literal + else + rtype=coder%false_literal + endif + return + elseif(opcode==op_same_rec_fold) then + ok=pm_type_same_rec(coder%context,pm_type_arg(coder%context,atype,2),pm_type_arg(coder%context,atype,3)) + if(ok) then + rtype=coder%true_literal + else + rtype=coder%false_literal + endif + return + endif + arg1=pm_type_val(coder%context,pm_tv_arg(tv,2)) + if(n>1) then + arg2=pm_type_val(coder%context,pm_tv_arg(tv,3)) + endif + rtyp=pm_type_strip_to_basic(coder%context,pm_type_arg(coder%context,rstype,1)) + + rtv=pm_type_vect(coder%context,rtyp) + rtyp=pm_type_strip_to_basic(coder%context,pm_tv_arg(rtv,1)) + if(rtyp==pm_long) then + coder%temp=pm_fast_newnc(coder%context,pm_long,1) + call fold_value(opcode,coder%temp,arg1,arg2,ok,emess) + if(.not.ok) then + call inf_error_with_trace(coder,procnode,& + 'Cannot combine run time values: '//trim(emess)) + elseif(pm_tv_kind(rtv)==pm_type_is_literal) then + rtype=pm_new_literal_value_type(coder%context,coder%temp) + else + rtype=pm_new_fix_value_type(coder%context,coder%temp) + endif + elseif(rtyp==pm_string_type) then + call fold_string(coder,opcode,arg1,arg2,coder%temp) + if(pm_tv_kind(rtv)==pm_type_is_literal) then + rtype=pm_new_literal_value_type(coder%context,coder%temp) + else + rtype=pm_new_fix_value_type(coder%context,coder%temp) + endif + else + if(opcode==op_eq_fold.or.opcode==op_ne_fold) then + ok=pm_type_name(coder%context,pm_tv_arg(tv,2))==& + pm_type_name(coder%context,pm_tv_arg(tv,3)) + if(opcode==op_ne_fold) ok=.not.ok + else + call fold_comparison(opcode,arg1,arg2,ok) + endif + if(pm_tv_kind(rtv)==pm_type_is_literal) then + if(ok) then + rtype=coder%true_literal + else + rtype=coder%false_literal endif - coder%wtop=base else - tno2=tno3 - ok=.true. + if(ok) then + rtype=coder%true_fix + else + rtype=coder%false_fix + endif endif endif - if(.not.ok) then - call infer_error(coder,node,& - 'Value cannot be cast to the given type') - call pm_typ_error(coder%context,einfo) - call infer_trace(coder) - endif + coder%temp=pm_null_obj contains - include 'fisnull.inc' - end function prc_cast + include "fnewnc.inc" + end function fold + !=========================================================== ! Calculate and arithmetic operation on integer constants !=========================================================== @@ -3101,51 +3641,51 @@ subroutine fold_value(op,a,b,c,ok,emess) character(len=*),intent(out):: emess ok=.true. select case(op) - case(op_uminus_ln) + case(op_uminus_fold) a%data%ln(a%offset)=-b%data%ln(b%offset) - case(op_add_ln) + case(op_add_fold) a%data%ln(a%offset)=b%data%ln(b%offset)+c%data%ln(c%offset) - case(op_sub_ln) + case(op_sub_fold) a%data%ln(a%offset)=b%data%ln(b%offset)-c%data%ln(c%offset) - case(op_mult_ln) + case(op_mult_fold) a%data%ln(a%offset)=b%data%ln(b%offset)*c%data%ln(c%offset) - case(op_divide_ln) + case(op_divide_fold) if(c%data%ln(c%offset)/=0) then a%data%ln(a%offset)=b%data%ln(b%offset)/c%data%ln(c%offset) else ok=.false. emess='division by zero' endif - case(op_mod_ln) + case(op_mod_fold) if(c%data%ln(c%offset)/=0) then a%data%ln(a%offset)=modulo(b%data%ln(b%offset),c%data%ln(c%offset)) else ok=.false. emess='modulo zero' endif - case(op_pow_ln) + case(op_pow_fold) a%data%ln(a%offset)=b%data%ln(b%offset)**c%data%ln(c%offset) - case(op_max_ln) + case(op_max_fold) a%data%ln(a%offset)=max(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_min_ln) + case(op_min_fold) a%data%ln(a%offset)=min(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_abs_ln) + case(op_abs_fold) a%data%ln(a%offset)=abs(b%data%ln(b%offset)) - case(op_band_ln) + case(op_band_fold) a%data%ln(a%offset)=iand(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_bor_ln) + case(op_bor_fold) a%data%ln(a%offset)=ior(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_bxor_ln) + case(op_bxor_fold) a%data%ln(a%offset)=ieor(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_bshift_ln) + case(op_bshift_fold) a%data%ln(a%offset)=ishft(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_bnot_ln) + case(op_bnot_fold) a%data%ln(a%offset)=not(b%data%ln(b%offset)) - case(op_pdiff_ln) + case(op_pdiff_fold) a%data%ln(a%offset)=dim(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_sign_ln) + case(op_sign_fold) a%data%ln(a%offset)=sign(b%data%ln(b%offset),c%data%ln(c%offset)) - case(op_modulo_ln) + case(op_modulo_fold) if(c%data%ln(c%offset)/=0) then a%data%ln(a%offset)=mod(b%data%ln(b%offset),c%data%ln(c%offset)) else @@ -3155,22 +3695,48 @@ subroutine fold_value(op,a,b,c,ok,emess) end select end subroutine fold_value + !================================================= + ! Calculate operations returning string constants + !================================================= + subroutine fold_string(coder,op,a,b,c) + type(code_state),intent(inout):: coder + integer,intent(in):: op + type(pm_ptr),intent(in):: a,b + type(pm_ptr),intent(out):: c + character(len=100):: str + select case(op) + case(op_string_fold) + str=pm_number_as_string(coder%context,a,0_pm_ln) + c=pm_new_string(coder%context,trim(str)) + case(op_concat_fold) + c=pm_concat_string(coder%context,a,b) + end select + contains + include 'fname.inc' + end subroutine fold_string + !=============================================== - ! Calculate logical operation on bool constants + ! Calculate operations returning bool constants !=============================================== subroutine fold_comparison(op,a,b,ok) integer,intent(in):: op type(pm_ptr),intent(in):: a,b logical,intent(out):: ok select case(op) - case(op_gt_ln) + case(op_gt_fold) ok=a%data%ln(a%offset)>b%data%ln(b%offset) - case(op_ge_ln) + case(op_ge_fold) ok=a%data%ln(a%offset)>=b%data%ln(b%offset) - case(op_eq_ln) + case(op_eq_fold) ok=a%data%ln(a%offset)>=b%data%ln(b%offset) - case(op_ne_ln) + case(op_ne_fold) ok=a%data%ln(a%offset)/=b%data%ln(b%offset) + case(op_and_fold) + ok=a%data%l(a%offset).and.b%data%l(b%offset) + case(op_or_fold) + ok=a%data%l(a%offset).or.b%data%l(b%offset) + case(op_except_fold) + ok=a%data%l(a%offset).and..not.b%data%l(b%offset) end select end subroutine fold_comparison @@ -3193,6 +3759,474 @@ subroutine make_type_if_possible(coder,n) call make_type(coder,n) end subroutine make_type_if_possible + + subroutine bprop(coder,cblock,rvec,update) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock + integer,dimension(:),intent(inout):: rvec + logical,intent(in):: update + integer(access_kind),allocatable,dimension(:):: access_info + integer:: save_loop_depth,i + if(debug_bprop) then + write(*,*) 'BP' + endif + allocate(access_info(size(rvec)+pm_max_args)) + access_info=0 + save_loop_depth=coder%loop_depth + call bprop_cblock(coder,cblock,access_info,rvec) + coder%loop_depth=save_loop_depth + if(update) then + do i=1,size(rvec) + if(access_info(i)==access_deactivated_call.or.& + access_info(i)==access_is_var) then + if(debug_bprop) then + write(*,*) 'BP Deactivate',i + endif + rvec(i)=sp_sig_deactivated + endif + end do + deallocate(access_info) + endif + end subroutine bprop + + + !========================================== + ! Back propogate information for code block + !========================================== + subroutine bprop_cblock(coder,cblock,access_info,rvec) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: cblock + integer,dimension(:),intent(in)::rvec + integer(access_kind),dimension(*),intent(inout):: access_info + integer:: nvars,idx,newbase + type(pm_ptr):: p + if(pm_fast_isnull(cblock)) return + p=cnode_get(cblock,cblock_first_var) + do while(.not.pm_fast_isnull(p)) + idx=cnode_get_num(p,var_index) + access_info(idx)=ior(access_info(idx),access_is_var) + p=cnode_get(p,var_link) + enddo + p=cnode_get(cblock,cblock_last_call) + do while(.not.pm_fast_isnull(p)) + call bprop_call(coder,cblock,p,access_info,rvec) + p=cnode_get(p,call_back_link) + enddo + contains + include 'fisnull.inc' + end subroutine bprop_cblock + + subroutine bprop_call(coder,cblock,callnode,access_info,rvec) + type(code_state),intent(inout):: coder + type(pm_ptr),intent(in):: callnode,cblock + integer,dimension(:),intent(in):: rvec + integer(access_kind),dimension(*),intent(inout):: access_info + type(pm_ptr):: args,arg,tv + integer:: nret,nargs,nvargs,opcode,i,sig,tno + nret=cnode_get_num(callnode,call_nret) + sig=-cnode_get_num(callnode,call_sig) + args=cnode_get(callnode,call_args) + nargs=cnode_numargs(args)-nret + call enable + if(sig>0) then + if(debug_bprop) then + write(*,*) 'BPcall ',sym_names(sig) + endif + select case(sig) + case(sym_while,sym_while_invar) + if(cblock_must_run(cnode_arg(args,1)).or.cblock_must_run(cnode_arg(args,3)) & + .or.block_writes_accessed(4)) then + coder%loop_depth=coder%loop_depth+1 + call access(cnode_arg(args,2)) + call bprop_cblock(coder,cnode_arg(args,3),access_info,rvec) + call access(cnode_arg(args,2)) + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + if(coder%loop_depth==1) then + call access(cnode_arg(args,2)) + call bprop_cblock(coder,cnode_arg(args,3),access_info,rvec) + call access(cnode_arg(args,2)) + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + endif + else + if(debug_bprop) then + write(*,*) 'DISABLE while' + endif + call disable + endif + case(sym_until,sym_until_invar) + if(cblock_must_run(cnode_arg(args,1)).or.& + block_writes_accessed(3)) then + call access(cnode_arg(args,2)) + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + call access(cnode_arg(args,2)) + if(coder%loop_depth==1) then + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + call access(cnode_arg(args,2)) + endif + else + if(debug_bprop) then + write(*,*) 'DISABLE until' + endif + call disable + endif + case(sym_if,sym_if_invar) + call bprop_if(count_updates(cnode_arg(args,4),1)) + case(sym_do) + call bprop_cblock(coder,cnode_arg(args,1),access_info,rvec) + case(sym_task) + + case(sym_pm_ref) + call std_access(.false.,2) + case(sym_open) + arg=cnode_arg(args,nargs) + nvargs=0 + if(cnode_get_kind(arg)==cnode_is_var) then + if(cnode_flags_set(arg,var_flags,var_is_varg)) then + tno=rvec(cnode_get_num(arg,var_index)) + if(tno>0) then + tv=pm_type_vect(coder%context,tno) + if(pm_tv_kind(tv)==pm_type_is_tuple.and.& + iand(pm_tv_flags(tv),pm_type_is_list)==0) then + nvargs=pm_tv_numargs(tv) + call combine_access_info(arg,access_holds_result) + endif + endif + endif + endif + call code_val(coder,pm_new(coder%context,& + access_pm_type,int(max(nargs+nvargs,1),pm_ln))) + arg=top_code(coder) + do i=1,nargs + arg%data%i8(arg%offset+i-1)=get_access_info(cnode_arg(args,i)) + if(debug_bprop) then + write(*,*) 'BP store access',arg%data%i8(arg%offset+i-1),cnode_get_num(cnode_arg(args,i),var_index) + endif + enddo + do i=1,nvargs-1 + arg%data%i8(arg%offset+i+nargs-1)=access_info(size(rvec)+i) + enddo + case(sym_key) + do i=2,nargs,2 + if(accessed(cnode_arg(args,i/2+nret/2))) then + call access(cnode_arg(args,nret+i)) + endif + call bprop_cblock(coder,cnode_arg(args,nret+i-1),access_info,rvec) + enddo + call code_val(coder,pm_new(coder%context,access_pm_type,int(max(nret/2,1),pm_ln))) + arg=top_code(coder) + do i=nret/2+1,nret + arg%data%i8(arg%offset+i-1)=get_access_info(cnode_arg(args,i)) + enddo + case(sym_amp,sym_result) + do i=1,nargs + call set_access_info(cnode_arg(args,i),access_everything) + enddo + case default + call std_access(.false.,1) + end select + else + call bprop_proc_call + endif + contains + + include 'fesize.inc' + include 'fisnull.inc' + include 'fvkind.inc' + + subroutine bprop_if(nupdates) + integer:: nupdates + type(pm_ptr):: readlist,p,var + integer(access_kind),dimension(nupdates):: save_access + integer:: i + integer(access_kind):: acc + + if(.not.(block_writes_accessed(4).or.cblock_must_run(cnode_arg(args,2)).or.& + cblock_must_run(cnode_arg(args,3)))) then + call disable + return + endif + + readlist=cnode_arg(cnode_arg(args,4),1) + i=1 + p=readlist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + save_access(i)=get_access_info(var) + p=p%data%ptr(p%offset+1) + i=i+1 + enddo + call bprop_cblock(coder,cnode_arg(args,2),access_info,rvec) + i=1 + p=readlist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + acc=access_info(cnode_get_num(var,var_index)) + call set_access_info(var,save_access(i)) + save_access(i)=acc + p=p%data%ptr(p%offset+1) + i=i+1 + enddo + call bprop_cblock(coder,cnode_arg(args,3),access_info,rvec) + i=1 + p=readlist + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + call combine_access_info(var,save_access(i)) + p=p%data%ptr(p%offset+1) + i=i+1 + enddo + call access(cnode_arg(args,1)) + end subroutine bprop_if + + subroutine bprop_proc_call + type(pm_ptr):: arg_access,key_access,key_names,proc_keys,arg,amps,key_args,procnode + integer:: i,j,nkeys,nproc_keys,taints,sig + logical:: arg_accessed,is_accessed, all_accessed, needs_to_run, is_builtin + + sig=rvec(cnode_get_num(callnode,call_index)) + if(sig<=0) then + call std_access(.false.,1) + return + endif + + amps=cnode_get(callnode,call_amp) + + if(debug_bprop) then + write(*,*) 'BPsig=',sig,trim(sig_name_str(coder,cnode_get_num(callnode,call_sig))) + endif + procnode=pm_dict_val(coder%context,coder%proc_cache,& + int(sig,pm_ln)) + + if(pm_fast_vkind(procnode)/=pm_pointer) then + ! Recursive call + call std_access(.false.,1) + return + endif + + if(cnode_get_kind(procnode)==cnode_is_autoconv_sig) then + procnode=pm_dict_val(coder%context,coder%proc_cache,& + int(cnode_num_arg(procnode,cnode_numargs(procnode)),pm_ln)) + endif + + is_builtin=cnode_get_kind(procnode)==cnode_is_builtin + + if(is_builtin) then + taints=cnode_get_num(procnode,pr_flags) + else + taints=cnode_num_arg(procnode,3) + endif + + if(debug_bprop) then + write(*,*) 'BPcall taints=',iand(taints,proc_must_run) + endif + + is_accessed=.false. + all_accessed=.true. + do i=1,nret + arg=cnode_arg(args,i) + arg_accessed=accessed(arg) + if(debug_bprop) then + write(*,*) 'accessed #',i,cnode_get_num(arg,var_index),arg_accessed + endif + is_accessed=is_accessed.or.arg_accessed + all_accessed=all_accessed.and.arg_accessed + call modify(arg) + enddo + + if(.not.pm_fast_isnull(amps)) then + amps=pm_name_val(coder%context,int(amps%offset)) + do i=0,pm_fast_esize(amps) + arg=cnode_arg(args,nret+amps%data%i(amps%offset+i)) + arg_accessed=accessed(arg) + is_accessed=is_accessed.or.arg_accessed + all_accessed=all_accessed.and.arg_accessed + call modify(arg) + enddo + endif + + if(debug_bprop) then + write(*,*) 'BPa',is_accessed,all_accessed + endif + + if(.not.is_accessed.and.iand(taints,proc_must_run)==0) then + if(debug_bprop) write(*,*) 'BP disable',is_accessed,iand(taints,proc_must_run) + call disable + return + endif + + if(.not.all_accessed) then + do i=1,nret + call combine_access_info(cnode_arg(args,i),access_holds_result) + enddo + if(.not.pm_fast_isnull(amps)) then + do i=0,pm_fast_esize(amps) + arg=cnode_arg(args,nret+amps%data%i(amps%offset+i)) + call combine_access_info(arg,access_holds_result) + enddo + endif + endif + + if(is_builtin) then + do i=1,nargs + call access(cnode_arg(args,nret+i)) + enddo + else + arg_access=cnode_arg(procnode,6) + key_access=cnode_arg(procnode,7) + do i=1,nargs + !!$ write(*,*) 'Combine #',i,cnode_get_num(cnode_arg(args,i+nret),var_index),'with',arg_access%data%i8(arg_access%offset+i-1) + !!! Need to cater for vargs + call combine_access_info(cnode_arg(args,i+nret),& + arg_access%data%i8(arg_access%offset+i-1)) + enddo + do i=nargs+1,pm_fast_esize(arg_access)+1 + j=size(rvec)+i-nargs + access_info(j)=ior(access_info(j),arg_access%data%i8(arg_access%offset+i-1)) + enddo + if(.not.pm_fast_isnull(cnode_get(callnode,call_keys))) then + nkeys=cnode_numargs(cnode_get(callnode,call_keys)) + key_names=pm_name_val(coder%context,cnode_get_num(callnode,call_key_names)) + proc_keys=cnode_get(cnode_arg(procnode,1),pr_keys) + nproc_keys=pm_fast_esize(proc_keys)/2 + key_args=cnode_get(callnode,call_keys) + outer: do j=1,nproc_keys + do i=1,nkeys + if(proc_keys%data%i(proc_keys%offset+j-1)==key_names%data%i(key_names%offset+i-1)) then + call combine_access_info(cnode_arg(key_args,i),key_access%data%i8(key_access%offset+j-1)) + cycle outer + endif + enddo + enddo outer + endif + endif + + end subroutine bprop_proc_call + + subroutine std_access(always,start) + logical,intent(in):: always + integer,intent(in):: start + type(pm_ptr):: arg + integer:: i + logical:: arg_accessed,is_accessed,all_accessed,should_disable + should_disable=.false. + is_accessed=.false. + all_accessed=.true. + do i=1,nret + arg=cnode_arg(args,i) + arg_accessed=accessed(arg) + is_accessed=is_accessed.or.arg_accessed + all_accessed=all_accessed.and.arg_accessed + call modify(arg) + enddo + if(is_accessed.or.always) then + do i=1,nargs + call access(cnode_arg(args,i+nret)) + enddo + if(.not.all_accessed) then + do i=1,nret + call combine_access_info(cnode_arg(args,i),access_holds_result) + enddo + endif + else + should_disable=.true. + endif + do i=1,nargs + arg=cnode_arg(args,i+nret) + if(cnode_get_kind(arg)==cnode_is_cblock) then + call bprop_cblock(coder,arg,access_info,rvec) + should_disable=.false. + endif + enddo + if(should_disable) call disable + end subroutine std_access + + subroutine access(var) + type(pm_ptr):: var + integer:: idx + if(debug_bprop) then + if(cnode_get_kind(var)==cnode_is_var) then + write(*,*) 'Make access to',cnode_get_num(var,var_index) + endif + endif + call combine_access_info(var,access_used_ever+access_used_now+access_is_var) + end subroutine access + + function accessed(var) result(ok) + type(pm_ptr):: var + logical:: ok + if(cnode_get_kind(var)==cnode_is_var) then + ok=iand(access_info(cnode_get_num(var,var_index)),access_used_now)/=0 + else + ok=.true. + endif + end function accessed + + subroutine modify(var) + type(pm_ptr):: var + integer:: idx + idx=cnode_get_num(var,var_index) + access_info(idx)=ior(access_is_var,& + iand(not(access_used_now),access_info(idx))) + end subroutine modify + + subroutine enable + access_info(cnode_get_num(callnode,call_index))=0 + end subroutine enable + + subroutine disable + access_info(cnode_get_num(callnode,call_index))=access_deactivated_call + end subroutine disable + + subroutine set_access_info(var,acc) + type(pm_ptr),intent(in):: var + integer(access_kind),intent(in):: acc + if(cnode_get_kind(var)==cnode_is_var) then + access_info(cnode_get_num(var,var_index))=acc + endif + end subroutine set_access_info + + subroutine combine_access_info(var,acc) + type(pm_ptr),intent(in):: var + integer(access_kind),intent(in):: acc + integer:: idx + if(cnode_get_kind(var)==cnode_is_var) then + idx=cnode_get_num(var,var_index) + access_info(idx)=ior(int(acc,access_kind),access_info(idx)) + endif + end subroutine combine_access_info + + function get_access_info(var) result(acc) + type(pm_ptr),intent(in):: var + integer(access_kind):: acc + if(cnode_get_kind(var)==cnode_is_var) then + acc=access_info(cnode_get_num(var,var_index)) + else + acc=0 + endif + end function get_access_info + + function cblock_must_run(cblock) result(ok) + type(pm_ptr),intent(in):: cblock + logical:: ok + ok=iand(cblock_taints(coder,cblock),proc_must_run)/=0 + end function cblock_must_run + + function block_writes_accessed(n) result(is_accessed) + integer,intent(in):: n + logical:: is_accessed + type(pm_ptr):: writelist,p,var + writelist=cnode_arg(cnode_arg(args,n),2) + p=writelist + is_accessed=.false. + do while(.not.pm_fast_isnull(p)) + var=p%data%ptr(p%offset) + is_accessed=is_accessed.or.accessed(var) + p=p%data%ptr(p%offset+1) + enddo + end function block_writes_accessed + + end subroutine bprop_call + !=================================================== ! Dump resolved proc signatures (debugging) !=================================================== @@ -3213,24 +4247,24 @@ end subroutine dump_res_sigs !=============================================== ! Output error message followed by call trace !=============================================== - subroutine infer_error_with_trace(coder,node,message,name) + subroutine inf_error_with_trace(coder,node,message,name) type(code_state):: coder type(pm_ptr),intent(in):: node character(len=*):: message type(pm_ptr),intent(in),optional:: name logical:: save_supress,current_supress current_supress=coder%supress_errors - call infer_error(coder,node,message,name) + call inf_error(coder,node,message,name) save_supress=coder%supress_errors coder%supress_errors=current_supress - call infer_trace(coder) + call inf_trace(coder) coder%supress_errors=save_supress - end subroutine infer_error_with_trace + end subroutine inf_error_with_trace !===================================== ! Output error message !===================================== - subroutine infer_error(coder,node,message,name) + subroutine inf_error(coder,node,message,name) type(code_state):: coder type(pm_ptr),intent(in):: node character(len=*):: message @@ -3253,11 +4287,11 @@ subroutine infer_error(coder,node,message,name) if(modl_name==sym_pm_system.and.pm_opts%hide_sysmod) then ! Search call stack for source outside of the system module ! (note- par/import stack is misused here) - do i=coder%par_depth,1,-1 - modl_name=cnode_get_name(coder%imports(i),cnode_modl_name) + do i=coder%trace_depth,1,-1 + modl_name=cnode_get_name(coder%trace(i),cnode_modl_name) if(modl_name/=sym_pm_system) then - lineno=cnode_get_name(coder%imports(i),cnode_lineno) - charno=cnode_get_name(coder%imports(i),cnode_charno) + lineno=cnode_get_name(coder%trace(i),cnode_lineno) + charno=cnode_get_name(coder%trace(i),cnode_charno) exit endif enddo @@ -3267,12 +4301,17 @@ subroutine infer_error(coder,node,message,name) lineno,& charno) if(present(name)) then - call pm_name_string(coder%context,int(name%offset),str) - str=trim(pm_opts%error)//trim(message)//' '//trim(str) + if(.not.pm_fast_isnull(name)) then + call pm_name_string(coder%context,int(name%offset),str) + str=trim(pm_opts%error)//' '//trim(message)//' '//trim(str) + else + str=trim(pm_opts%error)//' '//message + endif else - str=trim(pm_opts%error)//message + str=trim(pm_opts%error)//' '//message endif write(*,'(A)') trim(str) + write(*,*) endif if(cnode_get_name(node,cnode_modl_name)==sym_pm_system.and.& pm_opts%hide_sysmod) then @@ -3282,37 +4321,46 @@ subroutine infer_error(coder,node,message,name) if(coder%num_errors>max_code_errors) then call pm_stop('Too many type inference errors - compilation terminated') endif - end subroutine infer_error + contains + include 'fisnull.inc' + end subroutine inf_error + + !=========================================================== + ! Output error message associated with given error type + !========================================================== + subroutine inf_type_error(coder,node,tno,var) + type(code_state):: coder + type(pm_ptr),intent(in):: node,var + integer,intent(in):: tno + type(pm_ptr):: tv + character(len=100):: str + call pm_strval(pm_type_val(coder%context,tno),str) + call inf_error(coder,node,trim(str)//': '//& + trim(pm_name_as_string(coder%context,cnode_get_num(var,var_name)))) + end subroutine inf_type_error ! ============================================================ ! Output trace of current call stack - ! Calls stored in coder%imports(1:coder%par_depth) - ! and coder%import_cblock(1:coder%par_depth) - ! misused for this purpose + ! Calls stored in coder%trace(1:coder%trace_depth) + ! and coder%trace_keys(1:coder%trace_depth) ! Ignores internal calls within PM__system ! unless pm_opts%hide_sysmod is false ! ============================================================= - subroutine infer_trace(coder) + subroutine inf_trace(coder) type(code_state):: coder type(pm_ptr):: node,modname,tv - integer:: k,top + integer:: k,top,chunk if(.not.pm_main_process) return if(coder%supress_errors) return - if(coder%par_depth<1) return - top=coder%par_depth - if(pm_opts%hide_sysmod.and.top1) top=top-1 - node=coder%imports(top) + node=coder%trace(top) if(.not.hide(node)) then -!!$ call pm_error_header(coder%context,& -!!$ cnode_get_name(node,cnode_modl_name),& -!!$ cnode_get_name(node,cnode_lineno),& -!!$ cnode_get_name(node,cnode_charno)) -!!$ top=top-1 -!!$ if(top<1) return exit endif enddo @@ -3320,27 +4368,52 @@ subroutine infer_trace(coder) endif if(top==1.and.pm_opts%hide_sysmod) then - if(hide(coder%imports(top))) return + if(hide(coder%trace(top))) return endif write(*,*) - write(*,*) '-------------CALL TRACE---------------------------' - do k=top,1,-1 - if(k>max_par_depth) then - write(*,*) 'Procedure call: (call not recorded)' - cycle - endif - node=coder%imports(k) - if((.not.hide(node)).or.& - (.not.pm_opts%hide_sysmod)) then - call print_call_details(coder,node,& - int(coder%import_cblock(k)%offset)) - if(k>1) write(*,*) - endif - enddo - write(*,*) '--------------------------------------------------' + write(*,'(a)') '=====================CALL TRACE===========================' + write(*,*) + if(top>max_trace_depth) then + write(*,*) '------------------------------------------------------' + write(*,*) ' ... UNRECORDED PROCEDURES (TOO MANY NESTED CALLS) ...' + write(*,*) '------------------------------------------------------' + write(*,*) + top=max_trace_depth + endif + if(top<=pm_opts%trace_list.or.pm_opts%show_full_trace) then + do k=top,1,-1 + call trace_entry + enddo + else + chunk=max(2,pm_opts%trace_list/2-1) + do k=top,top-chunk+1,-1 + call trace_entry + enddo + write(*,*) '---------------------------' + write(*,*) ' ... (CALLS SKIPPED) ...' + write(*,*) '---------------------------' + write(*,*) + do k=chunk,1,-1 + call trace_entry + enddo + write(*,*) + write(*,*) ' (Use -fshow-full-trace to show the complete call trace)' + endif + write(*,'(a)') '==========================================================' write(*,*) contains + + subroutine trace_entry + node=coder%trace(k) + if((.not.hide(node)).or.& + (.not.pm_opts%hide_sysmod)) then + call print_call_details(coder,node,& + coder%trace_keys(k)) + if(k>1) write(*,*) + endif + end subroutine trace_entry + function hide(node) result(hideit) type(pm_ptr),intent(in):: node logical:: hideit @@ -3351,7 +4424,7 @@ function hide(node) result(hideit) return endif name=pm_name_stem(coder%context,sig_name(coder,cnode_get_num(node,call_sig))) - if(name==sym_assignment.or.name==sym_assign_var.or.& + if(name==sym_pm_assign.or.name==sym_assign_var.or.& name==sym_make_subref.or.name==sym_make_sublhs.or.& name==sym_make_sublhs_amp) then hideit=.false. @@ -3361,7 +4434,8 @@ function hide(node) result(hideit) endif !write(*,*) 'hide',hideit,name,sym_make_subref,sym_dump,pm_name_as_string(coder%context,name) end function hide - end subroutine infer_trace + + end subroutine inf_trace ! ============================================ ! Print details of individual call @@ -3375,21 +4449,17 @@ subroutine print_call_details(coder,node,base,numargs) integer:: i character(len=100):: str character(len=2):: join,ampstr + character(len=1):: procchr,dotchr integer:: n,k,nargs,nkeys integer::ampidx,signame,signamebase - type(pm_ptr):: tv,key,val,amp,keyargs,name + type(pm_ptr):: tv,key,val,amp,keyargs,keynames,name if(.not.pm_main_process) return if(coder%supress_errors) return - nkeys=cnode_get_num(node,call_nkeys) nargs=cnode_numargs(cnode_get(node,call_args))-cnode_get_num(node,call_nret) if(present(numargs)) nargs=numargs - k=0 - key=pm_dict_key(coder%context,& - coder%sig_cache,int(cnode_get_num(node,call_sig),pm_ln)) - val=pm_dict_val(coder%context,& - coder%sig_cache,int(cnode_get_num(node,call_sig),pm_ln)) - keyargs=cnode_arg(val,1) - ampidx=key%data%i(key%offset+pm_fast_esize(key)-2) + + nkeys=0 + ampidx=cnode_get_num(node,call_amp) if(ampidx==0) then amp=pm_null_obj else @@ -3411,69 +4481,83 @@ subroutine print_call_details(coder,node,base,numargs) signame=sig_name(coder,cnode_get_num(node,call_sig)) signamebase=pm_name_stem(coder%context,signame) if(signame==sym_proc) then - tv=pm_typ_vect(coder%context,coder%wstack(base)) + tv=pm_type_vect(coder%context,coder%wstack(base)) signame=abs(pm_tv_name(tv)) - elseif(signamebase==sym_assignment.or.signamebase==sym_assign_var) then + elseif(signamebase==sym_pm_assign.or.signamebase==sym_assign_var) then signame=sym_assign elseif(signamebase==sym_make_subref.or.signamebase==sym_make_sublhs.or.& signamebase==sym_make_sublhs_amp) then signame=sym_sub endif - if(cnode_flags_clear(node,call_flags,& - call_is_comm)) then - call more_error(coder%context,' '//trim(pm_name_as_string(coder%context,& - signame))//' (') - n=0 + + + if(cnode_flags_set(node,call_flags,proccall_is_comm)) then + n=6 + if(cnode_flags_set(node,call_flags,proccall_is_general)) then + procchr='''' + else + procchr='%' + endif + else + n=1 + procchr=' ' + endif + + if(cnode_flags_set(node,call_flags,proccall_is_ref)) then + procchr=' ' + dotchr='.' else - call more_error(coder%context,' '//trim(pm_name_as_string(coder%context,& - signame))//'%(') - call more_error(coder%context,' region: '//& - trim(pm_typ_as_string(coder%context,& - coder%wstack(base+nkeys+1),distr=.true.))) - call more_error(coder%context,' schedule: '//& - trim(pm_typ_as_string(coder%context,& - coder%wstack(base+nkeys+2),distr=.true.))) - call more_error(coder%context,' here: '//& - trim(pm_typ_as_string(coder%context,& - coder%wstack(base+nkeys+3),distr=.true.))) - n=3 - endif - do i=nkeys+n+1,nargs + dotchr=' ' + endif + + if(cnode_flags_set(node,call_flags,proccall_is_block)) then + n=n+3 + endif + + if(pm_opts%show_hidden) n=0 + + call more_error(coder%context,dotchr//trim(pm_name_as_string(coder%context,& + signame))//procchr//' (') + k=0 + do i=n+1,nargs if(i0) then join=', ' else join=' ' endif - call check_amp(i-nkeys) + call check_amp(i) call more_error(coder%context,& ' '//ampstr//& - trim(pm_typ_as_string(coder%context,coder%wstack(base+i)))//join) + trim(pm_type_as_string(coder%context,coder%wstack(base+nkeys+2+i)))//join) enddo if(.not.present(numargs).and.cnode_flags_set(node,call_flags,call_is_vararg)) then call more_error(coder%context,' ...') endif + keynames=pm_name_val(coder%context,cnode_get_num(node,call_key_names)) do i=1,nkeys if(ipm_fast_esize(amp)) then + ampstr=' ' + return + endif + enddo if(amp%data%i(amp%offset+k)==i) then ampstr=' &' k=k+1 @@ -3491,36 +4582,22 @@ subroutine check_amp(i) ampstr=' ' endif end subroutine check_amp + end subroutine print_call_details !===================================================== ! Print details of procedure definition ! with given signature (sig) and parameter types (tno) ! ==================================================== - subroutine print_proc_details(coder,node,sig,iscomm,tno) + subroutine print_proc_details(coder,node) type(code_state):: coder type(pm_ptr),intent(in):: node - integer,intent(in):: sig - logical,intent(in):: iscomm - integer,intent(in):: tno - integer:: name,ampidx - integer:: i,k,n,nx,nargs - integer:: typ - type(pm_ptr):: tv,tv2,key,amp,val - character(len=256):: str,str2 - character(len=7):: buf1,buf2 + integer:: name + integer:: istart,n,tno,nret,i + character(len=1024):: str,str2,buf1,buf2 if(.not.pm_main_process) return if(coder%supress_errors) return - k=0 - key=pm_dict_key(coder%context,coder%sig_cache,int(sig,pm_ln)) - val=pm_dict_val(coder%context,coder%sig_cache,int(sig,pm_ln)) - name=key%data%i(key%offset+pm_fast_esize(key)) - ampidx=key%data%i(key%offset+pm_fast_esize(key)-2) - if(ampidx==0) then - amp=pm_null_obj - else - amp=pm_name_val(coder%context,ampidx) - endif + name=cnode_get_num(node,pr_name) str=' ' call pm_name_string(coder%context,& cnode_get_name(node,cnode_modl_name),str2) @@ -3539,63 +4616,52 @@ subroutine print_proc_details(coder,node,sig,iscomm,tno) endif endif n=max(len_trim(str)+2,20) - if(add_char(':')) goto 777 + str(n:n)=':' n=n+2 + nret=cnode_get_num(node,pr_nret) + do i=1,nret-1 + str(n:n+1)='_,' + n=n+2 + enddo + if(nret>0) then + str(n:n+1)='_=' + n=n+2 + endif + + if(cnode_flags_set(node,pr_flags,proccall_is_ref)) then + str(n:n)='.' + n=n+1 + endif call pm_name_string(coder%context,name,str(n:)) n=len_trim(str)+1 - if(.not.iscomm) then - if(pm_fast_isnull(amp)) then - str(n:)=pm_typ_as_string(coder%context,tno) + if(cnode_flags_set(node,pr_flags,proccall_is_ref)) then + istart=7 + elseif(cnode_flags_set(node,pr_flags,proccall_is_comm)) then + if(cnode_flags_set(node,pr_flags,proccall_is_general)) then + str(n:n)='''' else - tv=pm_typ_vect(coder%context,tno) - nargs=pm_tv_numargs(tv) - nx=0 - if(add_char('(')) goto 777 - do i=1,nargs - call check_amp - typ=pm_tv_arg(tv,i) - call typ_to_str(coder%context,typ,str,n,.false.) - if(n>len(str)-10) goto 777 - if(ilen(str)-20) then + str(n:n+2)='...' + else + if(cnode_flags_set(node,pr_flags,proccall_is_block)) then + str(n:)=')yield(' + n=n+7 + tno=pm_type_arg(coder%context,tno,istart) + call pm_type_to_string(coder%context,tno,str,n) + str(n:n)=')' endif - if(n>len(str)-10) goto 777 - nargs=pm_tv_numargs(tv) - do i=4,nargs - call check_amp - typ=pm_tv_arg(tv,i) - call typ_to_str(coder%context,typ,str,n,.false.) - if(n>len(str)-10) goto 777 - if(ilen(str)-10-len(c)) then - str(n:n+2)='...' - term=.true. - else - str(n:n+len(c)-1)=c - n=n+len(c) - term=.false. - endif - end function add_char - subroutine check_amp - logical:: junk - if(pm_fast_isnull(amp)) return - if(k>pm_fast_esize(amp)) return - if(amp%data%i(amp%offset+k)==i) then - k=k+1 - junk=add_char('&') - endif - end subroutine check_amp - end subroutine print_proc_details diff --git a/src/lib.f90 b/src/lib.f90 index 7e8a2cf..1a92393 100755 --- a/src/lib.f90 +++ b/src/lib.f90 @@ -80,7 +80,7 @@ subroutine pm_error_header(context,modl_name,lineno,charno) caret=' ' caret(n:n)='!' if(pm_opts%colour) then - write(*,'(3X,A,A67,A)') pm_error_start,caret,pm_error_end + write(*,'(3X,A,A67,A)') pm_opts%error_start,caret,pm_error_end else write(*,'(3X,A67)') caret endif @@ -103,16 +103,15 @@ function pm_get_source_line(context,modl_name,lineno,buffer) result(iserr) !if(.not.pm_main_process) call pm_panic('pm_get_source_line - not main process') iserr=.true. if(modl_name==sym_pm_system) then - if(.not.pm_opts%out_sysmod) goto 20 - open(unit=3,file='sysmod.out',status='OLD',err=20) - do - read(3,'(I4,A7,A)',err=20,end=20) i,lbuffer,buffer - if(i==lineno) exit + call pm_module_filename('lib.sys.pm',buffer,pm_opts%lib_path_set,pm_opts%lib_path) + open(unit=3,file=buffer,status='OLD',err=20) + do i=1,lineno + read(3,'(A1024)',err=20,end=20) buffer enddo close(3) else call pm_module_filename(trim(pm_name_as_string(context,& - modl_name)),buffer) + modl_name)),buffer,pm_opts%lib_path_set,pm_opts%lib_path) open(unit=3,file=buffer,status='OLD',err=20) do i=1,lineno read(3,'(A1024)',err=20,end=20) buffer @@ -141,7 +140,7 @@ function pm_number_as_string(context,v,j) result(str) type(pm_ptr),intent(in):: v integer(pm_ln),intent(in):: j character(len=82):: str - str='' + str='***' select case(pm_fast_vkind(v)) case(pm_tiny_int) write(str,'(i40)') v%offset @@ -237,6 +236,8 @@ function pm_number_as_string(context,v,j) result(str) call fix(str(41:)) str=trim(adjustl(str(1:40)))//trim(adjustl(str(41:80)))//'i_cpx256' return + case default + str='????'//trim(pm_int_as_string(pm_fast_vkind(v)))//'????' end select str=adjustl(str) contains @@ -279,6 +280,8 @@ function pm_value_as_string(context,v) result(str) str(i+3:i+3)='"' endif end do + case(pm_name) + str="'"//pm_name_as_string(context,int(v%offset)) case default str=pm_number_as_string(context,v,0_pm_ln) end select @@ -296,10 +299,18 @@ function pm_int_as_string(num) result(str) integer:: n,j,k,m,d n=num m=1 + j=1 + if(n==0) then + str='0' + return + elseif(n<0) then + str(j:j)='-' + j=2 + n=-n + endif do while(m<=n) m=m*10 enddo - j=1 do while(m>1.and.j<=field_width) m=m/10 d=n/m diff --git a/src/linker.f90 b/src/linker.f90 index d5a140b..ad8a7d6 100755 --- a/src/linker.f90 +++ b/src/linker.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2025 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -33,7 +33,8 @@ module pm_linker implicit none integer,parameter:: max_link_errors=20 - + logical,parameter:: debug_linker=.false. + contains !================================================= @@ -41,53 +42,60 @@ module pm_linker ! modules !================================================= - ! Process all include statements + ! Process all 'use' statements in all modules subroutine link_includes(context,nerror,modl_dict) type(pm_context),pointer:: context integer,intent(inout):: nerror - type(pm_ptr):: modl_dict - type(pm_ptr),target:: modls,modl,dict - type(pm_ptr),target:: incls,node,imodl - type(pm_ptr)::p - type(pm_reg),pointer:: reg - integer:: i,j - character(len=100):: str - reg=>pm_register(context,'link includes',modls,modl,& - dict,incls,node,imodl) + type(pm_ptr),intent(in):: modl_dict + type(pm_ptr):: modls,modl + integer:: j modls=pm_dict_vals(context,modl_dict) ! Loop through all loaded modules do j=0,pm_dict_size(context,modl_dict)-1 modl=modls%data%ptr(modls%offset+j) - dict=modl%data%ptr(modl%offset+modl_include) - incls=pm_dict_vals(context,dict) - ! Loop through include definitions for given module - do i=0,pm_dict_size(context,dict)-1 - node=incls%data%ptr(incls%offset+i) - if(pm_debug_level>5) then - call pm_name_string(context,& - int(node%data%ptr(node%offset+node_args)%offset),str) - write(*,*) 'including',trim(str) - p=pm_dict_key(context,dict,int(i+1,pm_ln)) - write(*,*) '..',trim(pm_name_as_string(context,int(p%offset))) - endif - imodl=node%data%ptr(node%offset+node_args+1) - if(modl==imodl) then - call link_error(context,nerror,node,'Module cannot include itself') - endif - if(node_sym(node)==sym_use) then - call link_include(context,nerror,node,modl,imodl) - else - call link_include_mod(context,nerror,node,modl,imodl) - endif - if(pm_debug_level>5) then - write(*,*) '... included ',trim(str) - endif - enddo + call link_includes_for_module(context,nerror,modl) enddo - call pm_delete_register(context,reg) end subroutine link_includes - ! Process a single unmodified include statement + ! Process all 'use' statements in a single module + subroutine link_includes_for_module(context,nerror,modl) + type(pm_context),pointer:: context + integer,intent(inout):: nerror + type(pm_ptr),intent(in):: modl + type(pm_ptr):: modls,dict + type(pm_ptr)::incls,node,imodl + type(pm_ptr)::p + type(pm_reg),pointer:: reg + integer:: i + character(len=100):: str + dict=modl%data%ptr(modl%offset+modl_include) + incls=pm_dict_vals(context,dict) + ! Loop through include definitions for given module + do i=0,pm_dict_size(context,dict)-1 + node=incls%data%ptr(incls%offset+i) + if(debug_linker) then + call pm_name_string(context,& + int(node%data%ptr(node%offset+node_args)%offset),str) + write(*,*) 'including',trim(str) + p=pm_dict_key(context,dict,int(i+1,pm_ln)) + write(*,*) '..',trim(pm_name_as_string(context,int(p%offset))) + endif + imodl=node%data%ptr(node%offset+node_args+1) + if(modl==imodl) then + call link_error(context,nerror,node,'Module cannot include itself') + endif + if(node_sym(node)==sym_use) then + call link_include(context,nerror,node,modl,imodl) + else + call link_include_mod(context,nerror,node,modl,imodl) + endif + if(debug_linker) then + write(*,*) '... included ',trim(str) + endif + enddo + end subroutine link_includes_for_module + + ! Process a single unmodified 'use' statement subroutine link_include(context,nerror,node,modl,imodl) type(pm_context),pointer:: context integer,intent(inout):: nerror @@ -106,7 +114,7 @@ subroutine link_include(context,nerror,node,modl,imodl) enddo end subroutine link_include - ! Process a modified include statement + ! Process a modified 'use' statement subroutine link_include_mod(context,nerror,node,modl,imodl) type(pm_context),pointer:: context integer,intent(inout):: nerror @@ -142,7 +150,7 @@ subroutine link_include_elem(context,nerror,node,kind,modl,elem,imodl,val) type(pm_ptr),intent(in):: node,modl,elem,imodl,val type(pm_ptr),target:: dict,lcl_dict,idict,old,v1,v2 logical:: changed - if(pm_debug_level>2) then + if(debug_linker) then write(*,*) 'Include elem: ',trim(pm_name_as_string(context,int(elem%offset))),& ' to ',trim(pm_name_as_string(context,get_modl_name(modl))),& ' from ',trim(pm_name_as_string(context,get_modl_name(modl))) @@ -200,7 +208,7 @@ subroutine link_merge(context,nerror,node,kind,v1,v2) else call pm_ptr_assign(context,& first,& - int(typ_link,pm_ln),& + int(type_link,pm_ln),& v2%data%ptr(v2%offset+node_args+1)) endif call pm_ptr_assign(context,v1,int(node_args+2,pm_ln),& diff --git a/src/main.f90 b/src/main.f90 index 7f12330..1894109 100755 --- a/src/main.f90 +++ b/src/main.f90 @@ -32,11 +32,11 @@ program pm use pm_options use pm_lib use pm_symbol + use pm_types use pm_parser use pm_linker use pm_codegen use pm_infer - use pm_sysdefs use pm_wcode use pm_optimise use pm_backend @@ -59,7 +59,7 @@ program pm call pm_init_compilation call pm_init_names(context) call set_op_names - call init_typ(context) + call pm_init_types(context) call cpu_time(time) time0=time reg=>pm_register(context,'main',root_module,module_dict,visibility,& @@ -67,7 +67,13 @@ program pm ! Command line call pm_get_command_line(context,module_name) - + + ! Run REPL if -i option is present + if(pm_opts%is_repl) then + call repl(context) + stop + endif + ! Compilation call run_parser(module_name,root_module,module_dict,visibility) call run_linker(root_module,module_dict) @@ -111,7 +117,7 @@ subroutine run_parser(mname,root,dict,visibility) type(pm_ptr),intent(out):: root,dict,visibility ! Parser state type(parse_state),target:: parser - integer:: name + integer:: name,module_name,package_name character(len=pm_max_filename_size):: str,str2 if(pm_debug_level>1) write(*,*) 'PARSING>>' @@ -122,7 +128,30 @@ subroutine run_parser(mname,root,dict,visibility) ! Parse sytem module call init_parser(parser,context) - call sysdefs(parser) + + call dcl_module(parser,'PM__system') + parser%sysmodl=parser%modl + + call pm_module_filename('lib.sys.pm',str2,pm_opts%lib_path_set,pm_opts%lib_path) + call pm_open_file(pm_comp_file_unit,str2,ok) + if(.not.ok) then + if(pm_main_process) then + write(*,*) 'Cannot open system module: '//trim(str2) + endif + call pm_stop('Compilation terminated') + endif + !write(*,*) 'Parsing',trim(str) + call parse_file_on_unit(parser,pm_comp_file_unit,.false.) + close(pm_comp_file_unit) + if(parser%error_count>0) then + if(pm_main_process) then + write(*,*) 'Cannot parse system module: '//trim(str2) + endif + call pm_stop('Compilation terminated') + endif + +!!$ +!!$ call sysdefs(parser) call pm_gc(context,.false.) if(pm_opts%out_debug_files) then open(unit=9,file='sysmod.dmp') @@ -131,7 +160,7 @@ subroutine run_parser(mname,root,dict,visibility) endif ! Parse other modules - call pm_module_filename(mname,str2) + call pm_module_filename(mname,str2,pm_opts%lib_path_set,pm_opts%lib_path) if(.not.pm_file_exists(str2)) then if(pm_main_process) then write(*,*) 'Cannot open source file '//trim(str2)//& @@ -150,9 +179,9 @@ subroutine run_parser(mname,root,dict,visibility) parser%modl%offset+modl_link) if(pm_fast_isnull(parser%modl)) exit str=' ' - call pm_name_string(context,& - get_modl_name(parser%modl),str) - call pm_module_filename(str,str2) + module_name=get_modl_name(parser%modl) + call pm_name_string(context,module_name,str) + call pm_module_filename(str,str2,pm_opts%lib_path_set,pm_opts%lib_path) call pm_open_file(pm_comp_file_unit,str2,ok) if(.not.ok) then if(pm_main_process) then @@ -224,11 +253,7 @@ subroutine run_coder_and_inference(root,visibility,proc_code,proc_cache,poly_cac call run_type_inference(coder) proc_code=coder%vstack(1) proc_cache=coder%proc_cache - if(pm_is_compiling) then - poly_cache=coder%poly_cache - else - poly_cache=pm_null_obj - endif + poly_cache=coder%poly_cache call term_coder(coder) call pm_gc(context,.false.) end subroutine run_coder_and_inference @@ -270,7 +295,7 @@ subroutine run_type_inference(coder) integer:: i logical:: save_variants,save_elems,save_members if(pm_debug_level>1) write(*,*) 'TYPE INFERENCE>>' - call prc_prog(coder) + call inf_prog(coder) if(pm_opts%out_typelist) then write(*,*) 'TOTAL TYPES::',pm_dict_size(context,context%tcache) @@ -285,11 +310,7 @@ subroutine run_type_inference(coder) !pm_opts%show_elems=.true. !pm_opts%show_variants=.true. do i=1,pm_dict_size(context,context%tcache) - write(4,*) 'TYPE',i,pm_typ_kind(context,i) - write(4,*) i,trim(pm_typ_as_string(context,i)) - call pm_dump_tree(context,4,pm_typ_val(context,i),2) - call dump_type(context,4,i) - write(4,*) 'DONE',i + write(4,*) iand(pm_type_flags(context,i),pm_type_has_storage)/=0,iand(pm_type_flags(context,i),pm_type_has_fix)/=0,trim(pm_type_as_string(context,i)) enddo pm_opts%show_members=save_members pm_opts%show_elems=save_elems @@ -360,19 +381,72 @@ subroutine run_wcode_stage(prog_code,proc_cache,code_cache,poly_cache,typeset) endif end subroutine run_wcode_stage -!!$ subroutine repl -!!$ type(parse_state),target:: parser -!!$ type(code_state):: coder -!!$ type(wcoder),target:: wcd -!!$ -!!$ prog=root%data%ptr(root%offset+modl_stmts) -!!$ if(pm_fast_isnull(prog)) call pm_stop('No program defined to run') -!!$ call trav_prog(coder,prog) -!!$ call prc_prog(coder) -!!$ call init_wcoder(context,wcd,proc_cache,poly_cache) -!!$ call wcode_prog(wcd,prog_code) -!!$ call wcode_procs(wcd) -!!$ -!!$ end subroutine repl + subroutine repl(context) + type(pm_context),pointer:: context + type(parse_state),target:: parser + type(code_state):: coder + type(wcoder),target:: wcd + type(pm_ptr):: root,prog,dict + integer:: name,err + character(len=2000):: line,str2 + logical:: first + call init_parser(parser,context) + call dcl_module(parser,'PM__system') + parser%sysmodl=parser%modl + call pm_module_filename('lib.sys.pm',str2,pm_opts%lib_path_set,pm_opts%lib_path) + call pm_open_file(pm_comp_file_unit,str2,ok) + if(.not.ok) then + if(pm_main_process) then + write(*,*) 'Cannot open system module: '//trim(str2) + endif + call pm_stop('Compilation terminated') + endif + !write(*,*) 'Parsing',trim(str) + call parse_file_on_unit(parser,pm_comp_file_unit,.false.) + close(pm_comp_file_unit) + if(parser%error_count>0) then + if(pm_main_process) then + write(*,*) 'Cannot parse system module: '//trim(str2) + endif + call pm_stop('Compilation terminated') + endif + name=pm_name_entry(context,'PM__REPL') + call new_modl(parser,name) + root=parser%modls + parser%modl=parser%modls + first=.true. + do + write(*,'(a)',advance='NO') 'PM> ' + read(*,'(a)') line + if(line=='exit') return + call parse_expr_from_string(parser,line,first) + first=.false. + dict=parser%modl_dict + visibility=parser%visibility + if(parser%error_count==0) then + err=0 + call link_includes(context,err,dict) + if(err==0) then + prog=root%data%ptr(root%offset+modl_stmts) + if(pm_fast_isnull(prog)) call pm_stop('No program defined to run') + !call dump_parse_tree(context,6,prog,2) + call init_coder(context,coder,visibility) + call trav_prog(coder,prog) + call inf_prog(coder) + if(coder%num_errors==0) then + prog_code=coder%vstack(1) + proc_cache=coder%proc_cache + call init_wcoder(context,wcd,proc_cache,pm_null_obj) + call wcode_prog(wcd,prog_code) + code_cache=wcd%code_cache + call wcode_procs(wcd) + if(wcd%num_errors==0) then + call pm_run_prog(context,pm_dict_vals(context,code_cache)) + endif + endif + endif + endif + enddo + end subroutine repl end program pm diff --git a/src/memory.f90 b/src/memory.f90 index 8639197..da24230 100755 --- a/src/memory.f90 +++ b/src/memory.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2016 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -42,7 +42,7 @@ module pm_memory public pm_assign_new, pm_expand, pm_ptr_assign public pm_new_as_root,pm_get_ptr_as_root, pm_copy, pm_copy_ptr, pm_assign_copy public pm_new_string, pm_concat_string, pm_strval, pm_fill_vect, & - pm_copy_obj, pm_set_obj + pm_copy_obj, pm_set_obj, pm_new_string_of_width public pm_add_root, pm_delete_root public pm_numroot, pm_delete_numroot public pm_register, pm_delete_register @@ -230,6 +230,7 @@ module pm_memory type(pm_ptr),public:: pm_undef_obj,pm_null_obj,pm_tinyint_obj,pm_name_obj type(pm_ptr),public:: pm_typeno_obj,pm_procname_obj,pm_true_obj,pm_false_obj + type(pm_ptr),dimension(pm_int:pm_num_vkind),public:: pm_empty_obj contains @@ -529,30 +530,32 @@ subroutine pm_expand(context,obj,n,newsize) end subroutine pm_expand ! Create a new object - function pm_new(context,vkind,esize) result(ptr) + function pm_new(context,vkind,size) result(ptr) type(pm_context),pointer:: context integer(pm_p),intent(in):: vkind - integer(pm_ln),intent(in):: esize + integer(pm_ln),intent(in):: size type(pm_ptr):: ptr if(pm_debug_level>0) then if(vkindpm_usr) & call pm_panic('New - bad vkind') - if(esize<=0) & - call pm_panic('New - non +ve esize') + if(size<0) & + call pm_panic('New - non +ve size') endif - if(esize<=pm_large_obj_size) then - ptr=pm_new_small(context,vkind,int(esize,pm_p)) + if(size==0) then + ptr=pm_empty_obj(vkind) + elseif(size<=pm_large_obj_size) then + ptr=pm_new_small(context,vkind,int(size,pm_p)) else - ptr=pm_new_large(context,vkind,esize) + ptr=pm_new_large(context,vkind,size) endif end function pm_new ! Create multiple new objects ! -- assign to locations loc,loc+1,...,loc+n-1 in vect - subroutine pm_new_multi(context,vkind,esize,loc,n,vect) + subroutine pm_new_multi(context,vkind,size,loc,n,vect) type(pm_context),pointer:: context integer(pm_p),intent(in):: vkind - integer(pm_ln),intent(in):: loc,n,esize + integer(pm_ln),intent(in):: loc,n,size type(pm_ptr),intent(in):: vect integer(pm_ln):: i,j,k,m type(pm_ptr):: ptr @@ -560,10 +563,10 @@ subroutine pm_new_multi(context,vkind,esize,loc,n,vect) logical:: is_marked context%temp_obj1=vect is_marked=marked(vect) - if(esize<=pm_large_obj_size) then + if(size<=pm_large_obj_size) then i=0 do while(icontext%obj_list(esize,vkind) + ptr_p=>context%obj_list(size,vkind) ptr=ptr_p if(associated(ptr%data)) then if(ptr%offsetpm_add_root(context,ptr) end function pm_new_as_root ! Create a new object of <= pm_large_obj_size elements - function pm_new_small(context,vkind,esize) result(nptr) + function pm_new_small(context,vkind,size) result(nptr) type(pm_context),pointer:: context - integer(pm_p),intent(in):: vkind,esize + integer(pm_p),intent(in):: vkind,size type(pm_ptr):: nptr type(pm_ptr):: ptr type(pm_block),pointer:: oldblk @@ -620,48 +623,49 @@ function pm_new_small(context,vkind,esize) result(nptr) logical:: ok integer:: i - if(gc_xtra_debug) write(*,*) 'ALLOCATE>',vkind,esize + if(gc_xtra_debug) write(*,*) 'ALLOCATE>',vkind,size if(pm_debug_level>0) then if(vkindpm_usr) & call pm_panic('New small - bad vkind') - if(esize<=0.or.esize>pm_large_obj_size) & - call pm_panic('New small - bad esize') + if(size<=0.or.size>pm_large_obj_size) & + call pm_panic('New small - bad size') endif ! Get allocation slot for kind and size if(pm_debug_level>0) then - if(esize<=0) call pm_panic('alloc-esize') + if(size<=0) call pm_panic('alloc-size') endif - ptr_p=>context%obj_list(esize,vkind) + ptr_p=>context%obj_list(size,vkind) ptr=ptr_p if(associated(ptr%data)) then if(ptr%offsetmax_blocks) & - call pm_gc(context,.false.) - ptr%data=>new_block(context,vkind,int(esize,pm_ln)) + if(context%blocks_allocated>max_blocks) then + call pm_gc(context,.false.) + endif + ptr%data=>new_block(context,vkind,int(size,pm_ln)) ptr%offset=1 ptr%data%next=>ptr%data - ptr%data%next_sweep=ptr%data%size-esize+2 + ptr%data%next_sweep=ptr%data%size-size+2 ptr_p%data=>ptr%data - ptr_p%offset=1+esize + ptr_p%offset=1+size nptr=ptr goto 10 endif ! Check if GC has run since last use of this slot if(ptr%data%tickcontext%obj_list(esize,vkind) + ptr_p=>context%obj_list(size,vkind) if(associated(ptr_p%data)) then ptr=ptr_p ptr%offset=1 @@ -689,15 +693,15 @@ function pm_new_small(context,vkind,esize) result(nptr) if(.not.ok) then ! All full - allocate new block - ptr%data=>new_block(context,vkind,int(esize,pm_ln)) + ptr%data=>new_block(context,vkind,int(size,pm_ln)) ptr%offset=1 - ptr%data%next_sweep=ptr%data%size-esize+2 - ptr_p=>context%obj_list(esize,vkind) + ptr%data%next_sweep=ptr%data%size-size+2 + ptr_p=>context%obj_list(size,vkind) if(associated(ptr_p%data)) then ptr%data%next=>ptr_p%data%next ptr_p%data%next=>ptr%data ptr_p%data=>ptr%data - ptr_p%offset=1+esize + ptr_p%offset=1+size else ptr%data%next=>ptr%data endif @@ -713,7 +717,7 @@ function pm_new_small(context,vkind,esize) result(nptr) if(gc_xtra_debug) write(*,*) 'NEXT FREE' ! Find following free location - ptr%offset=ptr%offset+esize + ptr%offset=ptr%offset+size call next_free() if(.not.ok) then @@ -729,15 +733,15 @@ function pm_new_small(context,vkind,esize) result(nptr) ptr_p=ptr ! Find extent of run of free locations - ptr%offset=ptr%offset+esize + ptr%offset=ptr%offset+size do - if(ptr%offset+esize>ptr%data%size+1) then + if(ptr%offset+size>ptr%data%size+1) then exit endif if(marked(ptr)) exit if(gc_xtra_debug) & write(0,*) 'FREE',ptr%offset - ptr%offset=ptr%offset+esize + ptr%offset=ptr%offset+size enddo ptr%data%next_sweep=ptr%offset @@ -746,15 +750,15 @@ function pm_new_small(context,vkind,esize) result(nptr) if(pm_debug_level>3) call pm_verify_heap(context) if(pm_debug_level>0) then - if(mod(nptr%offset-1,esize)/=0& - .or.nptr%offset+esize>nptr%data%size+1) then + if(mod(nptr%offset-1,size)/=0& + .or.nptr%offset+size>nptr%data%size+1) then call pm_panic('misaligned allocation') endif endif ! Always initialise pointers if(vkind>=pm_pointer) & - nptr%data%ptr(nptr%offset:nptr%offset+esize-1)=pm_null_obj + nptr%data%ptr(nptr%offset:nptr%offset+size-1)=pm_null_obj if(gc_xtra_debug) write(0,*) 'all',nptr%offset,nptr%data%next_sweep @@ -763,7 +767,7 @@ function pm_new_small(context,vkind,esize) result(nptr) ! Find next free location in circular chain of blocks subroutine next_free() do - if(ptr%offset+esize>ptr%data%size+1) then + if(ptr%offset+size>ptr%data%size+1) then if(ptr%data%next%tick>=context%tick) then ! Scanned this block before - no hope ok=.false. @@ -781,30 +785,30 @@ subroutine next_free() ptr%data%ptr(ptr%offset)%offset endif if(.not.marked(ptr)) exit - ptr%offset=ptr%offset+esize + ptr%offset=ptr%offset+size enddo end subroutine next_free end function pm_new_small ! Create a new object of >= pm_large_obj_size elements - function pm_new_large(context,vkind,esize) result(ptr) + function pm_new_large(context,vkind,size) result(ptr) type(pm_context),pointer:: context integer(pm_p),intent(in):: vkind - integer(pm_ln):: esize + integer(pm_ln):: size type(pm_ptr):: ptr type(pm_block),pointer:: blk if(pm_debug_level>0) then if(vkindpm_usr) & call pm_panic('New large - bad vkind') - if(esize<=0) & - call pm_panic('New large -ve esize') + if(size<=0) & + call pm_panic('New large -ve size') endif if(context%blocks_allocated>max_blocks) & call pm_gc(context,.false.) - blk=>new_block(context,vkind,esize) + blk=>new_block(context,vkind,size) blk%next=>context%new_large context%new_large=>blk if(pm_debug_level>0) then @@ -813,7 +817,7 @@ function pm_new_large(context,vkind,esize) result(ptr) ptr%data=>blk ptr%offset=1 if(vkind>=pm_pointer) & - ptr%data%ptr(ptr%offset:ptr%offset+esize-1)=pm_null_obj + ptr%data%ptr(ptr%offset:ptr%offset+size-1)=pm_null_obj end function pm_new_large ! Create new string object from FORTRAN string @@ -832,6 +836,44 @@ function pm_new_string(context,string) result(ptr) endif end function pm_new_string + ! Create new string object from FORTRAN string + function pm_new_string_of_width(context,string,width) result(ptr) + type(pm_context),pointer:: context + character(len=*),intent(in):: string + integer(pm_ln),intent(in):: width + type(pm_ptr):: ptr + integer::i,n + if(width==0) then + ptr=pm_new_string(context,"") + return + endif + ptr=pm_new(context,pm_string,abs(width)) + n=len(string) + if(n>abs(width)) then + do i=1,abs(width) + ptr%data%s(ptr%offset+i-1)='*' + enddo + return + endif + if(n>0) then + if(width<0) then + do i=1,n + ptr%data%s(ptr%offset+i-1)=string(i:i) + enddo + do i=n+1,abs(width) + ptr%data%s(ptr%offset+i-1)=' ' + enddo + else + do i=1,abs(width)-n + ptr%data%s(ptr%offset+i-1)=' ' + enddo + do i=1,n + ptr%data%s(ptr%offset+i+abs(width)-n-1)=string(i:i) + enddo + endif + endif + end function pm_new_string_of_width + ! Get FORTRAN string from PM string subroutine pm_strval(ptr,str) type(pm_ptr),intent(in):: ptr @@ -1548,6 +1590,10 @@ subroutine init_context(context,startup) pm_false_obj%offset=1 pm_true_obj%data%l(pm_true_obj%offset)=.true. pm_false_obj%data%l(pm_false_obj%offset)=.false. + do i=pm_int,pm_num_vkind + pm_empty_obj(i)%data=>new_block(context,int(i,pm_p),0_pm_ln) + pm_empty_obj(i)%offset=0 + enddo endif forall (i=1:pm_large_obj_size, j=pm_int:pm_num_vkind) context%obj_list(i,j)%data=>null() @@ -1658,6 +1704,8 @@ function new_block(context,vkind,esize) result(blk) call pm_panic("Out of memory") endif + if(tsize==0) goto 10 + ! Allocate data area select case(vkind) case(pm_int) @@ -1714,7 +1762,8 @@ function new_block(context,vkind,esize) result(blk) call pm_panic("Out of memory") endif - 10 continue +10 continue + ! Finish initialising block blk%magic=1234567 blk%context=>context diff --git a/src/opts.f90 b/src/opts.f90 index 69e1beb..6d9a5ae 100755 --- a/src/opts.f90 +++ b/src/opts.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2021 +! Copyright (c) Tim Bellerby, 2025 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -36,14 +36,20 @@ module pm_options logical:: check_stmts logical:: show_elems logical:: show_members - logical:: see_all_procs + logical:: show_all_procs + logical:: show_full_trace logical:: out_debug_files logical:: old_files integer:: proc_list + integer:: trace_list logical:: show_variants + logical:: show_details logical:: check_alias logical:: show_all_ref logical:: print_immediate + logical:: show_hidden + logical:: lib_path_set + character(len=pm_max_filename_size):: lib_path logical:: out_sysmod logical:: out_typelist @@ -65,7 +71,10 @@ module pm_options logical:: ftn_name_types logical:: ftn_name_elems + logical:: is_repl + character(len=25):: error + character(len=7):: error_start logical:: colour end type pm_opts_type @@ -76,17 +85,22 @@ module pm_options subroutine init_opts(context) type(pm_context),pointer:: context - logical:: colour + logical:: colour,bright pm_opts%inline=.true. pm_opts%check_stmts=.not.pm_is_compiling pm_opts%show_elems=.false. pm_opts%show_members=.false. - pm_opts%see_all_procs=.false. + pm_opts%show_all_procs=.false. + pm_opts%show_full_trace=.false. pm_opts%proc_list=11 + pm_opts%trace_list=11 pm_opts%show_variants=.false. + pm_opts%show_details=.false. pm_opts%check_alias=.not.pm_is_compiling pm_opts%show_all_ref=.false. pm_opts%print_immediate=.false. + pm_opts%show_hidden=.false. + pm_opts%lib_path_set=.false. pm_opts%out_sysmod=.false. pm_opts%out_typelist=.false. @@ -110,24 +124,51 @@ subroutine init_opts(context) pm_opts%ftn_name_types=.false. pm_opts%ftn_name_elems=.false. colour=pm_colour_messages.and.pm_isatty(6) + bright=pm_bright_messages + if(bright) then + pm_opts%error_start=pm_error_start_bright + else + pm_opts%error_start=pm_error_start + endif if(colour) then - pm_opts%error=pm_error_start//'Error: '//pm_error_end + pm_opts%error=pm_opts%error_start//'Error:'//pm_error_end else pm_opts%error='Error: ' endif pm_opts%colour=colour + + call pm_get_env_var(pm_env_var,pm_opts%lib_path,pm_opts%lib_path_set) + if(.not.pm_opts%lib_path_set) then + pm_opts%lib_path_set=pm_default_lib_path_set + pm_opts%lib_path=pm_default_lib_path + endif + + pm_opts%is_repl=.false. end subroutine init_opts subroutine print_usage if(pm_main_process) then - write(*,*) 'Usage: pm [-f] [-D] [-help] root_module_name_or_filename' write(*,*) - write(*,*) ' -f Language options' - write(*,*) ' --help Longer help message' - write(*,*) ' -D Output compiler debugging information' + if(pm_is_compiling) then + write(*,*) 'Usage: pmc [-f] [-D] [ --help | root_module_name_or_filename ]' + else + write(*,*) 'Usage: pm [-f] [-D] [ --help | -i | root_module_name_or_filename ]' + write(*,*) ' -i Interactive mode' + endif + write(*,*) ' -L Set path to locate PM libraries' + write(*,*) ' -f Language options' + write(*,*) ' -H Terminal output options' + if(pm_is_compiling) then + write(*,*) ' -ftn Fortran language output options' + endif + write(*,*) ' -D Options for debugging the compiler itself' + write(*,*) ' --help Longer help message' endif end subroutine print_usage + + + subroutine usage call print_usage call pm_stop(' ') @@ -142,25 +183,35 @@ subroutine help write(*,*) ' Only the main (program) module must be named - other modules are' write(*,*) ' included automatically.' write(*,*) + write(*,*) ' CONFIGURATION OPTIONS' + write(*,*) ' -L Look for library files in rather than lib' + write(*,*) write(*,*) ' LANGUAGE OPTIONS' - write(*,*) ' -fno-inline Do not inline any procedures.' - write(*,*) ' -fno-check Do not run "check" or "test" statements.' - write(*,*) ' -fcheck Run "check" and "test" statements.' - write(*,*) ' -fshow-elems Show structure/record elements in error messages.' - write(*,*) ' -fshow-members Show members of user defined types in error messages' - write(*,*) ' -fshow-variants Show all variants for proc types' - write(*,*) ' -fsee-all-procs List all alternative procedures in error messages' - write(*,*) ' -fproc-list=n Maximum number of procs to list if see-all-procs not invoked' - write(*,*) ' -fno-alias-check Do not check for argument aliasing' - write(*,*) ' -falias_check Check for argument aliasing' + write(*,*) ' -fno-inline Do not inline any procedures.' + write(*,*) ' -fno-check Do not run "check" or "test" statements.' + write(*,*) ' -fcheck Run "check" and "test" statements.' + write(*,*) ' -fno-alias-check Do not check for argument aliasing' + write(*,*) ' -falias_check Check for argument aliasing' if(.not.pm_is_compiling) then write(*,*) ' -fprint-immediate' - write(*,*) ' Do not buffer print output by node' + write(*,*) ' Do not buffer print output by node' endif write(*,*) - write(*,*) ' GENERAL OPTIONS' - write(*,*) ' -N Do not colour-highlight error messages' - write(*,*) ' -H Colour-highlight error messages' + write(*,*) ' ERROR AND WARNING MESSAGE OUTPUT OPTIONS' + write(*,*) ' -fshow-elems Show structure/record elements in error messages.' + write(*,*) ' -fshow-members Show members of user defined types in error messages' + write(*,*) ' -fshow-variants Show all variants for proc types' + write(*,*) ' -fshow-all-procs List all alternative procedures in error messages' + write(*,*) ' -fproc-list=n Maximum number of procs to list if show-all-procs not invoked' + write(*,*) ' -fshow-full-trace List all alternative procedures in error messages' + write(*,*) ' -ftrace-list=n Maximum number of calls to list if show-full-trace not invoked' + + write(*,*) + write(*,*) ' TERMINAL DISPLAY OPTIONS' + write(*,*) ' -HN Do not colour-highlight error messages' + write(*,*) ' -H Colour-highlight error messages' + write(*,*) ' -HB Colour-highlight error messages using bright colours' + write(*,*) ' -HS Colour-highlight error messages using standard colours' if(pm_is_compiling) then write(*,*) write(*,*) ' OPTIMISER OPTIONS' @@ -201,12 +252,14 @@ subroutine help write(*,*) ' Include various annotation comments (mainly for debugging the compiler)' endif write(*,*) - write(*,*) ' OPTIONS FOR DEBUGGING THE COMPILER' - write(*,*) ' -D Activate all debugging options listed below.' - write(*,*) ' -Dfiles Output files from each compiler stage.' - write(*,*) ' -Dtimings Output time taken by each compilation stage.' - write(*,*) ' -Dsys-mod Output a listing of the system module.' - write(*,*) ' -Dtype-list Output a list of all types used by the system.' + write(*,*) ' OPTIONS FOR DEBUGGING THE COMPILER ITSELF' + write(*,*) ' -Dshow-details Show extra details of types' + write(*,*) ' -Dshow-hidden Show hidden procedure parameters' + write(*,*) ' -D Activate all debugging options listed below.' + write(*,*) ' -Dfiles Output files from each compiler stage.' + write(*,*) ' -Dtimings Output time taken by each compilation stage.' + write(*,*) ' -Dsys-mod Output a listing of the system module.' + write(*,*) ' -Dtype-list Output a list of all types used by the system.' endif call pm_stop(' ') end subroutine help @@ -214,7 +267,7 @@ end subroutine help subroutine pm_get_command_line(context,mname) type(pm_context),pointer:: context character(len=*),intent(out):: mname - character(len=pm_max_filename_size):: arg + character(len=pm_max_filename_size+5):: arg integer:: i,n call init_opts(context) n=pm_get_cl_count() @@ -226,14 +279,29 @@ subroutine pm_get_command_line(context,mname) write(*,*) 'Not a command line option: ',trim(arg) call usage() endif - elseif(arg(1:2)=='-N') then - pm_opts%error='Error: ' + elseif(arg(1:2)=='-L') then + pm_opts%lib_path_set=.true. + pm_opts%lib_path=arg(3:) + elseif(arg=='-HN') then + pm_opts%error='Error:' pm_opts%colour=.false. - elseif(arg(1:2)=='-H') then + elseif(arg=='-HS') then pm_opts%error=pm_error_start//'Error: '//pm_error_end + pm_opts%error_start=pm_error_start + pm_opts%colour=.true. + elseif(arg=='-HB') then + pm_opts%error=pm_error_start_bright//'Error: '//pm_error_end + pm_opts%error_start=pm_error_start_bright + pm_opts%colour=.true. + elseif(arg=='-H') then + pm_opts%error=pm_opts%error_start//'Error: '//pm_error_end pm_opts%colour=.true. elseif(arg(1:2)=='-D') then - if(arg=='-D') then + if(arg=='-Dshow-details') then + pm_opts%show_details=.true. + elseif(arg=='-Dshow-hidden') then + pm_opts%show_hidden=.true. + elseif(arg=='-D') then pm_opts%out_debug_files=.true. pm_opts%out_sysmod=.true. pm_opts%out_typelist=.true. @@ -269,8 +337,10 @@ subroutine pm_get_command_line(context,mname) pm_opts%show_members=.true. elseif(arg=='-fshow-variants') then pm_opts%show_variants=.true. - elseif(arg=='-fsee-all-procs') then - pm_opts%see_all_procs=.true. + elseif(arg=='-fshow-all-procs') then + pm_opts%show_all_procs=.true. + elseif(arg=='-fshow-full-trace') then + pm_opts%show_full_trace=.true. elseif(arg=='-falias-check') then pm_opts%check_alias=.true. elseif(arg=='-fno-alias-check') then @@ -279,7 +349,9 @@ subroutine pm_get_command_line(context,mname) pm_opts%print_immediate=.true. elseif(arg(1:12)=='-fproc-list=') then pm_opts%proc_list=get_num_opt(arg,arg(13:)) - elseif(arg(3:4)=='tn') then + elseif(arg(1:12)=='-ftrace-list=') then + pm_opts%trace_list=get_num_opt(arg,arg(14:)) + elseif(arg(3:4)=='tn'.and.pm_is_compiling) then if(arg=='-ftn-contig') then pm_opts%ftn_contig=.true. elseif(arg=='-ftn-no-contig') then @@ -335,15 +407,15 @@ subroutine pm_get_command_line(context,mname) pm_opts%ftn_name_types=.false. pm_opts%ftn_name_elems=.false. elseif(pm_main_process) then - write(*,*) 'Not a valid fortran name (-ftn-name-no) option:',trim(arg) + write(*,*) 'Not a valid fortran name (-ftn-no-name) option: ',trim(arg) call usage() endif elseif(pm_main_process) then - write(*,*) 'Not a valid fortran output (-ftn) option:',trim(arg) + write(*,*) 'Not a valid fortran output (-ftn) option: ',trim(arg) call usage() endif elseif(pm_main_process) then - write(*,*) 'Not a valid language (-f) option:',trim(arg) + write(*,*) 'Not a valid language (-f) option: ',trim(arg) call usage() endif elseif(arg(1:4)=='-opt') then @@ -352,7 +424,7 @@ subroutine pm_get_command_line(context,mname) elseif(arg=='-opt-no-sched') then pm_opts%schedule=.false. elseif(pm_main_process) then - write(*,*) 'Not a valid optimiser (-opt) option:',trim(arg) + write(*,*) 'Not a valid optimiser (-opt) option: ',trim(arg) call usage() endif elseif(arg=='--help') then @@ -368,6 +440,8 @@ subroutine pm_get_command_line(context,mname) call pm_get_cl_arg(i,mname) if(mname=='--help') then call help + elseif(mname=='-i') then + pm_opts%is_repl=.true. elseif(mname(1:1)=='-') then call usage() endif diff --git a/src/parlib.f90 b/src/parlib.f90 index b21b456..fa381b1 100644 --- a/src/parlib.f90 +++ b/src/parlib.f90 @@ -405,7 +405,7 @@ recursive subroutine broadcast(context,node,v,xcomm,xthis) call pm_ptr_assign(context,w,j,& broadcast_val(context,node,w%data%ptr(w%offset+j),nn,xcomm,xthis)) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call broadcast(context,node,v%data%ptr(v%offset+i),xcomm,xthis) enddo @@ -501,7 +501,7 @@ recursive subroutine broadcast_disp(context,node,v,off,offstart,noff,xcomm) call pm_ptr_assign(context,avec,k,broadcast_val(context,& node,avec%data%ptr(avec%offset+k),nout,xcomm)) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call broadcast_disp(context,node,v%data%ptr(v%offset+i),off,offstart,noff,xcomm) enddo @@ -642,7 +642,7 @@ recursive function broadcast_val(context,node,v,nout,xcomm,xthis) result(ptr) broadcast_val(context,node,w%data%ptr(w%offset+j),nn,xcomm,xthis)) enddo call pm_delete_root(context,root) - case(pm_struct_type,pm_rec_type,pm_polyref_type,pm_dref_type,pm_dref_shared_type) + case(pm_rec_type,pm_polyref_type,pm_dref_type,pm_dref_shared_type) root=>pm_new_as_root(context,pm_usr,esize+1) ptr=root%ptr ptr%data%ptr(ptr%offset)%offset=tno @@ -818,7 +818,7 @@ recursive function broadcast_val_disp(context,off,offstart,noff,node,v,nout) res broadcast_val(context,node,w%data%ptr(w%offset+k),nn)) enddo call pm_delete_root(context,root) - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) root=>pm_new_as_root(context,pm_usr,esize+1) ptr=root%ptr ptr%data%ptr(ptr%offset)%offset=tno @@ -991,7 +991,7 @@ recursive subroutine gather(context,v,w,j) broadcast_val(context,k,& v%data%ptr(v%offset+pm_array_vect),nn)) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call gather(context,v%data%ptr(v%offset+i),w%data%ptr(w%offset+i),j) enddo @@ -1051,7 +1051,7 @@ recursive subroutine recv(context,node,v,mess_tag) do j=0,pm_fast_esize(len) call pm_ptr_assign(context,avec,j,recv_val(context,node,mess_tag+1)) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,esize call recv(context,node,v%data%ptr(v%offset+i),mess_tag) enddo @@ -1141,7 +1141,7 @@ recursive subroutine recv_rest(context,node,v,mess_tag) do j=0,pm_fast_esize(avec) call pm_ptr_assign(context,avec,j,recv_val(context,node,mess_tag+1)) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,esize call recv_rest(context,node,v%data%ptr(v%offset+i),mess_tag) enddo @@ -1191,7 +1191,7 @@ recursive subroutine recv_disp(context,node,v,off,offstart,noff,mess_tag) k=off%data%ln(off%offset+offstart+j) call pm_ptr_assign(context,avec,k,recv_val(context,node,mess_tag+1)) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call recv_disp(context,node,v%data%ptr(v%offset+i),off,offstart,noff,mess_tag) enddo @@ -1290,7 +1290,7 @@ recursive subroutine recv_rest_disp(context,node,v,off,offstart,noff,mess_tag) call pm_ptr_assign(context,avec,k,recv_val(context,node,mess_tag+1)) enddo if(debug_mess) call pm_dump_tree(context,6,v,2) - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call recv_rest_disp(context,node,v%data%ptr(v%offset+i),off,offstart,noff,mess_tag) enddo @@ -1360,7 +1360,7 @@ recursive function recv_val(context,node,mess_tag) result(ptr) recv_val(context,node,mess_tag)) enddo call pm_delete_root(context,root) - case(pm_struct_type,pm_rec_type,pm_polyref_type,pm_dref_type,pm_dref_shared_type) + case(pm_rec_type,pm_polyref_type,pm_dref_type,pm_dref_shared_type) root=>pm_new_as_root(context,pm_usr,esize+1) ptr=root%ptr ptr%data%ptr(ptr%offset)%offset=tno @@ -1484,7 +1484,7 @@ recursive subroutine isend(node,v,mess_tag,xcomm) avec%data%ptr(avec%offset+j),& 0_pm_ln,-1_pm_ln,mess_tag+1,xcomm) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call isend(node,v%data%ptr(v%offset+i),mess_tag,xcomm) enddo @@ -1595,7 +1595,7 @@ recursive subroutine irecv(node,v,mess_tag,iserr,xcomm) case(pm_array_type,pm_const_array_type) iserr=.true. return - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call irecv(node,v%data%ptr(v%offset+i),mess_tag,iserr,xcomm) enddo @@ -1720,7 +1720,7 @@ recursive subroutine isend_val(node,v,start,siz,mess_tag,xcomm) off%data%ln(off%offset+j),& len%data%ln(len%offset+j),mess_tag,xcomm) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type,pm_dref_type,pm_dref_shared_type) + case(pm_rec_type,pm_polyref_type,pm_dref_type,pm_dref_shared_type) do i=2,pm_fast_esize(v) call isend_val(node,v%data%ptr(v%offset+i),start,siz,mess_tag,xcomm) enddo @@ -1853,7 +1853,7 @@ recursive subroutine isend_val_disp(node,v,off,offstart,noff,mess_tag) avec%data%ptr(avec%offset+k),& 0_pm_ln,-1_pm_ln,mess_tag+1) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call isend_val_disp(node,v%data%ptr(v%offset+i),off,offstart,noff,mess_tag) enddo @@ -1978,7 +1978,7 @@ recursive subroutine isend_disp(node,v,off,offstart,noff,mess_tag,xcomm) avec%data%ptr(avec%offset+k),& 0_pm_ln,-1_pm_ln,mess_tag+1) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call isend_disp(node,v%data%ptr(v%offset+i),off,offstart,noff,mess_tag) enddo @@ -2126,7 +2126,7 @@ recursive subroutine irecv_disp(context,node,v,off,offstart,noff,mess_tag,partia call irecv_disp(context,node,& v%data%ptr(v%offset+pm_array_length),& off,offstart,noff,mess_tag,partial) - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call irecv_disp(context,node,v%data%ptr(v%offset+i),& off,offstart,noff,mess_tag,partial) @@ -2240,7 +2240,7 @@ recursive subroutine rsend(context,node,v,mess_tag) call isend_val(node,avec%data%ptr(avec%offset+j),& 0_pm_ln,-1_pm_ln,mess_tag+1) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,esize call rsend(context,node,v%data%ptr(v%offset+i),mess_tag) enddo @@ -2333,7 +2333,7 @@ recursive subroutine rsend_disp(context,node,v,off,offstart,noff,mess_tag) call isend_val(node,avec%data%ptr(avec%offset+k),& 0_pm_ln,-1_pm_ln,mess_tag+1) enddo - case(pm_struct_type,pm_rec_type,pm_polyref_type) + case(pm_rec_type,pm_polyref_type) do i=2,pm_fast_esize(v) call rsend_disp(context,node,v%data%ptr(v%offset+i),off,offstart,noff,mess_tag) enddo @@ -4448,9 +4448,9 @@ subroutine pm_file_write_disps(handle,buffer,offsets,noff,totsize,ierr) include 'fvkind.inc' end subroutine pm_file_write_disps - subroutine pm_file_error_string(v,n,str) + subroutine pm_file_error_string(v,n,m,str) type(pm_ptr),intent(in):: v - integer(pm_ln),intent(in):: n + integer(pm_ln),intent(in):: n,m character(len=*),intent(out):: str character(len=mpi_max_error_string):: mess integer:: length,ierr diff --git a/src/parser.f90 b/src/parser.f90 index 922a59d..de47a2f 100644 --- a/src/parser.f90 +++ b/src/parser.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -36,97 +36,16 @@ module pm_parser use pm_symbol use pm_vmdefs use pm_types + use pm_ast implicit none ! Print out lots of parser debugging info logical,parameter:: debug_parser=.false. - logical,parameter:: debug_parser_extra=.false. ! Check if memory manager attempts to reuse a node ! (this should not happen so is one test of gc) logical,parameter:: check_node_reuse=.false. - ! Offsets into module objects - integer,parameter:: modl_name=1 - integer,parameter:: modl_link=2 - integer,parameter:: modl_last=3 - integer,parameter:: modl_stmts=4 - integer,parameter:: modl_include=5 - integer,parameter:: modl_proc=6 - integer,parameter:: modl_type=7 - integer,parameter:: modl_param=8 - integer,parameter:: modl_local=3 - - ! Offsets into parser node objects of various kinds - integer,parameter:: node_magic=0 - integer,parameter:: node_symbol=1 - integer,parameter:: node_modl=2 - integer,parameter:: node_lineno=3 - integer,parameter:: node_charno=4 - integer,parameter:: node_args=5 - - ! Type parse nodes - integer,parameter:: typ_name=node_args - integer,parameter:: typ_number=node_args+1 - integer,parameter:: typ_module=node_args+2 - integer,parameter:: typ_params=node_args+3 - integer,parameter:: typ_constraints=node_args+4 - integer,parameter:: typ_link=node_args+5 - integer,parameter:: typ_ins=node_args+6 - integer,parameter:: typ_includes=node_args+7 - integer,parameter:: typ_num_args=8 - integer,parameter:: typ_interface=node_args+8 - - ! Proc parse nodes - integer,parameter:: proc_name=node_args - integer,parameter:: proc_link=node_args+1 - integer,parameter:: proc_module=node_args+2 - integer,parameter:: proc_flags=node_args+3 - integer,parameter:: proc_params=node_args+4 - integer,parameter:: proc_keys=node_args+5 - integer,parameter:: proc_amplocs=node_args+6 - integer,parameter:: proc_coded_params=node_args+7 - integer,parameter:: proc_coded_results=node_args+8 - integer,parameter:: proc_coded_type=node_args+9 - integer,parameter:: proc_numret=node_args+10 - integer,parameter:: proc_result_types=node_args+11 - - ! Alternative final sections for 'proc' parse nodes - - ! - user functions - integer,parameter:: proc_reduce=node_args+12 - integer,parameter:: proc_check=node_args+13 - integer,parameter:: proc_result=node_args+14 - integer,parameter:: proc_stmts=node_args+15 - integer,parameter:: proc_code_tree=node_args+16 - integer,parameter:: proc_num_args=17 - - ! - built in functions - integer,parameter:: proc_retas=node_args+12 - integer,parameter:: proc_opcode=node_args+13 - integer,parameter:: proc_opcode2=node_args+14 - integer,parameter:: proc_data=node_args+15 - integer,parameter:: proc_coded_builtin=node_args+16 - integer,parameter:: sysproc_num_args=17 - - ! Values for flags (other values defined in sysdefs) - integer,parameter:: proc_is_comm=1 - integer,parameter:: proc_run_complete=2 - integer,parameter:: proc_run_local=4 - integer,parameter:: proc_run_shared=8 - integer,parameter:: proc_run_always=16 - integer,parameter:: proc_inline=32 - integer,parameter:: proc_no_inline=64 - integer,parameter:: proc_is_open=128 - integer,parameter:: proc_is_each_proc=256 - integer,parameter:: proc_is_cond=512 - integer,parameter:: proc_is_uncond=1024 - integer,parameter:: proc_is_abstract=2048 - - ! Corresponding flags in proc calls (must be same as for proc_is) - integer,parameter:: call_is_comm=1 - integer,parameter:: call_ignore_rules=256 - integer,parameter:: max_string=100 integer,parameter:: max_line=2001 integer,parameter:: max_parse_stack = 1024 @@ -140,13 +59,14 @@ module pm_parser integer:: ls,lineno,sym_lineno,name_lineno,old_sym_lineno logical:: newline,atstart integer:: n, sym_n, name_sym_n,old_sym_n, last, iunit - type(pm_ptr):: temp, lexval - integer:: sym, pushback + type(pm_ptr):: temp + integer:: sym, pushback, lexval integer,dimension(max_parse_stack):: stack integer:: top type(pm_ptr),dimension(max_parse_stack):: vstack integer,dimension(max_parse_stack):: vline,vchar integer:: vtop + type(pm_ptr):: op_names integer:: error_count type(pm_reg),pointer:: reg end type parse_state @@ -166,6 +86,7 @@ subroutine init_parser(parser,context) type(pm_context),pointer:: context integer:: i type(pm_ptr)::val + logical:: ok parser%context=>context parser%line(1)=' ' parser%line(2)=' ' @@ -184,8 +105,8 @@ subroutine init_parser(parser,context) parser%vtop=max_parse_stack parser%reg=>pm_register(context,'parser',& parser%modl,parser%modls,parser%modl_dict,& - parser%temp,parser%sysmodl,parser%lexval, & - parser%visibility,& + parser%temp,parser%sysmodl, & + parser%visibility,parser%op_names,& array=parser%vstack, & array_size=parser%vtop) parser%modl_dict=pm_dict_new(context,128_pm_ln) @@ -193,6 +114,18 @@ subroutine init_parser(parser,context) parser%modls=pm_null_obj parser%visibility=pm_set_new(context,128_pm_ln) parser%vtop=0 + parser%op_names=pm_dict_new(context,int(num_op-min_op+1,pm_ln)) + ! Create dictionary of operator names (for PM__intrinsic) + do i=min_op,num_op +!!$ write(*,*) '@>>',op_names(i),'{',op_names(op_offset_i8),'}',op_long_i8,op_long_i64 + call pm_dict_set(parser%context,parser%op_names,& + pm_new_string(parser%context,trim(op_names(i))),& + pm_fast_tinyint(parser%context,i),& + .true.,.false.,ok) + enddo + + contains + include 'ftiny.inc' end subroutine init_parser !====================================================== @@ -255,6 +188,7 @@ subroutine dcl_proc(parser,def,opcode,opcode2,line,flags) if(builtin(parser,opcode,opcode2,pm_null_obj,flags)) then call pm_panic('bad intrinsic module') endif + if(flags/=0) write(*,*) 'FLAGS=',flags end subroutine dcl_proc !====================================================== @@ -298,7 +232,7 @@ subroutine dcl_type(parser,def,line) endif if(pm_opts%out_sysmod) write(45,'(I4,A7,A)') line,'type:',trim(def) line=line+1 - if(type_decl(parser)) then + if(typ_decl(parser)) then write(*,*) def call pm_panic('bad intrinsic type') endif @@ -309,6 +243,29 @@ subroutine dcl_type(parser,def,line) endif end subroutine dcl_type + !====================================================== + ! Parse expression in string (for REPL) + !====================================================== + subroutine parse_expr_from_string(parser,line,use_sysmod) + type(parse_state),intent(inout):: parser + character(len=*),intent(in):: line + logical,intent(in):: use_sysmod + if(use_sysmod) then + call push_sym_val(parser,sym_pm_system) + call push_val(parser,parser%sysmodl) + call push_null_val(parser) + call make_node(parser,sym_use,3) + call new_import(parser,sym_pm_system,pop_val(parser)) + endif + call parse_from_string(parser,line) + call scan(parser) + call xexpr(parser) + call make_node(parser,sym_repl_line,1) + call make_node(parser,sym_list,1) + parser%modl%data%ptr(parser%modl%offset& + +modl_stmts)=pop_val(parser) + end subroutine parse_expr_from_string + !====================================================== ! Start parsing PM code from a string !====================================================== @@ -344,7 +301,7 @@ subroutine next_line(parser) parser%ls=3-parser%ls endif parser%lineno=parser%lineno+1 - if(debug_parser_extra) write(*,*) 'Now at line',parser%lineno + if(debug_parser) write(*,*) 'Now at line',parser%lineno if(parser%iunit>=0) then call pm_read_line(parser%iunit,parser%line(parser%ls),ios) if(ios/=0) goto 10 @@ -486,15 +443,20 @@ subroutine scan(parser) case(';') sym=sym_semi case('(') - if(peekchar()=='.') then + select case(peekchar()) + case('%') + if(peekchar_plus(1)/=':') then + c=getchar() + sym=sym_open_brace + else + sym=sym_open + endif + case('/') c=getchar() sym=sym_open_square - elseif(peekchar()=='%') then - c=getchar() - sym=sym_open_brace - else + case default sym=sym_open - endif + end select case(')') sym=sym_close case('+') @@ -522,6 +484,9 @@ subroutine scan(parser) if(peekchar()=='=') then c=getchar() sym=sym_ne + elseif(peekchar()=='!') then + c=getchar() + sym=sym_tilde else sym=sym_pling endif @@ -532,6 +497,9 @@ subroutine scan(parser) elseif(peekchar()==':') then c=getchar() sym=sym_bar + elseif(peekchar()==')') then + c=getchar() + sym=sym_close_square else sym=sym_divide endif @@ -540,9 +508,6 @@ subroutine scan(parser) case(':') c=getchar() sym=sym_dcolon - case('=') - c=getchar() - sym=sym_assign case default sym=sym_colon end select @@ -554,7 +519,7 @@ subroutine scan(parser) c=getchar() sym=sym_cond else - sym=sym_define + sym=sym_assign endif case('>') if(peekchar()=='=') then @@ -567,12 +532,24 @@ subroutine scan(parser) sym=sym_gt endif case('<') - if(peekchar()=='=') then - c=getchar() - sym=sym_le - elseif(peekchar()=='<') then + if(peekchar()=='<') then c=getchar() sym=sym_open_attr + elseif(peekchar2()=='--') then + c=getchar() + c=getchar() + sym=sym_move + elseif(peekchar2()=='->') then + c=getchar() + c=getchar() + sym=sym_swap + elseif(peekchar2()=='==') then + c=getchar() + c=getchar() + sym=sym_move_all + elseif(peekchar()=='=') then + c=getchar() + sym=sym_le else sym=sym_lt endif @@ -601,9 +578,6 @@ subroutine scan(parser) elseif(iachar(peekchar())>=iachar('1').and.iachar(peekchar())<=iachar('7')) then c=getchar() sym=sym_d1+iachar(c)-iachar('1') - elseif(peekchar()==')') then - c=getchar() - sym=sym_close_square else sym=sym_dot endif @@ -637,11 +611,15 @@ subroutine scan(parser) exit endif enddo outer - n=n+1 - buffer(n:n)='"' - val=pm_new_string(parser%context,buffer(1:n)) +!!$ n=n+1 +!!$ buffer(n:n)='"' + if(n==0) then + val=pm_empty_obj(pm_string) + else + val=pm_new_string(parser%context,buffer(1:n)) + endif sym=sym_string - parser%lexval=val + parser%lexval=pm_new_literal_value_type(parser%context,val) case('''') if(peekchar()=='''') then sym=sym_caret @@ -662,13 +640,13 @@ subroutine scan(parser) ! local character sets and/or keyboards ! Alternatives are available ! ********************************************* - case('[') ! Alternative (. + case('[') ! Alternative (/ sym=sym_open_square - case(']') ! Alternative .) + case(']') ! Alternative /) sym=sym_close_square - case('{') ! Alternative (% + case('{') ! Alternative (. sym=sym_open_brace - case('}') ! Alternative %) + case('}') ! Alternative .) sym=sym_close_brace case('|') ! Alternative /: sym=sym_bar @@ -676,6 +654,8 @@ subroutine scan(parser) sym=sym_at case('#') ! Alternative %: sym=sym_hash + case('~') ! Alternative -: + sym=sym_tilde case('^') ! Only used for internal system purposes if(.not.(parser%modl==parser%sysmodl)) then call parse_error(parser,'Error: Unexpected character "'//c//'"') @@ -701,7 +681,7 @@ subroutine scan(parser) parser%atstart=.false. endif parser%sym=sym - if(debug_parser_extra) then + if(debug_parser) then if(parser%sym>=0.and.parser%sym<=num_sym) then write(*,*) 'scan::',parser%sym,sym_names(parser%sym) else @@ -713,6 +693,7 @@ subroutine scan(parser) include 'fnewnc.inc' include 'ftypeno.inc' + include 'fname.inc' ! Get next character from current line and advance function getchar() result(ch) @@ -728,7 +709,7 @@ function peekchar() result(ch) ch=parser%line(parser%ls)(parser%n:parser%n) end function peekchar - ! Look at next character but one on line but do not advance + ! Look at next character but m on line but do not advance function peekchar_plus(m) result(ch) integer,intent(in)::m character(len=1):: ch @@ -912,77 +893,18 @@ subroutine numeric 'Numeric constant out of range') endif c=peekchar() - if(c=='''') then - c=getchar() - c=getchar() - select case(c) - case('s') - if(iscomplex) then - val=pm_fast_newnc(parser%context, & - pm_single_complex,1) - val%data%c(val%offset)=cmplx(0.0,rnumber) - elseif(isreal) then - val=pm_fast_newnc(parser%context, & - pm_single,1) - val%data%r(val%offset)=rnumber - else - val=pm_fast_newnc(parser%context, & - pm_int,1) - val%data%i(val%offset)=inumber - endif - case('l') - if(isreal) then - call parse_error(parser,'Long real not available') - else - val=pm_fast_newnc(parser%context, & - pm_longlong,1) - val%data%lln(val%offset)=inumber - endif - case('8') - if(isreal) goto 20 - if(isdigit(peekchar())) goto 20 - if(inumber<-127.or.inumber>127) goto 20 - val=pm_fast_newnc(parser%context, & - pm_int8,1) - val%data%i8(val%offset)=inumber - case('1') - if(isreal) goto 20 - if(peekchar()/='6'.or.isdigit(peekchar_plus(1))) goto 20 - if(inumber<-16383.or.inumber>16383) goto 20 - val=pm_fast_newnc(parser%context, & - pm_int16,1) - val%data%i16(val%offset)=inumber - c=getchar() - case('3') - if(isreal) goto 20 - if(peekchar()/='2'.or.isdigit(peekchar_plus(1))) goto 20 - if(inumber<-2147483647.or.inumber>2147483647) goto 20 - val=pm_fast_newnc(parser%context, & - pm_int32,1) - val%data%i32(val%offset)=inumber - c=getchar() - case('6') - if(isreal) goto 20 - if(peekchar()/='4'.or.isdigit(peekchar_plus(1))) goto 20 - val=pm_fast_newnc(parser%context, & - pm_int64,1) - val%data%i64(val%offset)=inumber - c=getchar() - end select + if(iscomplex) then + val=pm_fast_newnc(parser%context, & + pm_double_complex,1) + val%data%dc(val%offset)=cmplx(0.0,rnumber,kind=pm_d) + else if(isreal) then + val=pm_fast_newnc(parser%context,pm_double,1) + val%data%d(val%offset)=rnumber else - if(iscomplex) then - val=pm_fast_newnc(parser%context, & - pm_double_complex,1) - val%data%dc(val%offset)=cmplx(0.0,rnumber,kind=pm_d) - else if(isreal) then - val=pm_fast_newnc(parser%context,pm_double,1) - val%data%d(val%offset)=rnumber - else - val=pm_fast_newnc(parser%context,pm_long,1) - val%data%ln(val%offset)=inumber - endif + val=pm_fast_newnc(parser%context,pm_long,1) + val%data%ln(val%offset)=inumber endif - parser%lexval=val + parser%lexval=pm_new_literal_value_type(parser%context,val) sym=sym_number return 20 continue @@ -997,6 +919,10 @@ subroutine skip_nested_comments(cc) c=getchar() do c=getchar() + if(c==pm_eof_char) then + call parse_error(parser,'End of file encountered inside "/* ... */"') + return + endif if(c=='*') then c=getchar() if(c=='/') then @@ -1046,7 +972,6 @@ subroutine get_pos(parser,line,pos) pos=parser%n end subroutine get_pos - !====================================================== ! Next token must be specific token or error raised ! (moves past the token) @@ -1234,10 +1159,11 @@ end function check_name_no_repeat !====================================================== subroutine simple_call(parser) type(parse_state),intent(inout):: parser - call push_null_val(parser) ! keys call push_null_val(parser) ! amps + call push_null_val(parser) ! keys + call push_null_val(parser) ! key names call push_num_val(parser,0) ! flags - call make_node(parser,sym_open,5) + call make_node(parser,sym_open,6) end subroutine simple_call !====================================================== @@ -1257,94 +1183,134 @@ end function proccall !====================================================== ! Argument lists for procedure calls !====================================================== - recursive function arglist(parser,object) result(iserr) + recursive function arglist(parser,yield,dot) result(iserr) type(parse_state),intent(inout):: parser - type(pm_ptr),intent(in),optional:: object + logical,intent(in),optional:: yield + type(pm_ptr),intent(in),optional:: dot logical:: iserr - integer m,n,base,sym,flags,line,pos + integer m,n,base,sym,msym,flags,line,pos type(pm_ptr):: temp iserr=.true. call get_sym_pos(parser,line,pos) - m=0 n=0 base=parser%top - + if(parser%sym==sym_pct) then - flags=call_is_comm + flags=proccall_is_comm + call scan(parser) + elseif(parser%sym==sym_dash) then + flags=proccall_is_comm+proccall_is_general call scan(parser) + elseif(present(yield)) then + if(yield) then + flags=proccall_is_yield + else + flags=proccall_is_block + endif + elseif(present(dot)) then + flags=proccall_is_comm+proccall_is_ref+proccall_is_general else flags=0 endif - if(flags/=0) then + + call push_sym_val(parser,sym_topology) + call make_node(parser,sym_name,1) + m=1 + if(iand(flags,proccall_is_comm)/=0) then + call push_sym_val(parser,sym_outer) + call make_node(parser,sym_name,1) call push_sym_val(parser,sym_region) call make_node(parser,sym_name,1) call push_sym_val(parser,sym_subregion) call make_node(parser,sym_name,1) call push_sym_val(parser,sym_here_in_tile) call make_node(parser,sym_name,1) - m=3 + call push_sym_val(parser,sym_mask) + call make_node(parser,sym_name,1) + m=num_comm_args endif - if(present(object)) then - call push_val(parser,object) + + if(present(yield)) then + if(yield) then + call push_sym_val(parser,sym_block_inouts) + call push_sym(parser,m+1) + call make_node(parser,sym_name,1) + call push_sym_val(parser,sym_block_ins) + call make_node(parser,sym_name,1) + m=m+2 + else + call push_sym_val(parser,sym_block_proc_a) + call make_node(parser,sym_name,1) + call push_sym_val(parser,sym_block_inouts_a) + call make_node(parser,sym_name,1) + call push_sym(parser,m+2) + call push_sym_val(parser,sym_block_ins_a) + call make_node(parser,sym_name,1) + m=m+3 + endif + elseif(present(dot)) then + call push_val(parser,dot) m=m+1 + call push_sym(parser,m) endif - if(parser%sym/=sym_open) then - if(expect(parser,sym_open)) return - else - call scan(parser) - endif + + if(expect(parser,sym_open)) return + ! Call attributes but no arguments if(parser%sym==sym_open_attr) then - if(proc_call_attr(parser,.true.,flags)) return + if(call_attr(parser,.true.,flags)) return if(parser%sym/=sym_close) then if(expect(parser,sym_close)) return endif endif + + ! Call with no arguments if(parser%sym==sym_close) then - if(m==0) then - call push_null_val(parser) + call make_node(parser,sym_list,m) ! args + if(parser%top>base) then ! amps + call name_vector(parser,base) else - call make_node(parser,sym_list,m) - endif ! args - call push_null_val(parser) ! keys - call push_null_val(parser) ! amps - call push_num_val(parser,flags) ! flags - call make_node_at(parser,sym_open,5,line,pos) + call push_null_val(parser) + endif + call push_null_val(parser) ! keys + call push_null_val(parser) ! key names + call push_num_val(parser,flags) ! flags + call make_node_at(parser,sym_open,6,line,pos) call scan(parser) iserr=.false. return endif + + ! Positional argument do if(parser%sym==sym_amp) then call scan(parser) - if(parser%sym==sym_amp) then - call scan(parser) - if(valref(parser)) return - else - if(valref(parser)) return - call make_node(parser,sym_amp,1) - endif + if(valref(parser)) return m=m+1 call push_sym(parser,m) - elseif(parser%sym==sym_key) then - call make_node(parser,sym_list,m) - exit - else if(parser%sym==sym_arg) then - call scan(parser) - if(parser%sym==sym_dotdotdot) then - call push_sym_val(parser,sym_arg) - call make_node(parser,sym_arg,1) - call make_node(parser,sym_dotdotdot,m+1) - call scan(parser) - exit + else if(parser%sym==sym_dotdotdot) then + call push_sym_val(parser,sym_dotdotdot) + call make_node(parser,sym_dotdotdot,1) + call make_node(parser,sym_dotdotdot,m+1) + if(parser%top>base) then + call name_vector(parser,base) else - call push_back(parser,sym_arg) + call push_null_val(parser) endif + base=parser%top + call scan(parser) + exit else if(check_name(parser,sym)) then - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call make_node(parser,sym_list,m) - call push_name_val(parser,sym) + if(parser%top>base) then + call name_vector(parser,base) + else + call push_null_val(parser) + endif + base=parser%top + call push_sym(parser,sym) call scan(parser) if(expr(parser)) return n=1 @@ -1358,30 +1324,39 @@ recursive function arglist(parser,object) result(iserr) endif if(parser%sym/=sym_comma) then call make_node(parser,sym_list,m) + if(parser%top>base) then + call name_vector(parser,base) + else + call push_null_val(parser) + endif exit endif call scan(parser) enddo + + ! Remaining keyword arguments do while(parser%sym==sym_comma) call scan(parser) - if(parser%sym==sym_key) exit - if(expect_name(parser,& - 'optional argument name')) return - if(expect(parser,sym_define,& - 'optional argument "="')) return + if(check_name(parser,sym)) then + call push_sym(parser,sym) + else + if(expect_name(parser,& + 'keyword argument name')) return + endif + if(expect(parser,sym_assign,& + 'keyword argument "="')) return if(expr(parser)) return n=n+1 enddo - if(parser%sym==sym_key) then - call scan(parser) - if(expect(parser,sym_dotdotdot)) return - call make_node(parser,sym_dotdotdot,n*2) - else if(n>0) then - call make_node(parser,sym_list,n*2) + + ! List of keyword expressions + if(n>0) then + call make_node(parser,sym_list,n) else call push_null_val(parser) endif - + + ! Vector of keyword names if(parser%top>base) then call name_vector(parser,base) else @@ -1390,57 +1365,105 @@ recursive function arglist(parser,object) result(iserr) ! Call attributes if present if(parser%sym==sym_open_attr) then - if(proc_call_attr(parser,.true.,flags)) return + if(call_attr(parser,.true.,flags)) return endif - + call push_num_val(parser,flags) - call make_node_at(parser,sym_open,5,line,pos) + call make_node_at(parser,sym_open,6,line,pos) + if(m+n>pm_max_args) then call parse_error(parser,& - 'Too many arguments to proc call - maximum is:'//pm_maxargs_str) + 'Too many arguments to proc call - maximum is:'//trim(pm_int_as_string(pm_max_args))) endif if(expect(parser,sym_close)) return iserr=.false. end function arglist + !====================================================== + ! Procedure/call attributes !====================================================== + recursive function call_attr(parser,iscall,flags) result(iserr) + type(parse_state),intent(inout):: parser + logical,intent(in):: iscall + integer,intent(inout):: flags + logical:: iserr + integer:: m + iserr=.true. + call scan(parser) + do + select case(parser%sym) + case(sym_inline) + call set_flags(proccall_is_inline) + call scan(parser) + case(sym_no_inline) + call set_flags(proccall_is_no_inline) + call scan(parser) + case(sym_ignore_rules) + call set_flags(call_ignore_rules) + call scan(parser) + case(sym_keep_literals) !!! IS THIS TO BE USED? + call set_flags(call_is_fixed) + call scan(parser) + case(sym_pm_ref) + call set_flags(proccall_is_ref) + call scan(parser) + end select + if(parser%sym/=sym_comma) exit + call scan(parser) + enddo + if(iand(flags,proccall_is_inline+proccall_is_no_inline)==& + proccall_is_inline+proccall_is_no_inline) then + call parse_error(parser,& + 'Cannot have both "<>" and "<>" attributes together') + endif + if(expect(parser,sym_close_attr)) return + iserr=.false. + contains + subroutine set_flags(new_flags) + integer,intent(in):: new_flags + if(iand(flags,new_flags)/=0) then + call parse_error(parser,& + 'Cannot repeat attribute "'//trim(sym_names(parser%sym))//'"') + endif + flags=ior(flags,new_flags) + end subroutine set_flags + end function call_attr + + + !==================================================================== ! Qualifiers - ! .name [ ] - !====================================================== - recursive function qual(parser,dot_call) result(iserr) + ! .name .digit .{} [] .name() .{}() .() .'() .%() + ! Will immediately return true in dot_call if dot_call is present + ! and parser just encountered a .() or .'() or .%() call + ! Will return true in last_is_method if this present + ! and qualifier finishes on a .name() or .{}() method call + !==================================================================== + recursive function qual(parser,dot_call,last_is_method) result(iserr) type(parse_state),intent(inout):: parser - logical,intent(inout),optional:: dot_call + logical,intent(inout),optional:: dot_call,last_is_method logical:: iserr - integer:: sym,line,pos + integer:: sym,line,pos,n,m + logical:: finish_on_method iserr=.true. - if(parser%sym==sym_at) then + n=1 + if(parser%sym==sym_pling) then + call scan(parser) + call make_node(parser,sym_pling,0) + n=n+1 + elseif(parser%sym==sym_at) then call scan(parser) - call make_node(parser,sym_at,1) + call make_node(parser,sym_at,0) + n=n+1 endif + finish_on_method=.false. do select case(parser%sym) case(sym_dot) call get_sym_pos(parser,line,pos) call scan(parser) select case(parser%sym) - case(sym_caret) - call scan(parser) - if(parser%sym==sym_amp) then - call scan(parser) - if(expect(parser,sym_open)) return - if(expr(parser)) return - if(expect(parser,sym_close)) return - call make_node_at(parser,sym_get_dot_ref,2,line,pos) - else - if(expect(parser,sym_open)) return - if(expr(parser)) return - if(expect(parser,sym_close)) return - call make_node_at(parser,sym_get_dot,2,line,pos) - endif - case(sym_open_square) - if(subscript(parser)) return - call make_node_at(parser,sym_dot_sub,2,line,pos) - case(sym_open,sym_pct) + case(sym_open,sym_pct,sym_dash) + if(n>1) call make_node_at(parser,sym_reference,n,line,pos) call make_node_at(parser,sym_dot,1,line,pos) if(arglist(parser)) return if(present(dot_call)) then @@ -1448,55 +1471,81 @@ recursive function qual(parser,dot_call) result(iserr) iserr=.false. return endif + n=1 + case(sym_open_brace) + call scan(parser) + if(expr(parser)) return + if(expect(parser,sym_close_brace)) return + if(parser%sym==sym_open) then + call scan(parser) + if(exprlist(parser,sym=sym_pm_list)) return + if(expect(parser,sym_close)) return + call make_node_at(parser,sym_open,2,line,pos) + finish_on_method=.true. + else + call make_node_at(parser,sym_open_brace,1,line,pos) + finish_on_method=.false. + endif + n=n+1 + case(sym_caret) + call scan(parser) + if(expect_name(parser)) return + if(expect(parser,sym_open)) return + if(parser%sym==sym_close) then + call scan(parser) + call make_node_at(parser,sym_caret,1,line,pos) + else + if(exprlist(parser)) return + call make_node_at(parser,sym_caret,2,line,pos) + if(expect(parser,sym_close)) return + endif + n=n+1 case default if(expect_name(parser)) return sym=parser%sym - if(sym==sym_open.or.sym==sym_pct) then - parser%temp=parser%vstack(parser%vtop-1) - call make_node_at(parser,sym_method_call,1,line,pos) - call swap_vals(parser) - call drop_val(parser) - if(arglist(parser,parser%temp)) return - if(present(dot_call)) then - dot_call=.true. - iserr=.false. - return - endif - - ! This supports implementation of lhs calls at some point -!!$ select case(parser%sym) -!!$ case(sym_dot,sym_open_square,sym_d1:sym_d7,sym_pling,sym_at,& -!!$ sym_assign,sym_comma) -!!$ call push_val(parser,parser%temp) -!!$ call make_node(parser,sym_dot_amp,2) -!!$ case default -!!$ if(present(dot_call)) then -!!$ dot_call=.true. -!!$ iserr=.false. -!!$ return -!!$ endif -!!$ end select - + if(sym==sym_dcolon) then + call scan(parser) + if(expect_name(parser)) return + call make_node(parser,sym_proc,2) + if(expect(parser,sym_open)) return + if(exprlist(parser,sym=sym_pm_list)) return + call make_node(parser,sym_open,2) + if(expect(parser,sym_close)) return + finish_on_method=.true. + elseif(sym==sym_open) then + call make_node(parser,sym_proc,1) + call scan(parser) + if(exprlist(parser,sym=sym_pm_list)) return + call make_node(parser,sym_open,2) + if(expect(parser,sym_close)) return + finish_on_method=.true. else - call make_node_at(parser,sym_dot,2,line,pos) + call make_node_at(parser,sym_dot,1,line,pos) + finish_on_method=.false. endif + n=n+1 end select case(sym_d1:sym_d7) call get_sym_pos(parser,line,pos) call push_sym_val(parser,parser%sym) - call make_node_at(parser,sym_dot,2,line,pos) + call make_node_at(parser,sym_dot,1,line,pos) call scan(parser) + finish_on_method=.false. + n=n+1 case(sym_open_square) call get_sym_pos(parser,line,pos) + call push_sym_val(parser,sym_pm_subs) if(subscript(parser)) return - call make_node_at(parser,sym_sub,2,line,pos) -!!$ case(sym_at) -!!$ call scan(parser) -!!$ call make_node(parser,sym_at,1) + call simple_call(parser) + call make_node_at(parser,sym_sub,1,line,pos) + finish_on_method=.false. + n=n+1 case default + if(n>1) call make_node(parser,sym_reference,n) exit end select enddo + if(present(last_is_method)) last_is_method=finish_on_method iserr=.false. end function qual @@ -1624,21 +1673,13 @@ recursive function op(parser,sym,isconst,istype) result(iserr) logical:: iserr iserr=.true. select case(parser%sym) - case(first_operator:last_operator) + case(first_operator:last_operator,sym_as) sym=parser%sym call scan(parser) case(sym_open_square) call scan(parser) if(expect(parser,sym_close_square)) return sym=sym_sub - case(sym_dotdotdot) - call scan(parser) - if(expect(parser,sym_underscore)) return - sym=sym_to_range - case(sym_underscore) - call scan(parser) - if(expect(parser,sym_dotdotdot)) return - sym=sym_from_range case default if(.not.check_name(parser,sym)) then call parse_error(parser,'Malformed "proc" identifier') @@ -1652,7 +1693,7 @@ end function op ! Structure expression new name { name=.. } ! Parse node contains full_type/ list_of_expr / name / tag !========================================================== - recursive function struct_gen(parser) result(iserr) + recursive function rec_gen(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr integer:: base,vbase,i,name,line,pos,line1,pos1,tag @@ -1691,9 +1732,9 @@ recursive function struct_gen(parser) result(iserr) 'Expected name of struct or rec element') return endif - if(expect(parser,sym_define)) return + if(expect(parser,sym_assign)) return if(expr(parser)) return - call make_node_at(parser,sym_define,1,line,pos) + call make_node_at(parser,sym_assign,1,line,pos) if(parser%sym/=sym_comma) exit call scan(parser) enddo @@ -1702,10 +1743,13 @@ recursive function struct_gen(parser) result(iserr) call make_node_at(parser,sym_list,parser%vtop-vbase,line1,pos1) call name_vector(parser,base) call push_sym_val(parser,tag) - call make_node_at(parser,sym_struct,4,line1,pos1) + call make_node_at(parser,sym_rec,4,line1,pos1) iserr=.false. - end function struct_gen + end function rec_gen + !====================================================== + ! Tuple former + !====================================================== recursive function tuple(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr @@ -1723,12 +1767,32 @@ recursive function term(parser,checkqual) result(iserr) type(parse_state),intent(inout):: parser logical,intent(in):: checkqual logical:: iserr - integer:: m,name,sym,base,line,pos + integer:: i,m,name,sym,base,line,pos logical:: atstart,dot_call iserr=.true. sym=parser%sym select case(sym) - case(sym_if,sym_switch) + case(sym_if) + call scan(parser) + if(expect(parser,sym_open)) return + if(expr(parser)) return + if(expect(parser,sym_cond)) return + if(expr(parser)) return + if(expect(parser,sym_comma)) return + m=1 + do + if(expr(parser)) return + if(parser%sym/=sym_cond) exit + call scan(parser) + if(expr(parser)) return + m=m+1 + if(expect(parser,sym_comma)) return + enddo + if(expect(parser,sym_close)) return + do i=1,m + call make_node(parser,sym_if_expr,3) + enddo + case(sym_switch) call scan(parser) if(expect(parser,sym_open)) return if(expr(parser)) return @@ -1752,21 +1816,11 @@ recursive function term(parser,checkqual) result(iserr) if(expect(parser,sym_comma)) return enddo if(expect(parser,sym_close)) return - call make_node(parser,merge(sym_if_expr,sym_switch_expr,sym==sym_if),m) - case(sym_coherent,sym_mirrored,sym_shared) - call scan(parser) - if(expect(parser,sym_open)) return - if(expr(parser)) return - call push_sym_val(parser,sym) - if(parser%sym==sym_open_attr) then - call scan(parser) - if(expect(parser,sym_always)) return - if(expect(parser,sym_close_attr)) return - call make_node(parser,sym_always,2) - else - call make_node(parser,sym_mode,2) - endif - if(expect(parser,sym_close)) return + call make_node(parser,sym_switch_expr,m) + case(sym_yield) + if(yield(parser,.true.)) return + case(sym_pm_yield) + if(yield(parser,.false.)) return case(sym_open) call scan(parser) if(expr(parser)) return @@ -1795,35 +1849,37 @@ recursive function term(parser,checkqual) result(iserr) if(tuple(parser)) return case(sym_open_brace) if(array_former(parser,sym_close_brace)) return - case(sym_new) - if(struct_gen(parser)) return + case(sym_rec) + if(rec_gen(parser)) return case(sym_present) call scan(parser) + if(expect(parser,sym_open)) return if(expect_name(parser)) return call make_node(parser,sym_present,1) + if(expect(parser,sym_close)) return case(sym_number,sym_string) - call push_val(parser,parser%lexval) + call push_num_val(parser,parser%lexval) call make_node(parser,sym,1) call scan(parser) case(sym_dollar) call scan(parser) if(op(parser,name,.true.,.false.)) return call push_sym_val(parser,name) - if(parser%sym==sym_dash.and.name>num_sym) then + if(parser%sym==sym_dcolon.and.name>num_sym) then call scan(parser) if(expect_name(parser)) return call make_node(parser,sym_proc,2) else call make_node(parser,sym_proc,1) endif - if(parser%sym==sym_open.or.parser%sym==sym_pct) then + if(parser%sym==sym_open.or.parser%sym==sym_pct.or.parser%sym==sym_dash) then if(arglist(parser)) return endif case(sym_param) call scan(parser) if(expect(parser,sym_open_brace)) return if(expect_name(parser)) return - if(parser%sym==sym_dash) then + if(parser%sym==sym_dcolon) then call scan(parser) if(expect_name(parser)) return call make_node(parser,sym_param,2) @@ -1836,39 +1892,29 @@ recursive function term(parser,checkqual) result(iserr) if(typ(parser)) return if(expect(parser,sym_gt)) return call make_node(parser,sym_type_val,1) - case(sym_dash) + case(sym_pm_list) call scan(parser) - if(parser%sym==sym_number) then - if(pm_fast_vkind(parser%lexval)/=pm_long) then - call parse_error(parser,& - '"''" cannot precede non-default integer constant') - endif - call push_val(parser,parser%lexval) + if(expect(parser,sym_open)) return + if(parser%sym==sym_close) then call scan(parser) - call make_node(parser,sym_dash,1) - elseif(parser%sym==sym_true.or.& - parser%sym==sym_false) then - call push_sym_val(parser,parser%sym) - call scan(parser) - call make_node(parser,sym_dash,1) - elseif(parser%sym==sym_open) then - call scan(parser) - if(expr(parser)) return + m=0 + else + if(exprlist(parser,m,nolist=.true.)) return if(expect(parser,sym_close)) return - call make_node(parser,sym_fix,1) - elseif(parser%sym==sym_open_square) then + endif + call make_node(parser,sym_pm_list,m) + case(sym_fix,sym_literal) + call scan(parser) + if(parser%sym==sym_open_square) then call push_sym_val(parser,sym_tuple) if(subscript(parser)) return call simple_call(parser) - call make_node(parser,sym_fix,1) - elseif(parser%sym>num_sym) then - call push_sym_val(parser,parser%sym) - call scan(parser) - call make_node(parser,sym_name,1) - call make_node(parser,sym_fix,1) + call make_node(parser,sym,1) else - call parse_error(parser,'"''" must be followed by constant value') - return + if(expect(parser,sym_open)) return + if(expr(parser)) return + if(expect(parser,sym_close)) return + call make_node(parser,sym,1) endif case(sym_null) if(parser%sym==sym_open) then @@ -1878,10 +1924,11 @@ recursive function term(parser,checkqual) result(iserr) call make_node(parser,sym,0) call scan(parser) endif - case(sym_true,sym_false) + case(sym_true,sym_false,sym_underscore) call make_node(parser,sym,0) call scan(parser) goto 20 + ! ** These are for internal use by the compiler only ** case(sym_caret) call scan(parser) @@ -1952,30 +1999,48 @@ recursive function term(parser,checkqual) result(iserr) if(expr(parser)) return if(expect(parser,sym_close)) return call make_node(parser,sym_dcaret,1) - case(sym_pm_dref:sym_pm_ref) + case(sym_pm_ref) call scan(parser) - if(expect(parser,sym_open)) return + if(parser%sym==sym_open) then + call push_sym_val(parser,0) + else + if(expect_name(parser)) return + if(expect(parser,sym_open)) return + endif if(exprlist(parser,m,nolist=.true.)) return if(expect(parser,sym_close)) return - if(m/=3.and.m/=5) then - call parse_error(parser,'Wrong number of args to: '//sym_names(sym)) - return - endif - call make_node(parser,sym,m) + call make_node(parser,sym,m+1) + case(sym_pm_each_index) + call scan(parser) + if(expect(parser,sym_open)) return + if(expect_name(parser)) return + if(expect(parser,sym_in)) return + if(expr(parser)) return + if(expect(parser,sym_colon)) return + if(expr(parser)) return + if(expect(parser,sym_close)) return + call make_node(parser,sym_pm_each_index,3) case default if(check_name_pos(parser,name,line,pos)) then select case(parser%sym) - case(sym_open,sym_pct) + case(sym_open,sym_pct,sym_dash) if(proccall(parser,name)) return - case(sym_dash) + case(sym_dcolon) call scan(parser) call push_name_val_at(parser,name,line,pos) if(expect_name(parser)) return call make_node(parser,sym_use,2) if(parser%sym==sym_open.or.& - parser%sym==sym_pct) then + parser%sym==sym_pct.or.parser%sym==sym_dash) then if(arglist(parser)) return endif + case(sym_dot,sym_open_square,sym_d1:sym_d7,sym_at) + call push_name_val_at(parser,name,line,pos) + call make_node(parser,sym_name,1) + dot_call=.false. + if(qual(parser,dot_call)) return + iserr=.false. + return case default call push_name_val_at(parser,name,line,pos) call make_node(parser,sym_name,1) @@ -1996,6 +2061,27 @@ recursive function term(parser,checkqual) result(iserr) include 'fvkind.inc' end function term + ! ========================================= + ! Yield statement or expression + ! ========================================= + recursive function yield(parser,isyield) result(iserr) + type(parse_state),intent(inout):: parser + logical,intent(in):: isyield + logical:: iserr + iserr=.true. + call scan(parser) + call push_name_val(parser,sym_block_proc) + call make_node(parser,sym_name,1) + call make_node(parser,sym_dot,1) + call push_back(parser,sym_dash) + if(isyield) then + if(arglist(parser,yield=.true.)) return + else + if(arglist(parser)) return + endif + iserr=.false. + end function yield + !====================================================== ! Expression @@ -2003,7 +2089,10 @@ end function term recursive function expr(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr - iserr=expr1(parser,100) + integer:: n + iserr=.true. + if(expr1(parser,100)) return + iserr=.false. end function expr recursive function expr1(parser,priority) result(iserr) @@ -2014,12 +2103,12 @@ recursive function expr1(parser,priority) result(iserr) integer,parameter:: priority_uhash=1 ! # (unary) integer,parameter:: priority_pow=2 ! ** integer,parameter:: priority_mult=3 ! * / - integer,parameter:: priority_uminus=4 ! - (unary) ! + integer,parameter:: priority_uminus=4 ! - (unary) ~ integer,parameter:: priority_hash=5 ! # integer,parameter:: priority_as=6 ! as integer,parameter:: priority_bitshift=7 ! shift integer,parameter:: priority_bitand=8 ! & - integer,parameter:: priority_bitxor=9 ! xor + integer,parameter:: priority_bitxor=9 ! ~ integer,parameter:: priority_bitor=10 ! | integer,parameter:: priority_mod=11 ! mod integer,parameter:: priority_add=12 ! + - @@ -2046,8 +2135,8 @@ recursive function expr1(parser,priority) result(iserr) if(unary(priority_uminus,sym_plus)) return case(sym_mult) if(unary(priority_uminus,sym_ustar)) return - case(sym_pling) - if(unary(priority_uminus,sym_pling)) return + case(sym_tilde) + if(unary(priority_uminus,sym_tilde)) return case(sym_hash) if(unary(priority_uhash,sym_uhash)) return case(sym_not) @@ -2056,9 +2145,6 @@ recursive function expr1(parser,priority) result(iserr) if(unary(priority_by,sym_by)) return case(sym_ortho) if(unary(priority_ortho,sym_ortho)) return - case(sym_dotdotdot) - parser%sym=sym_to_range - if(unary(priority_dotdot,sym_to_range)) return case default if(term(parser,.true.)) return end select @@ -2082,10 +2168,10 @@ recursive function expr1(parser,priority) result(iserr) if(binary(priority_and)) return case(sym_eq,sym_ne) if(binary_none(priority_eq)) return - case(sym_gt,sym_ge,sym_lt,sym_le,sym_in,& - sym_includes,sym_is) + case(sym_gt,sym_ge,sym_lt,sym_le,sym_in,sym_not_in,& + sym_includes,sym_not_includes,sym_is) if(binary_none(priority_gt)) return - case(sym_mod) + case(sym_mod,sym_div) if(binary(priority_mod)) return case(sym_plus,sym_minus) if(binary(priority_add)) return @@ -2097,7 +2183,7 @@ recursive function expr1(parser,priority) result(iserr) if(binary(priority_bitor)) return case(sym_amp) if(binary(priority_bitand)) return - case(sym_xor) + case(sym_tilde) if(binary(priority_bitxor)) return case(sym_shift) if(binary(priority_bitshift)) return @@ -2107,12 +2193,6 @@ recursive function expr1(parser,priority) result(iserr) if(binary_none(priority_as)) return case(sym_ortho) if(binary_none(priority_ortho)) return - case(sym_dotdotdot) - if(priority7) then + if(n>8) then call parse_error(parser,'Cannot have more than seven dimensions in tuple or subscript') endif call make_node(parser,sym,n) @@ -2250,20 +2337,22 @@ end function sexpr end function subscript - !====================================================== - ! Assignment/definition: lhs, lhs... [ ":=" | "=" ] rhs - ! or call with no return values - !====================================================== - recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr) + !============================================================= + ! Left hand side of an assignment or zero return call + ! { ( name [ qual ] [op] | _ ) ,} + ! Returns number of elements, number of underscores + ! is_call if just a call + ! cannot_be_move if operators present + !============================================================== + function lhs(parser,n,nu,is_call,cannot_be_move,last_is_method) result(iserr) type(parse_state),intent(inout):: parser - logical,intent(in):: call_ok,assign_ok,define_ok + integer,intent(out):: n,nu + logical,intent(inout),optional:: is_call,cannot_be_move,last_is_method logical:: iserr - integer:: n,nu,name - logical:: dotcall,must_be_assignment + logical:: dotcall iserr=.true. n=0 nu=0 - must_be_assignment=.false. ! ( name [ qual ] | _ )* do @@ -2272,12 +2361,20 @@ recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr call scan(parser) nu=nu+1 n=n+1 + if(parser%sym/=sym_comma) exit + call scan(parser) + cycle else - if(expect_name(parser)) return n=n+1 + if(expect_name(parser)) return select case(parser%sym) - case(sym_open,sym_pct) - if(n>1.or.nu>0.or..not.call_ok) then + case(sym_open,sym_pct,sym_dcolon,sym_dash) + if(parser%sym==sym_dcolon) then + call scan(parser) + if(expect_name(parser)) return + call make_node(parser,sym_use,2) + endif + if(n>1.or.nu>0.or..not.present(is_call)) then call parse_error(parser,& 'Unexpected symbol in what seems to be a left hand side expression') return @@ -2288,20 +2385,21 @@ recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr call parse_error(parser,'Cannot follow a call with a comma') return endif + is_call=.true. iserr=.false. return - case(sym_dot,sym_d1:sym_d7,sym_open_square,sym_at) - must_be_assignment=.true. + case(sym_dot,sym_d1:sym_d7,sym_open_square,sym_at,sym_pling) dotcall=.false. call make_node(parser,sym_name,1) - if(qual(parser,dotcall)) return + if(qual(parser,dotcall,last_is_method)) return if(dotcall) then - if(n==1.and.call_ok) then + if(n==1.and.present(is_call)) then call make_node(parser,sym_do,1) if(parser%sym==sym_comma) then call parse_error(parser,'Cannot follow a call with a comma') return endif + is_call=.true. iserr=.false. return else @@ -2310,35 +2408,80 @@ recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr return endif endif - end select - select case(parser%sym) - case(sym_plus,sym_minus,sym_mult,sym_and,sym_or,sym_amp,sym_bar,sym_xor,sym_concat) - call push_sym_val(parser,parser%sym) - call make_node(parser,sym_proc,1) - call make_node(parser,sym_lt,2) - call scan(parser) - must_be_assignment=.true. - case(sym_open_brace) - call scan(parser) - if(expr(parser)) return - if(expect(parser,sym_close_brace)) return - call make_node(parser,sym_lt,2) - must_be_assignment=.true. + case default + call make_node(parser,sym_name,1) end select endif + + select case(parser%sym) + case(sym_plus,sym_minus,sym_mult,sym_and,sym_or,sym_amp,sym_bar,sym_tilde,sym_concat) + call push_sym_val(parser,parser%sym) + call make_node(parser,sym_proc,1) + call make_node(parser,sym_open_brace,2) + call scan(parser) + if(present(cannot_be_move)) cannot_be_move=.true. + case(sym_open_brace) + call scan(parser) + if(expr(parser)) return + if(expect(parser,sym_close_brace)) return + call make_node(parser,sym_open_brace,2) + if(present(cannot_be_move)) cannot_be_move=.true. + end select if(parser%sym/=sym_comma) exit call scan(parser) + if(parser%sym/=sym_underscore.and.parser%sym<=num_sym) then + call push_back(parser,sym_comma) + exit + endif enddo + iserr=.false. + end function lhs - call make_node(parser,sym_define,n) - if(expect(parser,sym_define)) return - - if(must_be_assignment.and..not.assign_ok) then - call parse_error(parser,'Cannot have an assignment in this context') + !====================================================== + ! Assignment/definition: lhs, lhs... "=" rhs + ! or call with no return values + !====================================================== + recursive function assn_or_call(parser,call_ok,assign_ok,define_ok) result(iserr) + type(parse_state),intent(inout):: parser + logical,intent(in):: call_ok,assign_ok,define_ok + logical:: iserr + integer:: n,nu,name,sym + logical:: dotcall,cannot_be_move,last_is_method + iserr=.true. + + dotcall=.false. + cannot_be_move=.false. + last_is_method=.false. + if(lhs(parser,n,nu,dotcall,cannot_be_move,last_is_method)) return + + if(dotcall) then + iserr=.false. + return endif - if(rhs(parser,n)) return - call make_node(parser,sym_define,2) + sym=parser%sym + if(sym==sym_move.or.sym==sym_move_all.or.sym==sym_swap) then + if(n/=1) then + call parse_error(parser,'Cannot have multiple left hand sides before "'//& + trim(sym_names(sym))//'"') + elseif(nu>0) then + call parse_error(parser,'Cannot have "_" as the left hand side of "'//& + trim(sym_names(sym))//'"') + elseif(cannot_be_move) then + call parse_error(parser,'Cannot have operators before "'//& + trim(sym_names(sym))//'"') + endif + call scan(parser) + if(valref(parser)) return + call make_node(parser,sym,2) + elseif(parser%sym==sym_assign.or.n>1.or..not.last_is_method) then + call make_node(parser,sym_assign,n) + if(expect(parser,sym_assign)) return + if(rhs(parser,n)) return + call make_node(parser,sym_assign,2) + else + call make_node(parser,sym_do,1) + endif iserr=.false. end function assn_or_call @@ -2352,25 +2495,29 @@ recursive function rhs(parser,n) result(iserr) integer:: name logical:: dotcall iserr=.true. - - if(n==1) then + + if(parser%sym==sym_do) then + if(do_stmt(parser)) return + elseif(parser%sym==sym_yield) then + if(yield(parser,.true.)) return + elseif(parser%sym==sym_pm_yield) then + if(yield(parser,.false.)) return + elseif(n==1) then if(expr(parser)) return else if(check_name(parser,name)) then - if(parser%sym==sym_open.or.parser%sym==sym_pct) then + if(parser%sym==sym_open.or.parser%sym==sym_pct.or.parser%sym==sym_dash) then if(proccall(parser,name)) return else call push_name_val(parser,name) call make_node(parser,sym_name,1) dotcall=.false. if(qual(parser,dotcall)) return - if(.not.dotcall) then - call make_node(parser,sym_define,1) - endif + call make_node(parser,sym_assign,1) endif - elseif(parser%sym==sym_number.or.parser%sym==sym_string.or.parser%sym==sym_dash) then + elseif(parser%sym==sym_number.or.parser%sym==sym_string.or.parser%sym==sym_dcolon) then if(term(parser,.false.)) return - call make_node(parser,sym_define,1) + call make_node(parser,sym_assign,1) else call parse_error(parser,& 'Expected procedure call, name or constant after multiple left-hand sides') @@ -2386,22 +2533,14 @@ recursive function valref(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr iserr=.true. - if(parser%sym==sym_caret) then + if(expect_name(parser)) return + if(parser%sym==sym_dcolon) then call scan(parser) - if(expect(parser,sym_open)) return - if(expr(parser)) return - if(expect(parser,sym_close)) return - call make_node(parser,sym_caret,1) - else if(expect_name(parser)) return - if(parser%sym==sym_dash) then - call scan(parser) - if(expect_name(parser)) return - call make_node(parser,sym_use,2) - else - call make_node(parser,sym_name,1) - end if - endif + call make_node(parser,sym_use,2) + else + call make_node(parser,sym_name,1) + end if if(qual(parser)) return iserr=.false. end function valref @@ -2450,6 +2589,22 @@ function subexpr(parser) result(iserr) enddo call make_node(parser,sym_check,n) endif + if(parser%sym==sym_split) then + call scan(parser) + m=0 + do + if(expect_name(parser)) return + if(expect(parser,sym_assign)) return + if(valref(parser)) return + m=m+2 + if(parser%sym==sym_comma) then + call scan(parser) + else + exit + endif + enddo + call make_node(parser,sym_split,m+1) + end if do while(parser%sym==sym_where) call scan(parser) m=0 @@ -2466,11 +2621,10 @@ function subexpr(parser) result(iserr) if(parser%sym/=sym_comma) exit call scan(parser) enddo - if(expect(parser,sym_define)) return - call push_null_val(parser) - call make_node(parser,sym_const,n+1) + if(expect(parser,sym_assign)) return + call make_node(parser,sym_where,n) if(rhs(parser,n)) return - call make_node(parser,sym_define,2) + call make_node(parser,sym_assign,2) m=m+1 if(parser%sym/=sym_comma) exit call scan(parser) @@ -2494,11 +2648,12 @@ end subroutine xexpr !====================================================== ! Extended expression list ( expr, expr... subexpr) !====================================================== - subroutine xexprlist(parser,length) + subroutine xexprlist(parser,length,sym) type(parse_state),intent(inout):: parser integer,intent(out),optional:: length + integer,intent(in),optional:: sym integer:: m - if(exprlist(parser,m)) return + if(exprlist(parser,m,sym=sym)) return if(present(length)) length=m if(subexpr(parser)) return contains @@ -2508,13 +2663,12 @@ end subroutine xexprlist !====================================================== ! While statement !====================================================== - recursive function while_stmt(parser,name) result(is_err) + recursive function while_stmt(parser) result(is_err) type(parse_state),intent(inout):: parser - integer,intent(in):: name logical:: is_err - integer:: line,sym + integer:: line,pos,sym is_err=.true. - line=get_sym_line(parser) + call get_sym_pos(parser,line,pos) sym=sym_while call scan(parser) if(parser%sym==sym_invar) then @@ -2522,21 +2676,20 @@ recursive function while_stmt(parser,name) result(is_err) call scan(parser) endif call xexpr(parser) - if(block_or_single_stmt(parser,name,sym,line)) return - call make_node(parser,sym,3) + if(block_or_single_stmt(parser,sym_while,0,line)) return + call make_node_at(parser,sym,2,line,pos) is_err=.false. end function while_stmt !====================================================== ! Until statement !====================================================== - recursive function until_stmt(parser,name) result(is_err) + recursive function until_stmt(parser) result(is_err) type(parse_state),intent(inout):: parser - integer,intent(in):: name logical:: is_err - integer:: line,sym + integer:: line,pos,sym is_err=.true. - line=get_sym_line(parser) + call get_sym_pos(parser,line,pos) sym=sym_until call scan(parser) if(parser%sym==sym_invar) then @@ -2544,38 +2697,98 @@ recursive function until_stmt(parser,name) result(is_err) call scan(parser) endif call xexpr(parser) - if(block_or_single_stmt(parser,name,sym,line)) return - call make_node(parser,sym,3) + if(block_or_single_stmt(parser,sym_until,0,line)) return + call make_node_at(parser,sym,2,line,pos) is_err=.false. end function until_stmt - !====================================================== ! do statement - ! do after statement - ! do until statement !====================================================== - recursive function do_stmt(parser,name) result(is_err) + recursive function do_stmt(parser) result(is_err) type(parse_state),intent(inout):: parser - integer,intent(in):: name logical:: is_err - integer:: line,sym + integer:: line,pos,sym,lsym,n,base is_err=.true. - line=get_sym_line(parser) + call get_sym_pos(parser,line,pos) call scan(parser) - if(block_or_single_stmt(parser,sym_do,name,line)) return - if(parser%sym==sym_after) then - if(name/=0) call parse_error(parser,'Cannot label a "do after" statement') - call scan(parser) + if(parser%sym==sym_colon.or.parser%sym==sym_open_brace) then if(block_or_single_stmt(parser,sym_do,0,line)) return - call make_node(parser,sym_after,2) - elseif(name==0) then - call make_node(parser,sym_do_stmt,1) + call make_node_at(parser,sym_do_stmt,1,line,pos) else - call make_node(parser,sym_true,0) - call swap_vals(parser) - call make_node(parser,sym_until,3) - endif + base=parser%top + lsym=sym_list + call push_sym(parser,7) + if(parser%sym==sym_amp) then + call scan(parser) + if(expect_name(parser)) return + call push_sym(parser,9) + elseif(parser%sym==sym_dotdotdot) then + call push_sym_val(parser,sym_dotdotdot) + lsym=sym_dotdotdot + else + if(expect_name(parser)) return + endif + if(parser%sym==sym_comma.or.parser%sym==sym_assign) then + n=1 + do while(parser%sym==sym_comma) + if(lsym==sym_dotdotdot) then + call parse_error(parser,'"," not expected after "..."') + endif + call scan(parser) + n=n+1 + if(parser%sym==sym_amp) then + call scan(parser) + if(expect_name(parser)) return + call push_sym(parser,n+8) + elseif(parser%sym==sym_dotdotdot) then + call push_sym_val(parser,sym_dotdotdot) + call scan(parser) + lsym=sym_dotdotdot + else + if(expect_name(parser)) return + endif + enddo + call make_node(parser,lsym,n) + if(parser%top>base) then + call name_vector(parser,base) + else + call push_null_val(parser) + endif + if(expect(parser,sym_assign)) return + if(expect_name(parser)) return + elseif(lsym==sym_dotdotdot.or.parser%top>base) then + if(expect(parser,sym_assign)) return + else + call make_node(parser,sym_list,0) + call push_null_val(parser) + endif + if(arglist(parser,yield=.false.)) return + if(parser%sym==sym_colon) then + call scan(parser) + if(parser%sym==sym_return) then + call scan(parser) + call push_null_val(parser) + call xexprlist(parser) + else + call stmt_list(parser,single=.true.) + call push_null_val(parser) + endif + else + if(expect(parser,sym_open_brace)) return + call stmt_list(parser) + if(parser%sym==sym_return) then + call scan(parser) + call xexprlist(parser) + else + call push_null_val(parser) + endif + if(close_block(parser,sym_do,0,line)) return + endif + call push_null_val(parser) + if(subexpr(parser)) return + call make_node_at(parser,sym_do_stmt,6,line,pos) + end if is_err=.false. end function do_stmt @@ -2596,21 +2809,21 @@ recursive function for_each_stmt(parser,name) result(is_err) call scan(parser) endif if(iter(parser,.false.,var_name)) return - if(subexpr(parser)) return if(parser%sym==sym_while) then call scan(parser) - call xexpr(parser) + if(expr(parser)) return call make_node(parser,sym_while,1) elseif(parser%sym==sym_until) then call scan(parser) - call xexpr(parser) + if(expr(parser)) return call make_node(parser,sym_until,1) else call push_null_val(parser) endif + call push_null_val(parser) + if(subexpr(parser)) return if(block_or_single_stmt(parser,name,var_name,line)) return - call push_sym_val(parser,name) ! Make for-each node: iter while-until block label call make_node(parser,sym,4) is_err=.false. @@ -2656,81 +2869,111 @@ recursive function if_stmt(parser) result(iserr) end function if_stmt !============================================================== - ! (var | const) { name | _ | exception) } [ : type ] [ = expr ] + ! { (var | let | assign ) { name | _ } [ : type ] , } [ = expr ] !============================================================== - recursive function var_stmt(parser,moded_stmt) result(iserr) + recursive function var_stmt(parser) result(iserr) type(parse_state),intent(inout):: parser - integer,intent(in),optional:: moded_stmt logical:: iserr - integer:: n,nu,ne,sym,symi - logical:: dotcall + integer:: n,nu,ntot,m,vsym,mode + logical:: dotcall,has_dotdotdot iserr=.true. - sym=parser%sym - call scan(parser) - n=0 - nu=0 - ne=0 + mode=0 + m=0 + ntot=0 do - if(parser%sym==sym_underscore) then + select case(parser%sym) + case(sym_var,sym_const) + vsym=parser%sym call scan(parser) - call make_node(parser,sym_underscore,0) - nu=nu+1 - else - if(expect_name(parser)) return - endif - n=n+1 - if(parser%sym==sym_comma) then + case(sym_invar,sym_nhd,sym_chan,sym_shared) + mode=parser%sym call scan(parser) - else - exit - endif - enddo - if(parser%sym==sym_colon) then - call scan(parser) - if(typ(parser)) return - else - call push_null_val(parser) - endif - call make_node(parser,sym,n+1) - if(ne==n) then - call parse_error(parser,'A "'//trim(sym_names(sym))//'" statement must define at least one object') - endif - if(parser%sym==sym_define) then - call scan(parser) - if(rhs(parser,n)) return - call make_node(parser,sym_define,2) - if(subexpr(parser)) return - elseif(present(moded_stmt).or..true.) then - call parse_error(parser,'Must include an initialising expression in a "'//& - sym_names(sym)//' statement') - elseif(nu+ne>0) then - call parse_error(parser,'Cannot have "_" or "(...)" in unitialised '//& - trim(sym_names(sym))//' declaration') - endif - iserr=.false. - end function var_stmt + if(expect(parser,sym_var)) return + vsym=sym_var + case(sym_assignment) + call scan(parser) + if(lhs(parser,n,nu)) return + call make_node(parser,sym_assign,n) + goto 10 + case default + call parse_error(parser,'Expected "var", "let" or "assign"') + return + end select + n=0 + nu=0 + has_dotdotdot=.false. + do + if(parser%sym==sym_underscore) then + call scan(parser) + call make_node(parser,sym_underscore,0) + nu=nu+1 + elseif(parser%sym==sym_dotdotdot) then + call scan(parser) + if(expect_name(parser)) return + call make_node(parser,sym_dotdotdot,1) + has_dotdotdot=.true. + else + if(expect_name(parser)) return + endif + n=n+1 + if(parser%sym==sym_comma) then + call scan(parser) + if(parser%sym/=sym_underscore.and.parser%sym<=num_sym) then + call push_back(parser,sym_comma) + exit + endif + else + exit + endif + enddo + if(mode/=0) then + call push_sym_val(parser,mode) + else + call push_null_val(parser) + endif + if(parser%sym==sym_colon) then + if(has_dotdotdot) then + call parse_error(parser,& + 'Cannot give a new type to an object being initialised with "..."') + endif + call scan(parser) + if(typ(parser)) return + else + call push_null_val(parser) + endif + call make_node(parser,vsym,n+2) + if(nu==n.and.vsym/=sym_assignment) then + call parse_error(parser,& + 'A "'//trim(sym_names(vsym))//& + '" clause must define at least one object') + endif +10 continue + m=m+1 + ntot=ntot+n + if(parser%sym/=sym_comma) exit + call scan(parser) + enddo + if(m>1) call make_node(parser,sym_assign_list,m) - !============================================================== - ! ( coherent | mirrored | shared ) [ var | const ] name = expr - ! ( coherent | shared) call - !============================================================== - recursive function mode_stmt(parser,sym) result(iserr) - type(parse_state),intent(inout):: parser - integer,intent(in):: sym - logical:: iserr - iserr=.true. - if(parser%sym==sym_var.or.parser%sym==sym_const) then - if(var_stmt(parser,moded_stmt=sym)) return - else - if(assn_or_call(parser,& - sym==sym_coherent.or.sym==sym_shared,.false.,.true.)) return + if(parser%sym/=sym_dotdotdot) then + if(expect(parser,sym_assign)) return + if(rhs(parser,ntot)) return + call make_node(parser,sym_assign,2) if(subexpr(parser)) return + else + if(m>1) then + call parse_error(parser,'Cannot have multiple left hand side elements before "..."') + elseif(mode/=0) then + call parse_error(parser,'"'//trim(sym_names(mode))//' var" must have an initialiser') + elseif(nu>0) then + call parse_error(parser,'Cannot have "_" in unitialised "'//& + trim(sym_names(vsym))//'" declaration') + endif + call scan(parser) endif - call make_node(parser,sym_list,1) - call push_sym_val(parser,sym) - call make_node(parser,sym_mode,2) iserr=.false. - end function mode_stmt + end function var_stmt + !========================================================== ! switch [ xexpr ] { case xexprlist : statement_list ... } @@ -2757,7 +3000,7 @@ recursive function switch_stmt(parser) result(iserr) n=0 do while(parser%sym==sym_case) call scan(parser) - call xexprlist(parser) + call xexprlist(parser,sym=sym_case) if(expect(parser,sym_colon)) return call stmt_list(parser) n=n+2 @@ -2795,7 +3038,7 @@ recursive function any_stmt(parser) result(iserr) endif if(expect_and_get_name(parser,name)) return call make_node(parser,sym_name,1) - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call scan(parser) call xexpr(parser) else @@ -2855,16 +3098,16 @@ recursive function for_stmt(parser) result(iserr) else call push_null_val(parser) endif - call swap_vals(parser) + call push_null_val(parser) if(subexpr(parser)) return - call push_sym_val(parser,sym) - if(block_or_single_stmt(parser,sym_for,name,line)) return - call make_node(parser,sym_for,4) + if(block_or_single_stmt(parser,sym,name,line)) return + ! attr iter block + call make_node(parser,sym,4) iserr=.false. end function for_stmt !==================================================================================== - ! par [ << attrs >> ] { statements ( do name [ << attrs >> ] : statements ...) } + ! par [ << attrs >> ] { statements ( task name [ << attrs >> ] : statements ...) } !==================================================================================== recursive function par_stmt(parser) result(is_error) type(parse_state),intent(inout):: parser @@ -2882,17 +3125,20 @@ recursive function par_stmt(parser) result(is_error) else call push_null_val(parser) endif + call push_null_val(parser) + if(subexpr(parser)) return if(expect(parser,sym_open_brace)) return call stmt_list(parser) - k=2 + k=3 n=0 if(expect(parser,sym_task)) return do if(expect_name(parser)) return + call make_node(parser,sym_name,1) if(parser%sym==sym_open_attr) then call scan(parser) if(expect(parser,sym_work)) return - if(expect(parser,sym_define)) return + if(expect(parser,sym_assign)) return call xexpr(parser) if(expect(parser,sym_close_attr)) return has_work=.true. @@ -2908,7 +3154,7 @@ recursive function par_stmt(parser) result(is_error) enddo if(close_block(parser,sym_par,0,line)) return if(has_work) then - do i=base+4,base+k,3 + do i=base+5,base+k,3 call push_val(parser,parser%vstack(i)) enddo call make_node(parser,sym_list,n) @@ -2946,11 +3192,14 @@ recursive function par_stmt(parser) result(is_error) endif call push_val(parser,parser%vstack(base+1)) call push_val(parser,parser%vstack(base+2)) - do i=3,k,3 + call push_val(parser,parser%vstack(base+3)) + do i=4,k,3 call push_val(parser,parser%vstack(base+i)) call push_val(parser,parser%vstack(base+i+2)) enddo - call make_node(parser,sym_par,2+n*2) + call make_node(parser,sym_task,n*2+1) + call make_node(parser,sym_list,1) + call make_node(parser,sym_par,3) k=parser%vtop parser%vtop=base+1 parser%vstack(parser%vtop)=parser%vstack(k) @@ -2969,15 +3218,18 @@ recursive function iter(parser,star_ok,first_name) result(iserr) integer,intent(out),optional:: first_name logical:: iserr integer:: i,m,name - logical:: star + logical:: star,amp iserr=.true. m=0 do - if(parser%sym==sym_mult) then + star=.false. + amp=.false. + if(parser%sym==sym_mult.and.star_ok) then call scan(parser) star=.true. - else - star=.false. + elseif(parser%sym==sym_amp) then + call scan(parser) + amp=.true. endif if(check_name(parser,name)) then call push_name_val(parser,name) @@ -2985,6 +3237,8 @@ recursive function iter(parser,star_ok,first_name) result(iserr) if(expect(parser,sym_in)) return if(star) then call make_node(parser,sym_mult,1) + elseif(amp) then + call make_node(parser,sym_amp,1) endif if(expr(parser)) return m=m+1 @@ -3006,9 +3260,8 @@ recursive function par_attr(parser,start,finish,sym) result(iserr) integer,intent(in):: start,finish integer,intent(inout),optional:: sym logical:: iserr - integer:: n,i,base,vbase,vbase2,name,high + integer:: i,base,vbase,name,high iserr=.true. - n=0 base=parser%top vbase=parser%vtop high=max(sym_block,finish) @@ -3017,41 +3270,17 @@ recursive function par_attr(parser,start,finish,sym) result(iserr) do while(parser%sym>num_sym) call push_sym(parser,parser%sym) call scan(parser) - if(expect(parser,sym_define)) return + if(expect(parser,sym_assign)) return if(expr(parser)) return - n=n+1 if(parser%sym/=sym_comma) exit call scan(parser) enddo if(expect(parser,sym_close_attr)) return enddo - if(parser%error_count==0.and.(n>0.or.start==sym_block)) then - vbase2=parser%vtop - do i=start,high - call make_node(parser,sym_null,0) - enddo - do i=1,n - name=parser%stack(base+i) - if(name>=start.and.& - name<=finish) then - name=name-start+1 - if(node_sym(parser%vstack(vbase+i))/=sym_null) then - parser%vstack(vbase2+name)=parser%vstack(vbase+i) - else - call parse_error(parser,'Repeated "<<'//& - trim(pm_name_as_string(parser%context,& - name+start-1))//'>>" attribute') - endif - else - call parse_error(parser,'Not an allowed attribute: "<<'//& - trim(pm_name_as_string(parser%context,& - name))//'=>>"') - endif - enddo - call make_node(parser,sym_list,high-start+1) - parser%top=base - parser%vstack(vbase+1)=top_val(parser) - parser%vtop=vbase+1 + if(parser%vtop>vbase) then + call make_node(parser,sym_list,parser%vtop-vbase) + call name_vector(parser,base) + call make_node(parser,sym_open_attr,2) else call push_null_val(parser) endif @@ -3060,90 +3289,6 @@ recursive function par_attr(parser,start,finish,sym) result(iserr) include 'fisnull.inc' end function par_attr - !====================================================================== - ! nhd {tuple {name of expr}} [bounds expr] [attr] [subexpr] block - !====================================================================== - function nhd_stmt(parser) result(iserr) - type(parse_state),intent(inout):: parser - logical:: iserr - integer:: n,m,line,line2,var_name,list_sym - iserr=.true. - line=get_sym_line(parser) - call scan(parser) - m=0 - outer: do - if(parser%sym==sym_open_square) then - if(tuple(parser)) return - if(parser%sym==sym_ortho) then - call scan(parser) - if(parser%sym/=sym_open_square) then - if(expect(parser,sym_open_square)) return - endif - if(tuple(parser)) return - call make_node(parser,sym_open_square,2) - end if - elseif(parser%sym==sym_ortho) then - call scan(parser) - if(parser%sym/=sym_open_square) then - if(expect(parser,sym_open_square)) return - endif - if(tuple(parser)) return - call make_node(parser,sym_ortho,1) - elseif(parser%sym==sym_open) then - if(expr(parser)) return - if(expect(parser,sym_close)) return - endif - n=0 - do - if(check_name(parser,var_name)) then - if(expect(parser,sym_of)) return - call push_sym_val(parser,var_name) - call make_node(parser,sym_of,1) - if(expr(parser)) return - n=n+2 - else - if(n==0) then - if(expect_name(parser)) return - endif - call make_node(parser,list_sym,n) - m=m+2 - cycle outer - endif - if(parser%sym/=sym_comma) exit - call scan(parser) - enddo - call make_node(parser,list_sym,n) - m=m+2 - if(parser%sym/=sym_comma) exit - call scan(parser) - enddo outer - call make_node(parser,sym_list,m) - - ! Bounds - if(parser%sym==sym_bounds) then - call scan(parser) - if(expr(parser)) return - else - call make_node(parser,sym_null,0) - endif - call make_node(parser,sym_bounds,1) - - ! Attributes - if(par_attr(parser,sym_block,sym_block)) return - - ! Subexpressions - call make_node(parser,sym_nhd,0) - if(subexpr(parser)) return - - ! Block - if(block_or_single_stmt(parser,sym_nhd,-1,line)) return - - ! Make node for nhd statement - ! (nhd_expr (name of_expr)*)*, bounds,attr,subexp,block - call make_node(parser,sym_nhd,5) - iserr=.false. - end function nhd_stmt - !====================================================== ! test [ expr ] [ block ] !====================================================== @@ -3185,19 +3330,119 @@ recursive function test_stmt(parser) result(iserr) iserr=.false. end function test_stmt + !====================================================== + ! over expr [ attr ] [ subexp ] block + !====================================================== + function over_stmt(parser) result(iserr) + type(parse_state),intent(inout):: parser + logical:: iserr + integer:: line + iserr=.true. + line=get_sym_line(parser) + call scan(parser) + if(expr(parser)) return + if(par_attr(parser,sym_block,sym_block)) return + call push_null_val(parser) + if(subexpr(parser)) return + if(block_or_single_stmt(parser,sym_over,0,line)) return + call make_node(parser,sym_over,4) + iserr=.false. + end function over_stmt + + !====================================================== + ! sync ( [ while ] name) block | assignment | call + !====================================================== + function sync_stmt(parser) result(iserr) + type(parse_state),intent(inout):: parser + logical:: iserr + integer:: line,name,name2,sym,n,nu + logical:: is_call,is_assign,is_labelled + iserr=.true. + line=get_sym_line(parser) + call scan(parser) + sym=sym_sync + if(parser%sym==sym_open) then + call scan(parser) + if(parser%sym==sym_while) then + call scan(parser) + sym=sym_sync_while + endif + if(expect_and_get_name(parser,name)) return + if(expect(parser,sym_close)) return + is_labelled=.true. + else + call push_null_val(parser) + is_labelled=.false. + endif + if(parser%sym==sym_colon.or.parser%sym==sym_open_brace) then + if(.not.is_labelled) then + call parse_error(parser,& + 'A "sync" statement that is not of the form "sync(...)"'//& + ' cannot be applied to a block of statements') + endif + if(block_or_single_stmt(parser,sym_sync,name,line)) return + call make_node(parser,sym,2) + else + if(parser%sym==sym_dollar) then + call scan(parser) + if(op(parser,name2,.true.,.false.)) return + call push_sym_val(parser,name2) + call make_node(parser,sym_proc,1) + if(parser%sym==sym_dot) call scan(parser) + if(arglist(parser)) return + call make_node(parser,sym_open,1) + else + if(parser%sym==sym_assignment) then + call scan(parser) + is_assign=.true. + else + is_assign=.false. + endif + is_call=.false. + if(lhs(parser,n,nu,is_call)) return + if(is_call) then + if(is_assign) then + call parse_error(parser,& + 'Left hand side of "sync assign" appears to contain a procedure call') + return + else + call make_node(parser,sym_open,1) + endif + elseif(n>1) then + call parse_error(parser,'"sync" assignment can only have one left hand side') + return + elseif(nu>1) then + call parse_error(parser,'Left hand side of "sync" assignment cannot be "_"') + return + else + if(expect(parser,sym_assign)) return + if(expr(parser)) return + call make_node(parser,sym_assign,2) + endif + endif + call push_null_val(parser) + if(subexpr(parser)) return + call make_node(parser,sym,3) + endif + iserr=.false. + end function sync_stmt + !====================================================== ! List of statements !====================================================== - recursive subroutine stmt_list(parser,single) + recursive subroutine stmt_list(parser,single,num_to_include) type(parse_state),intent(inout):: parser logical,intent(in),optional:: single + integer,intent(in),optional:: num_to_include logical:: ok integer:: i,n,m,k,name,sym,label,line,pos type(pm_ptr):: p k=0 + if(present(num_to_include)) k=num_to_include do sym=parser%sym select case(sym) + ! These statements are only used internally by the compiler case(sym_pm_send:sym_pm_serve) if(send_stmt()) goto 999 @@ -3211,131 +3456,87 @@ recursive subroutine stmt_list(parser,single) if(pm_do_stmt()) goto 999 case(sym_pm_head_node) if(head_node_stmt()) goto 999 + case(sym_pm_each_index) + if(each_index_stmt()) goto 999 + case(sym_pm_for,sym_pm_foreach,sym_pm_over) + if(pm_for_stmt()) goto 999 + case(sym_pm_context) + if(pm_context_stmt()) goto 999 + case(sym_pm_shared,sym_pm_shared_always,sym_pm_chan,sym_pm_chan_always) + call scan(parser) + if(expect(parser,sym_open_brace)) goto 999 + call stmt_list(parser) + if(expect(parser,sym_close_brace)) goto 999 + call make_node(parser,sym,1) + case(sym_pm_set_dotdotdot) + call scan(parser) + if(expect(parser,sym_open)) goto 999 + if(expr(parser)) goto 999 + if(expect(parser,sym_close)) goto 999 + call make_node(parser,sym_pm_set_dotdotdot,1) + case(sym_pm_ref) + call scan(parser) + if(expect_name(parser)) return + if(expect(parser,sym_assign)) return + if(expr(parser)) return + call make_node(parser,sym_pm_ref,2) + ! Pragma's -- start with $$ case(sym_ddollar) - if(pragma()) goto 999 + if(pragma()) goto 999 + ! Statements that are actually part of the language case(sym_if) if(if_stmt(parser)) goto 999 case(sym_switch) if(switch_stmt(parser)) goto 999 case(sym_while) - call push_null_val(parser) - if(while_stmt(parser,0)) goto 999 + if(while_stmt(parser)) goto 999 case(sym_until) - call push_null_val(parser) - if(until_stmt(parser,0)) goto 999 + if(until_stmt(parser)) goto 999 case(sym_do) - if(do_stmt(parser,0)) goto 999 + if(do_stmt(parser)) goto 999 case(sym_test) if(test_stmt(parser)) goto 999 - case(sym_for,sym_conc) + case(sym_for,sym_forall) if(for_stmt(parser)) goto 999 - case(sym_each,sym_foreach_invar) + case(sym_each) if(for_each_stmt(parser,0)) goto 999 case(sym_par) if(par_stmt(parser)) goto 999 case(sym_any) if(any_stmt(parser)) goto 999 case(sym_over) - line=get_sym_line(parser) - call scan(parser) - call xexpr(parser) - if(par_attr(parser,sym_block,sym_block)) goto 999 - if(block_or_single_stmt(parser,sym_over,0,line)) goto 999 - call make_node(parser,sym_over,3) - case(sym_nhd) - if(nhd_stmt(parser)) return - case(sym_with) - line=get_sym_line(parser) - call scan(parser) - if(assn_or_call(parser,.false.,.false.,.true.)) goto 999 - if(parser%sym==sym_check.or.parser%sym==sym_where) then - if(subexpr(parser)) goto 999 - endif - call make_node(parser,sym_list,1) - if(block_or_single_stmt(parser,sym_with,0,line)) goto 999 - call make_node(parser,sym_with,2) + if(over_stmt(parser)) goto 999 case(sym_underscore) if(assn_or_call(parser,.false.,.true.,.true.)) goto 999 - if(parser%sym==sym_check.or.parser%sym==sym_where) then - if(subexpr(parser)) goto 999 - endif - case(sym_var,sym_const) - if(assn_list()) goto 999 - case(sym_coherent,sym_chan,sym_mirrored,sym_shared) - call scan(parser) - if(mode_stmt(parser,sym)) goto 999 + if(subexpr(parser)) goto 999 + case(sym_var,sym_const,sym_assignment,sym_invar,sym_chan,sym_nhd,sym_shared) + if(var_stmt(parser)) goto 999 + if(subexpr(parser)) goto 999 case(sym_dollar) if(proc_val_call()) goto 999 - case(sym_proceed) - call scan(parser) - call make_node(parser,sym_proceed,0) case(sym_sync) - if(sync_assign()) goto 999 + if(sync_stmt(parser)) goto 999 case(sym_return) call make_node(parser,sym_list,k) return + case(sym_yield,sym_pm_yield) + if(yield(parser,sym==sym_yield)) goto 999 + call make_node(parser,sym_yield,1) case default - if(check_name_pos(parser,name,line,pos)) then - ! Labelled statements - if(parser%sym==sym_gt) then - call scan(parser) - sym=parser%sym - select case(sym) - case(sym_while) - call push_sym_val(parser,name) - if(while_stmt(parser,name)) goto 999 - case(sym_until) - call push_sym_val(parser,name) - if(until_stmt(parser,name)) goto 999 - case(sym_each) - if(for_each_stmt(parser,name)) goto 999 - case(sym_do) - call push_sym_val(parser,name) - if(do_stmt(parser,name)) goto 999 - case(sym_if,sym_test,sym_any,& - sym_for,sym_conc,sym_par) - call parse_error(parser,'Cannot label a "'//trim(sym_names(sym))//'" statement') - goto 999 - case(sym_proceed) - call scan(parser) - call push_sym_val(parser,name) - call make_node_at(parser,sym_proceed,1,line,pos) - case default - call parse_error(parser,'Syntax error following ">" label') - goto 999 - end select - elseif(parser%sym==sym_colon.or.parser%sym==sym_dcolon& - .or.parser%sym==sym_open_brace) then - if(block_or_single_stmt(parser,name,0,line)) goto 999 - call push_sym_val(parser,name) - call make_node_at(parser,sym_sync,2,line,pos) - elseif(parser%sym==sym_dash) then - call scan(parser) - if(expect_name(parser)) goto 999 - call make_node(parser,sym_use,2) - if(arglist(parser)) goto 999 - call make_node(parser,sym_do,1) - if(subexpr(parser)) goto 999 - elseif(parser%sym==sym_open.or.parser%sym==sym_pct) then - call push_name_val(parser,name) - if(arglist(parser)) goto 999 - call make_node(parser,sym_do,1) - if(subexpr(parser)) goto 999 - else - call push_back_name(parser,name) - if(assn_list()) goto 999 - endif + if(parser%sym>num_sym) then + if(assn_or_call(parser,.true.,.true.,.true.)) goto 999 + if(subexpr(parser)) goto 999 else - if(parser%sym>0.and.parser%sym/=sym_close_brace& - .and.parser%sym<=last_decl) then - call parse_error(parser,'Expected start of statement') - goto 999 - else - exit - endif - endif + if(parser%sym>0.and.parser%sym/=sym_close_brace& + .and.parser%sym<=last_decl) then + call parse_error(parser,'Expected start of statement') + goto 999 + else + exit + endif + endif end select k=k+1 if(present(single)) exit @@ -3359,53 +3560,6 @@ recursive subroutine stmt_list(parser,single) contains - ! assignment { ',' assignment } - function assn_list() result(iserr) - logical:: iserr - integer:: n - iserr=.true. - n=0 - do - if(parser%sym==sym_var.or.parser%sym==sym_const) then - if(var_stmt(parser)) return - else - if(assn_or_call(parser,.true.,.true.,.true.)) return - endif - n=n+1 - if(parser%sym/=sym_comma) exit - call scan(parser) - enddo - if(n>1) call make_node(parser,sym_assign_list,n) - if(subexpr(parser)) return - iserr=.false. - end function assn_list - - ! sync name [ qual ] := expr - function sync_assign() result(iserr) - logical:: iserr - iserr=.true. - call scan(parser) - if(expect_name(parser)) return - call make_node(parser,sym_name,1) - call dup_val(parser) - if(qual(parser)) return - select case(parser%sym) - case(sym_plus,sym_minus,sym_mult,sym_and,sym_or,sym_amp,sym_bar,sym_xor,sym_concat) - call push_sym_val(parser,parser%sym) - call make_node(parser,sym_proc,1) - call scan(parser) - if(expect(parser,sym_define)) return - if(expr(parser)) return - call make_node(parser,sym_sync_assign,4) - case default - if(expect(parser,sym_define)) return - if(expr(parser)) return - call make_node(parser,sym_sync_assign,3) - end select - if(subexpr(parser)) return - iserr=.false. - end function sync_assign - ! $op(args) or $op.(args) function proc_val_call() result(iserr) logical:: iserr @@ -3421,7 +3575,7 @@ function proc_val_call() result(iserr) if(subexpr(parser)) return iserr=.false. end function proc_val_call - + ! Pragma: $$ name [ '(' exprlist ')' ] function pragma() result(iserr) logical:: iserr @@ -3588,26 +3742,67 @@ recursive function head_node_stmt() result(iserr) call make_node(parser,sym_pm_head_node,1) iserr=.false. end function head_node_stmt - - end subroutine stmt_list - !====================================================== - ! :statement | { statement list } - !====================================================== - recursive function block_or_single_stmt(parser,name1,name2,line) result(iserr) - type(parse_state),intent(inout):: parser - integer,intent(in):: name1,name2,line - logical:: iserr - iserr=.true. - if(parser%sym==sym_colon) then - call scan(parser) - call stmt_list(parser,single=.true.) - elseif(parser%sym==sym_dcolon) then + function each_index_stmt() result(iserr) + logical:: iserr + iserr=.true. call scan(parser) - call stmt_list(parser) - if(parser%sym/=sym_close_brace.and.parser%sym/=sym_eof) then - call parse_error(parser,'A block of statements starting with "::" cannot finish here') - endif + if(expect_name(parser)) return + if(expect(parser,sym_in)) return + if(expr(parser)) return + if(expect(parser,sym_open_brace)) return + call stmt_list(parser) + if(expect(parser,sym_close_brace)) return + call make_node(parser,sym_pm_each_index,3) + iserr=.false. + end function each_index_stmt + + ! PM__for PM__foreach PM__over + function pm_for_stmt() result(iserr) + logical:: iserr + integer:: sym + iserr=.true. + sym=parser%sym + call scan(parser) + call xexpr(parser) + if(expect(parser,sym_open_brace)) return + call stmt_list(parser) + if(expect(parser,sym_close_brace)) return + call make_node(parser,sym,2) + iserr=.false. + end function pm_for_stmt + + function pm_context_stmt() result(iserr) + logical:: iserr + integer:: i + iserr=.true. + call scan(parser) + do i=1,num_comm_args + if(i>1) then + if(expect(parser,sym_comma)) return + endif + if(expect_name(parser)) return + enddo + if(expect(parser,sym_open_brace)) return + call stmt_list(parser) + if(expect(parser,sym_close_brace)) return + call make_node(parser,sym_pm_context,num_comm_args+1) + iserr=.false. + end function pm_context_stmt + + end subroutine stmt_list + + !====================================================== + ! :statement | { statement list } + !====================================================== + recursive function block_or_single_stmt(parser,name1,name2,line) result(iserr) + type(parse_state),intent(inout):: parser + integer,intent(in):: name1,name2,line + logical:: iserr + iserr=.true. + if(parser%sym==sym_colon) then + call scan(parser) + call stmt_list(parser,single=.true.) else if(expect(parser,sym_open_brace)) return call stmt_list(parser) @@ -3715,7 +3910,7 @@ recursive function moded_typ(parser,modes_ok,type_needed) result(iserr) call scan(parser) if(.not.type_needed .and.(parser%sym==sym_comma.or.& parser%sym==sym_close.or.& - parser%sym==sym_define.or.& + parser%sym==sym_assign.or.& parser%sym==sym_open_attr)) then call push_null_val(parser) else @@ -3823,10 +4018,6 @@ recursive function typunary(parser) result(iserr) call make_node(parser,sym_any,0) if(typunary(parser)) return call make_node(parser,sym_includes,2) - elseif(parser%sym==sym_fix) then - call scan(parser) - if(typunary(parser)) return - call make_node(parser,sym_const,1) else if(typval(parser)) return endif @@ -3840,6 +4031,7 @@ recursive function typval(parser) result(iserr) type(parse_state),intent(inout):: parser logical:: iserr integer:: m,name,name2,i,base,vbase,sym,tag,line,pos + logical:: varg iserr=.true. sym=parser%sym select case(sym) @@ -3857,6 +4049,9 @@ recursive function typval(parser) result(iserr) call push_sym_val(parser,sym_dim1+m-1) call make_node(parser,sym_type,m+1) if(expect(parser,sym_close_square)) return + case(sym_pm_list) + call make_node(parser,sym_pm_list,0) + call scan(parser) case(sym_lt) call scan(parser) if(typ(parser)) return @@ -3865,29 +4060,72 @@ recursive function typval(parser) result(iserr) case(sym_any) call scan(parser) call make_node(parser,sym_any,0) - case(sym_dash) + case(sym_number) + call push_num_val(parser,parser%lexval) + call make_node(parser,sym_number,1) call scan(parser) - if(parser%sym==sym_number) then - if(pm_fast_vkind(parser%lexval)/=& - pm_long) then - call parse_error(parser,& - 'Cannot have "''" before non-default integer constant') - endif - call push_val(parser,parser%lexval) - call scan(parser) - call make_node(parser,sym_dash,1) - elseif(parser%sym==sym_true.or.parser%sym==sym_false) then - call push_sym_val(parser,parser%sym) + call make_node(parser,sym_literal,1) + case(sym_fix,sym_literal) + call scan(parser) + if(sym==sym_fix.and.parser%sym==sym_open_square) then call scan(parser) - call make_node(parser,sym_dash,1) + m=0 + do + if(expect(parser,sym_number)) return + call push_num_val(parser,parser%lexval) + call make_node(parser,sym_number,1) + call make_node(parser,sym_fix,1) + if(parser%sym==sym_dotdot) then + call scan(parser) + if(expect(parser,sym_number)) return + call push_num_val(parser,parser%lexval) + call make_node(parser,sym_number,1) + call make_node(parser,sym_fix,1) + call push_sym_val(parser,sym_range) + call make_node(parser,sym_type,3) + endif + m=m+1 + if(parser%sym/=sym_comma) exit + call scan(parser) + enddo + call push_sym_val(parser,sym_dim1+m-1) + call make_node(parser,sym_type,m+1) + if(expect(parser,sym_close_square)) return + elseif(sym==sym_literal.and.parser%sym/=sym_open) then + call make_node(parser,sym_any,0) + call make_node(parser,sym_literal,1) else - call parse_error(parser,'Expected number,"true" or "false"') + if(parser%sym==sym_open) then + call scan(parser) + if(parser%sym==sym_number) then + call push_num_val(parser,parser%lexval) + call make_node(parser,sym_number,1) + call scan(parser) + call make_node(parser,sym,1) + elseif(parser%sym==sym_true.or.parser%sym==sym_false) then + call make_node(parser,parser%sym,0) + call scan(parser) + call make_node(parser,sym,1) + elseif(parser%sym==sym_string) then + call push_num_val(parser,parser%lexval) + call make_node(parser,sym_string,1) + call scan(parser) + call make_node(parser,sym,1) + else + if(typ(parser)) return + call make_node(parser,sym,1) + endif + if(expect(parser,sym_close)) return + else + call push_null_val(parser) + call make_node(parser,sym,1) + endif endif case(sym_dollar) call scan(parser) if(op(parser,name,.true.,.true.)) return call push_sym_val(parser,name) - if(parser%sym==sym_dash.and.name>num_sym) then + if(parser%sym==sym_dcolon.and.name>num_sym) then call scan(parser) if(expect_name(parser)) return call make_node(parser,sym_proc,2) @@ -3896,7 +4134,7 @@ recursive function typval(parser) result(iserr) endif case(sym_proc) call scan(parser) - if(parser%sym==sym_open.or.parser%sym==sym_pct) then + if(parser%sym==sym_open.or.parser%sym==sym_pct.or.parser%sym==sym_dash) then if(proctyp(parser)) return else call push_sym_val(parser,sym_proc) @@ -3908,49 +4146,32 @@ recursive function typval(parser) result(iserr) if(typ(parser)) return call make_node(parser,sym_contains,1) if(expect(parser,sym_close)) return - case(sym_caret) + case(sym_pm_dref:sym_pm_dref_any_slice) call scan(parser) - select case(parser%sym) - case(sym_shared) - call scan(parser) - m=pm_dref_is_shared - case(sym_dot) - call scan(parser) - m=pm_dref_is_dot - case(sym_mult) - call scan(parser) - m=pm_dref_is_any - case(sym_hash) - call scan(parser) - if(parser%sym==sym_shared) then - call scan(parser) - m=pm_dref_is_shared_slice - elseif(parser%sym==sym_mult) then - call scan(parser) - m=pm_dref_is_any_slice - else - m=pm_dref_is_slice - endif - case(sym_here) - call scan(parser) - m=pm_dref_is_here - case(sym_pling) - call scan(parser) - m=pm_dref_is_ref - case default - m=pm_dref_is_var - end select + m=sym_pm_dref-sym-1 call push_num_val(parser,m) if(expect(parser,sym_open)) return if(opt_typ_list(parser,m)) return if(expect(parser,sym_close)) return call make_node(parser,sym_pm_dref,m+1) + case(sym_assign_or_init) + call make_node(parser,sym_assign_or_init,0) + call scan(parser) case(sym_dcaret) call scan(parser) - if(expect(parser,sym_open)) return - if(typ(parser)) return - if(expect(parser,sym_close)) return - call make_node(parser,sym_dcaret,1) + if(parser%sym==sym_caret) then + call scan(parser) + if(typval(parser)) return + call make_node(parser,sym_const,1) + elseif(parser%sym==sym_dcaret) then + call scan(parser) + call make_node(parser,sym_assign_or_init,0) + else + if(expect(parser,sym_open)) return + if(typ(parser)) return + if(expect(parser,sym_close)) return + call make_node(parser,sym_dcaret,1) + endif case(sym_underscore) call scan(parser) call make_node(parser,sym_underscore,0) @@ -3965,7 +4186,7 @@ recursive function typval(parser) result(iserr) call scan(parser) endif endif - if(parser%sym==sym_dash) then + if(parser%sym==sym_dcolon) then call scan(parser) if(.not.check_name(parser,name2)) then call parse_error(parser,'Expected name') @@ -4015,80 +4236,55 @@ end function typval !==================================================================== ! proc ( args... ) -> (type,type...) - ! - ! Also used in methods and method signatures - ! For a method signature tname and params must be present - ! For a method, tname, params and is_method must be present - ! -- in this case parameter names are parsed and - ! pushed onto the symbol stack !==================================================================== - recursive function proctyp(parser,tname,params,is_method) result(iserr) + recursive function proctyp(parser,yield) result(iserr) type(parse_state):: parser - integer,intent(in),optional:: tname - type(pm_ptr),intent(in),optional:: params - logical,intent(in),optional:: is_method + logical,intent(in),optional:: yield logical:: iserr - integer:: i,base,base2,n,m,sym,npar + integer:: i,base,n,m,sym,npar logical:: iscomm iserr=.true. + + base=parser%top call push_null_val(parser) sym=parser%sym - iscomm=sym==sym_pct - if(iscomm) then + if(sym==sym_pct.or.sym==sym_dash.or.sym==sym_dot) then + iscomm=.true. call push_sym_val(parser,sym) call scan(parser) - call make_node(parser,sym_any,0) - call make_node(parser,sym_any,0) - call make_node(parser,sym_any,0) - m=3 + do i=1,num_comm_args + call make_node(parser,sym_any,0) + enddo + m=num_comm_args else call push_sym_val(parser,sym_proc) - m=0 - endif - if(expect(parser,sym_open)) return - - if(present(tname)) then - ! First argument "this" for methods and method signatures - ! Either T(u,v) for method or *T(u,v) for method signature - if(present(is_method)) then -!!$ npar=node_numargs(params) -!!$ do i=1,npar,2 -!!$ call push_val(parser,node_arg(params,i)) -!!$ call make_node(parser,sym_type,1) -!!$ enddo - call push_sym_val(parser,tname) - call make_node(parser,sym_type,1) - else - call make_node(parser,sym_mult,0) - endif - m=m+1 + call make_node(parser,sym_any,0) + m=1 endif - - base=parser%top - if(parser%sym/=sym_close) then - do + if(present(yield)) then + call make_node(parser,sym_any,0) + call push_sym(parser,m+1) + call make_node(parser,sym_any,0) + m=m+2 + endif + + if(expect(parser,sym_open)) return + + if(parser%sym/=sym_close) then + do sym=parser%sym m=m+1 if(sym==sym_amp) then call scan(parser) - if(present(is_method)) then - if(expect_name(parser)) return - call push_sym(parser,-int(parser%vstack(parser%vtop)%offset)) - call drop_val(parser) - if(expect(parser,sym_colon)) return - else - call push_sym(parser,m) - endif + call push_sym(parser,m) + if(moded_typ(parser,iscomm,.false.)) return + elseif(sym==sym_var.or.sym==sym_const) then + call scan(parser) if(moded_typ(parser,iscomm,.false.)) return + call make_node(parser,sym,1) else - if(present(is_method)) then - if(expect_name(parser)) return - call push_sym(parser,int(parser%vstack(parser%vtop)%offset)) - call drop_val(parser) - if(expect(parser,sym_colon)) return - endif if(moded_typ(parser,iscomm,.false.)) return endif if(parser%sym/=sym_comma) exit @@ -4097,15 +4293,13 @@ recursive function proctyp(parser,tname,params,is_method) result(iserr) if(parser%sym==sym_dotdotdot) then call scan(parser) call make_node(parser,sym_dotdotdot,m) - if(present(is_method)) call push_sym(parser,sym_dotdotdot) else call make_node(parser,sym_list,m) - if(present(is_method)) call push_sym(parser,sym_list) - endif + endif else call make_node(parser,sym_list,m) - if(present(is_method)) call push_sym(parser,sym_list) endif + if(expect(parser,sym_close)) return if(parser%sym==sym_arrow) then call scan(parser) @@ -4116,22 +4310,22 @@ recursive function proctyp(parser,tname,params,is_method) result(iserr) else call push_null_val(parser) endif - if(present(is_method)) then - base2=parser%top - do i=base+1,base2-1 - if(parser%stack(i)<0) then - call push_sym(parser,i) - endif - enddo + + if(parser%top>base) then + call name_vector(parser,base) else - base2=base + call push_null_val(parser) endif - if(parser%top>base2) then - call name_vector(parser,base2) + + if(.not.present(yield).and.parser%sym==sym_yield) then + call scan(parser) + call push_back(parser,sym_dash) + if(proctyp(parser,yield=.true.)) return else call push_null_val(parser) endif - call make_node(parser,sym_proc,5) + + call make_node(parser,sym_proc,6) iserr=.false. end function proctyp @@ -4203,29 +4397,85 @@ recursive function opt_typ_list(parser,m) result(iserr) iserr=.false. end function opt_typ_list + + !====================================================== + ! Comma separated list of types + ! any of which may be omitted + !====================================================== + recursive function opt_moded_typ_list(parser,m,varg) result(iserr) + type(parse_state),intent(inout):: parser + integer,intent(out):: m + logical,intent(out),optional:: varg + logical:: iserr + iserr=.true. + m=0 + do + if(parser%sym==sym_comma.or.& + parser%sym==sym_dotdotdot) then + call push_null_val(parser) + else + if(moded_typ(parser,.true.,.false.)) return + endif + m=m+1 + if(present(varg).and.parser%sym==sym_dotdotdot) then + call scan(parser) + varg=.true. + exit + endif + if(parser%sym/=sym_comma) exit + call scan(parser) + enddo + iserr=.false. + end function opt_moded_typ_list + !====================================================== ! Parameter list for procedure declaration !====================================================== - recursive function param_list(parser,iscomm,param_base) result(iserr) + recursive function param_list(parser,iscomm,dot_name,dot_type,close) result(iserr) type(parse_state),intent(inout):: parser logical,intent(in):: iscomm - integer,intent(in),optional:: param_base + type(pm_ptr),intent(in):: dot_name,dot_type + integer,intent(in):: close logical:: iserr - integer:: m,n,i,base,last,vbase,sym,name,numloop + integer:: m,n,i,base,last,vbase,sym,msym,name,numloop type(pm_ptr):: temp,dom base=parser%top iserr=.true. - m=0 + m=1 n=0 - + + ! All procedure calls implicitly pass topology + call push_sym_val(parser,sym_topology) + if(parser%sym==sym_topology) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + if(parser%sym/=close) then + if(expect(parser,sym_comma)) return + endif + else + call push_null_val(parser) + endif + ! For communicating procedures implicit "region" and "subregion" parameters if(iscomm) then + call push_sym_val(parser,sym_outer) + if(parser%sym==sym_outer) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + if(parser%sym/=close) then + if(expect(parser,sym_comma)) return + endif + else + call push_null_val(parser) + endif call push_sym_val(parser,sym_region) if(parser%sym==sym_region) then call scan(parser) if(expect(parser,sym_colon)) return if(typ(parser)) return - if(parser%sym/=sym_close) then + if(parser%sym/=close) then if(expect(parser,sym_comma)) return endif else @@ -4236,7 +4486,7 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) call scan(parser) if(expect(parser,sym_colon)) return if(typ(parser)) return - if(parser%sym/=sym_close) then + if(parser%sym/=close) then if(expect(parser,sym_comma)) return endif else @@ -4248,43 +4498,38 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) call scan(parser) if(expect(parser,sym_colon)) return if(typ(parser)) return - if(parser%sym/=sym_close) then + if(parser%sym/=close) then if(expect(parser,sym_comma)) return endif else call push_null_val(parser) endif - m=3 - endif - - ! For methods, the parameter list is coded on the stack - if(present(param_base)) then - last=parser%top - call push_sym_val(parser,sym_this) - call push_null_val(parser) - m=m+1 - do i=param_base+1,last-1 - call push_sym_val(parser,abs(parser%stack(i))) - call push_null_val(parser) - m=m+1 - if(parser%stack(i)<0) call push_sym(parser,m) - enddo - call make_node(parser,parser%stack(last),m*2) - call push_null_val(parser) - if(parser%top>base) then - call name_vector(parser,base) + call push_sym_val(parser,sym_mask) + if(parser%sym==sym_mask) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + if(parser%sym/=close) then + if(expect(parser,sym_comma)) return + endif else call push_null_val(parser) endif - iserr=.false. - return + m=num_comm_args endif + if(.not.pm_fast_isnull(dot_name)) then + call push_val(parser,dot_name) + call push_val(parser,dot_type) + m=m+1 + endif + ! Empty argument list - if(parser%sym==sym_close) then + if(parser%sym==close) then call make_node(parser,sym_list,m*2) call push_null_val(parser) call push_null_val(parser) + call push_null_val(parser) call scan(parser) iserr=.false. return @@ -4292,30 +4537,36 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) ! Standard (non-keyword) arguments do - if(parser%sym==sym_arg) then + if(parser%sym==sym_dotdotdot) then call scan(parser) - if(expect(parser,sym_dotdotdot)) return - call push_sym_val(parser,sym_arg) - if(arg_type_with_mode(iscomm)) return + call push_sym_val(parser,sym_dotdotdot) + if(arg_typ_with_mode(iscomm)) return call make_node(parser,sym_dotdotdot,m*2+2) exit else if(parser%sym==sym_amp) then call scan(parser) if(expect_name(parser,'argument name')) return - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call parse_error(parser,'Cannot have "=" after "&name"') return endif m=m+1 call push_sym(parser,m) - if(arg_type_with_mode(iscomm)) return - else if(parser%sym==sym_key) then - call make_node(parser,sym_list,m*2) - call push_back(parser,sym_comma) - exit + if(arg_typ_with_mode(iscomm)) return + elseif(parser%sym==sym_var.or.parser%sym==sym_const) then + msym=parser%sym + call scan(parser) + if(expect_name(parser)) return + if(parser%sym==sym_colon) then + call scan(parser) + if(arg_typ_with_mode(iscomm)) return + else + call push_null_val(parser) + endif + call make_node(parser,msym,1) else if(check_name(parser,name)) then - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call make_node(parser,sym_list,m*2) call push_sym_val(parser,name) call scan(parser) @@ -4329,8 +4580,8 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) else call parse_error(parser,'Expected argument') endif - if(arg_type_with_mode(iscomm)) return - if(parser%sym==sym_define) then + if(arg_typ_with_mode(iscomm)) return + if(parser%sym==sym_assign) then parser%temp=pop_val(parser) call drop_val(parser) call make_node(parser,sym_list,m*2) @@ -4355,19 +4606,12 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) if(parser%sym==sym_comma) then do call scan(parser) - if(parser%sym==sym_key) then - call scan(parser) - if(expect(parser,sym_dotdotdot)) return - call make_node(parser,sym_dotdotdot,n*3) - exit - else - if(expect_name(parser, & - 'optional argument name')) return - if(arg_type_with_mode(iscomm)) return - if(expect(parser,sym_define)) return - if(expr(parser)) return - n=n+1 - endif + if(expect_name(parser, & + 'optional argument name')) return + if(arg_typ_with_mode(iscomm)) return + if(expect(parser,sym_assign)) return + if(expr(parser)) return + n=n+1 if(parser%sym/=sym_comma) then call make_node(parser,sym_list,n*3) exit @@ -4375,23 +4619,37 @@ recursive function param_list(parser,iscomm,param_base) result(iserr) enddo else if(n>0) then + if(.not.pm_fast_isnull(dot_name)) then + call parse_error(parser,'A method cannot have keyword arguments') + endif call make_node(parser,sym_list,n*3) else call push_null_val(parser) endif endif - - if(expect(parser,sym_close)) return + if(parser%top>base) then call name_vector(parser,base) else call push_null_val(parser) endif + + if(parser%sym==sym_when) then + call scan(parser) + call xexpr(parser) + else + call push_null_val(parser) + endif + + if(expect(parser,close)) return + iserr=.false. return contains - function arg_type_with_mode(iscomm) result(iserr) + include 'fisnull.inc' + + function arg_typ_with_mode(iscomm) result(iserr) logical,intent(in):: iscomm logical:: iserr iserr=.true. @@ -4402,173 +4660,151 @@ function arg_type_with_mode(iscomm) result(iserr) call push_null_val(parser) endif iserr=.false. - end function arg_type_with_mode + end function arg_typ_with_mode end function param_list + !====================================================== ! Procedure/call attributes !====================================================== - recursive function proc_call_attr(parser,iscall,flags) result(iserr) + recursive function proc_attr(parser,iscall,flags) result(iserr) type(parse_state),intent(inout):: parser logical,intent(in):: iscall integer,intent(inout):: flags logical:: iserr - logical:: iscomm integer:: m iserr=.true. call scan(parser) - iscomm=iand(flags,proc_is_comm)/=0 do select case(parser%sym) - case(sym_each) - if(iscall) then - call bad_attr - exit - endif + case(sym_inline) + call set_flags(proccall_is_inline) call scan(parser) - if(expect(parser,sym_caret)) return - if(expect(parser,sym_open)) return - m=0 - do - if(expect_name(parser)) return - m=m+1 - if(parser%sym/=sym_comma) exit - call scan(parser) - enddo - call make_node(parser,sym_each,m) - if(expect(parser,sym_close)) return - flags=ior(flags,proc_is_each_proc) - case(sym_shared) - if(iscomm.eqv.iscall) then - call bad_attr - endif - call scan(parser) - flags=ior(flags,proc_run_shared) - case(sym_pm_node) - if(iscomm.eqv.iscall) then - call bad_attr - endif - call scan(parser) - flags=ior(flags,proc_run_local+proc_run_always) - case(sym_complete) - if(iscomm.eqv.iscall) then - call bad_attr - endif - call scan(parser) - flags=ior(flags,proc_run_complete) - case(sym_always) - if((.not.iscomm).and.(.not.iscall)) then - call bad_attr - endif - call scan(parser) - flags=ior(flags,proc_run_always) - case(sym_inline) - call scan(parser) - flags=ior(flags,proc_inline) case(sym_no_inline) + call set_flags(proccall_is_no_inline) call scan(parser) - flags=ior(flags,proc_no_inline) - case(sym_cond_attr) - call scan(parser) - if(iscall.or..not.iscomm) call bad_attr - flags=ior(flags,proc_is_cond) - case(sym_uncond) - call scan(parser) - if(iscall.or..not.iscomm) call bad_attr - flags=ior(flags,proc_is_uncond) - case(sym_ignore_rules) + case(sym_always) + call set_flags(proc_run_always) call scan(parser) - flags=ior(flags,call_ignore_rules) end select if(parser%sym/=sym_comma) exit call scan(parser) enddo - if(iand(flags,proc_inline+proc_no_inline)==& - proc_inline+proc_no_inline) then + if(iand(flags,proccall_is_inline+proccall_is_no_inline)==& + proccall_is_inline+proccall_is_no_inline) then call parse_error(parser,& 'Cannot have both "<>" and "<>" attributes together') endif - if(iand(flags,proc_is_cond+proc_is_uncond)==& - proc_is_cond+proc_is_uncond) then - call parse_error(parser,& - 'Cannot have both "<>" and "<>" attributes together') - endif if(expect(parser,sym_close_attr)) return iserr=.false. contains - subroutine bad_attr - if(iscall) then - call parse_error(parser,& - 'Cannot have "'//trim(sym_names(parser%sym))//& - '" attribute in a communicating call') - else + subroutine set_flags(new_flags) + integer,intent(in):: new_flags + if(iand(flags,new_flags)/=0) then call parse_error(parser,& - 'Cannot have "'//trim(sym_names(parser%sym))//& - '" attribute in a non-communicating procedure') + 'Cannot repeat attribute "'//trim(sym_names(parser%sym))//'"') endif - end subroutine bad_attr - end function proc_call_attr + flags=ior(flags,new_flags) + end subroutine set_flags + end function proc_attr !====================================================== ! Procedure declaration !====================================================== - function proc_decl(parser,method_name,param_base) result(iserr) + function proc_decl(parser) result(iserr) type(parse_state),intent(inout):: parser - integer,intent(in),optional:: method_name,param_base logical:: iserr - type(pm_ptr),target::ptr,dom,dparams,rtypes + type(pm_ptr),target::ptr,dom,dparams,rtypes,dot_name,dot_type type(pm_ptr):: p,params,link type(pm_reg),pointer:: reg integer:: name,callname,this,thispar integer:: nret,base,flags,sbase,scount,m,nreduce,sym - integer:: line,pos,nerrors - logical:: ampargs,iscall,iscomm,isshared,islocal,ischan,ismethod,have_rtn + integer:: line,pos,nerrors,open,close + logical:: ampargs,iscall,iscomm,isref,isshared,islocal,ischan,have_rtn nerrors=parser%error_count - reg=>pm_register(parser%context,'proc',ptr,dom,dparams,rtypes) + reg=>pm_register(parser%context,'proc',ptr,dom,dparams,rtypes,dot_name,dot_type) iserr=.true. - ismethod=present(method_name) sym=sym_proc nret=0 + flags=0 sbase=parser%vtop scount=parser%error_count dom=pm_null_obj dparams=pm_null_obj thispar=-1 - - ! Procedure name - if(ismethod) then - name=method_name - else - call scan(parser) - if(.not.check_name(parser,name)) then - if(op(parser,name,.false.,.false.)) goto 999 - endif - endif - + open=sym_open + close=sym_close + ! Line and position of procedure start call get_sym_pos(parser,line,pos) - - ! Communicating proc flag + call scan(parser) + iscomm=.false. - if(parser%sym==sym_pct) then + isref=.false. + if(parser%sym==sym_open) then + ! Reference procedure proc (name:type).name(...) call scan(parser) + if(parser%sym==sym_amp) then + flags=ior(flags,proccall_is_lhs) + call scan(parser) + endif + if(expect_name(parser)) goto 999 + dot_name=pop_val(parser) + if(parser%sym==sym_colon) then + call scan(parser) + if(moded_typ(parser,.true.,.false.)) goto 999 + dot_type=pop_val(parser) + else + dot_type=pm_null_obj + endif + if(expect(parser,sym_close)) goto 999 + if(parser%sym==sym_open_square) then + name=sym_sub + open=sym_open_square + close=sym_close_square + else + if(expect(parser,sym_dot)) goto 999 + if(expect_name(parser)) goto 999 + name=pop_num_val(parser) + endif + flags=ior(flags,proccall_is_ref+proccall_is_comm+proccall_is_general) iscomm=.true. + isref=.true. + else + + ! Procedure name + if(.not.check_name(parser,name)) then + if(.not.isref) then + if(op(parser,name,.false.,.false.)) goto 999 + endif + endif + + dot_name=pm_null_obj + dot_type=pm_null_obj + + endif + + ! Communicating proc flags + if(.not.isref) then + if(parser%sym==sym_pct) then + call scan(parser) + flags=ior(flags,proccall_is_comm) + iscomm=.true. + elseif(parser%sym==sym_dash) then + call scan(parser) + flags=ior(flags,proccall_is_comm+proccall_is_general) + iscomm=.true. + endif endif ! Start of parameters - if(.not.present(param_base)) then - if(expect(parser,sym_open)) goto 999 - endif - + if(expect(parser,open)) goto 999 + 10 continue ! Create fully qualified (module!name) procedure name - if(ismethod) then - call push_sym_val(parser,name) - else - call make_qualified_name(parser,name) - endif + call make_qualified_name(parser,name) ! Start of procedure delaration node base=parser%vtop @@ -4581,28 +4817,21 @@ function proc_decl(parser,method_name,param_base) result(iserr) ! Push some more entries in the procedure node (some get values later) call push_val(parser,parser%modl) call push_num_val(parser,-12345) ! flags - if(param_list(parser,iscomm,param_base)) goto 999 + if(param_list(parser,iscomm,dot_name,dot_type,close)) goto 999 + params=parser%vstack(parser%vtop-2) - call push_num_val(parser,-777) ! coded params call push_num_val(parser,-777) ! coded returns call push_num_val(parser,-777) ! coded type call push_num_val(parser,-777) ! nret - ! Start computing flags for this procedure node - if(iscomm) then - flags=proc_is_comm - else - flags=0 - endif - ! Return types ->(typelist) if(parser%sym==sym_arrow) then call scan(parser) - if(expect(parser,sym_open)) return + if(expect(parser,sym_open)) goto 999 if(parser%sym==sym_close) then nret=0 else - if(moded_typ_list(parser,iscomm,nret)) return + if(moded_typ_list(parser,iscomm,nret)) goto 999 if(expect(parser,sym_close)) return endif call make_node(parser,sym_list,nret) @@ -4614,12 +4843,40 @@ function proc_decl(parser,method_name,param_base) result(iserr) nret=-1 endif + if(parser%sym==sym_yield) then + if(yield_clause()) goto 999 + endif + + if(iscomm) then + + if(parser%sym==sym_uncond) then + flags=ior(flags,proc_is_uncond) + call scan(parser) + elseif(parser%sym==sym_cond) then + flags=ior(flags,proc_is_cond) + call scan(parser) + endif + + if(parser%sym==sym_global) then + flags=ior(flags,proc_run_shared) + call scan(parser) + elseif(parser%sym==sym_pm_shared) then + flags=ior(flags,proc_run_local) + call scan(parser) + elseif(parser%sym==sym_complete) then + if(iand(flags,proc_is_uncond)/=0) then + call parse_error(parser,'Cannot combine "cplt" and "uncond"') + endif + flags=ior(flags,proc_run_complete) + call scan(parser) + endif + + endif + ! Attributes if(parser%sym==sym_open_attr) then - if(proc_call_attr(parser,.false.,flags)) goto 999 - if(iand(flags,proc_is_each_proc)==0) then - call push_null_val(parser) - endif + if(proc_attr(parser,.false.,flags)) goto 999 + call push_null_val(parser) else call push_null_val(parser) endif @@ -4628,16 +4885,32 @@ function proc_decl(parser,method_name,param_base) result(iserr) if(parser%sym==sym_dotdotdot) then call scan(parser) flags=ior(flags,proc_is_open) - endif + endif + ! = expr or [ check expr ] block - if(parser%sym==sym_define.and.nret==-1) then - + if(parser%sym==sym_assign.and.nret==-1) then + call push_null_val(parser) call scan(parser) + m=0 do - if(expr(parser)) goto 999 + if(iand(flags,proccall_is_lhs)/=0) then + if(m>0) then + call parse_error(parser,& + 'Cannot return more than one value from reference "." procedure') + if(expr(parser)) goto 999 + else + if(parser%sym>=sym_pm_dref.and.parser%sym<=sym_pm_ref) then + if(term(parser,.false.)) goto 999 + else + if(valref(parser)) goto 999 + endif + endif + else + if(expr(parser)) goto 999 + endif call push_null_val(parser) m=m+2 if(parser%sym/=sym_comma) exit @@ -4697,26 +4970,25 @@ function proc_decl(parser,method_name,param_base) result(iserr) endif endif call push_null_val(parser) ! Code tree - - if(parser%error_count>scount) then + if(parser%error_count>0) then parser%vtop=sbase + if(parser%error_count==scount) iserr=.false. goto 999 endif - if(parser%error_count>0) goto 999 - + ! Assign flags to proc_flags slot parser%vstack(parser%vtop-& proc_num_args-node_args+proc_flags+1)%offset=flags - + ! Assign number of returns to proc_numret slot parser%vstack(parser%vtop-& proc_num_args-node_args+proc_numret+1)%offset=nret - + if(pm_debug_checks) then if(parser%vtop-base/=proc_num_args) then - write(*,*) '=========' + write(*,*) '=========',parser%vtop-base,proc_num_args do flags=base+1,parser%vtop call dump_parse_tree(parser%context,6,parser%vstack(flags),2) write(*,*) '===' @@ -4728,22 +5000,93 @@ function proc_decl(parser,method_name,param_base) result(iserr) endif call make_node_at(parser,sym,proc_num_args,line,pos) - - if(debug_parser_extra) then + + if(debug_parser) then write(*,*) 'PROC DECL>----------------' call dump_parse_tree(parser%context,44,top_val(parser),2) write(*,*) 'PROC-DECL----------------' endif call add_proc_decl(parser,name,ptr) - + iserr=.false. 999 continue call pm_delete_register(parser%context,reg) return contains include 'fisnull.inc' - + include 'fesize.inc' + + function yield_clause() result(iserr) + logical:: iserr + integer:: m,n,i,k,base,first + type(pm_ptr):: params,amps + iserr=.true. + + if(parser%error_count>0) then + call scan(parser) + if(proctyp(parser,yield=.true.)) return + iserr=.false. + return + endif + + if(iand(flags,proccall_is_ref)/=0) then + call parse_error(parser,'Cannot have a "yield" clause in a method') + elseif(iand(flags,proccall_is_comm)/=0) then + first=num_comm_args+1 + else + first=2 + endif + params=parser%vstack(parser%vtop-7) + n=node_numargs(params)/2 + amps=parser%vstack(parser%vtop-5) + do i=1,first-1 + call push_val(parser,node_arg(params,i*2-1)) + call push_val(parser,node_arg(params,i*2)) + enddo + base=parser%top + m=first + call push_sym_val(parser,sym_block_proc) + call scan(parser) + call push_back(parser,sym_dash) + if(proctyp(parser,yield=.true.)) return + m=m+1 + call push_sym_val(parser,sym_block_inouts) + call push_null_val(parser) + call push_sym(parser,m) + m=m+1 + call push_sym_val(parser,sym_block_ins) + call push_null_val(parser) + m=m+1 + if(pm_fast_isnull(amps))then + do i=first,n + call push_val(parser,node_arg(params,i*2-1)) + call push_val(parser,node_arg(params,i*2)) + enddo + else + amps=pm_name_val(parser%context,int(amps%offset)) + k=0 + do i=first,n + call push_val(parser,node_arg(params,i*2-1)) + call push_val(parser,node_arg(params,i*2)) + if(amps%data%i(amps%offset+k)==i) then + call push_sym(parser,m) + k=min(k+1,pm_fast_esize(amps)) + endif + m=m+1 + enddo + endif + call make_node(parser,node_sym(params),n*2+num_comm_args) + parser%vstack(parser%vtop-8)=top_val(parser) + call drop_val(parser) + + call name_vector(parser,base) + parser%vstack(parser%vtop-6)=top_val(parser) + call drop_val(parser) + + iserr=.false. + end function yield_clause + function return_stmt() result(iserr) logical:: iserr integer:: m @@ -4751,7 +5094,21 @@ function return_stmt() result(iserr) call scan(parser) m=0 do - if(expr(parser)) return + if(iand(flags,proccall_is_lhs)/=0) then + if(m>0) then + call parse_error(parser,& + 'Cannot return more than one value from reference "." procedure') + if(expr(parser)) return + else + if(parser%sym>=sym_pm_dref.and.parser%sym<=sym_pm_ref) then + if(term(parser,.false.)) return + else + if(valref(parser)) return + endif + endif + else + if(expr(parser)) return + endif m=m+2 if(nret>=m/2.and..not.pm_fast_isnull(rtypes)) then call push_val(parser,node_arg(rtypes,m/2)) @@ -4772,36 +5129,79 @@ function return_stmt() result(iserr) parser%vtop=parser%vtop-1 iserr=.false. end function return_stmt - + end function proc_decl !====================================================== ! Procedure signature (...)->... used for builtin procs !====================================================== - recursive function proc_sig(parser) result(iserr) + recursive function proc_sig(parser,iscomm) result(iserr) type(parse_state),intent(inout):: parser + logical,intent(in):: iscomm logical:: iserr integer:: m,n,base,name,sym type(pm_ptr):: temp base=parser%top iserr=.true. - m=0 + m=1 n=0 - if(parser%sym==sym_eq) then + call push_sym_val(parser,sym_topology) + if(parser%sym==sym_topology) then call scan(parser) - call make_node(parser,sym_eq,0) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + else call push_null_val(parser) - if(parser%sym==sym_amp) then + endif + if(iscomm) then + call push_sym_val(parser,sym_outer) + m=m+1 + if(parser%sym==sym_outer) then call scan(parser) - parser%top=parser%top+1 - parser%stack(parser%top)=1 - call name_vector(parser,base) + if(expect(parser,sym_colon)) return + if(typ(parser)) return else call push_null_val(parser) endif - if(expect(parser,sym_close)) return - elseif(parser%sym==sym_close) then - call make_node(parser,sym_list,0) + call push_sym_val(parser,sym_region) + m=m+1 + if(parser%sym==sym_topology) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + else + call push_null_val(parser) + endif + call push_sym_val(parser,sym_subregion) + m=m+1 + if(parser%sym==sym_subregion) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + else + call push_null_val(parser) + endif + call push_sym_val(parser,sym_here_in_tile) + m=m+1 + if(parser%sym==sym_here_in_tile) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + else + call push_null_val(parser) + endif + call push_sym_val(parser,sym_mask) + m=m+1 + if(parser%sym==sym_mask) then + call scan(parser) + if(expect(parser,sym_colon)) return + if(typ(parser)) return + else + call push_null_val(parser) + endif + endif + if(parser%sym==sym_close) then + call make_node(parser,sym_list,2) call push_null_val(parser) call push_null_val(parser) call scan(parser) @@ -4814,7 +5214,7 @@ recursive function proc_sig(parser) result(iserr) parser%stack(parser%top)=m endif if(check_name(parser,name)) then - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call make_node(parser,sym_list,m*2) call push_sym_val(parser,name) call scan(parser) @@ -4828,23 +5228,19 @@ recursive function proc_sig(parser) result(iserr) call push_back_name(parser,name) call push_null_val(parser) endif - else if(parser%sym==sym_arg) then - call push_sym_val(parser,sym_arg) + else if(parser%sym==sym_dotdotdot) then + call push_sym_val(parser,sym_dotdotdot) call scan(parser) - if(expect(parser,sym_dotdotdot)) return if(expect(parser,sym_colon)) return if(moded_typ(parser,.true.,.false.)) return call make_node(parser,sym_dotdotdot,m*2) exit - else if(parser%sym==sym_key) then - call make_node(parser,sym_list,m*2) - exit else call push_null_val(parser) endif if(moded_typ(parser,.true.,.false.)) return - + if(parser%sym==sym_dotdotdot) then call scan(parser) call make_node(parser,sym_dotdotdot,m*2) @@ -4858,18 +5254,13 @@ recursive function proc_sig(parser) result(iserr) enddo do while(parser%sym==sym_comma) call scan(parser) - if(parser%sym==sym_key) exit if(typ(parser)) return if(expect_name(parser,& 'optional parameter name')) return - if(expect(parser,sym_define)) return + if(expect(parser,sym_assign)) return n=n+1 enddo - if(parser%sym==sym_key) then - call make_node(parser,sym_dotdotdot,n*2) - call scan(parser) - if(expect(parser,sym_dotdotdot)) return - else if(n>0) then + if(n>0) then call make_node(parser,sym_list,n*2) else call push_null_val(parser) @@ -4888,10 +5279,11 @@ recursive function proc_sig(parser) result(iserr) ! Special forms of return type which compute it based on arguments if(parser%sym==sym_arrow) then call scan(parser) + if(expect(parser,sym_open)) return sym=parser%sym select case(sym) case(sym_gt,sym_dim,sym_vdim,sym_invar_dim,sym_fix_dim,& - sym_eq,sym_over,sym_pling,sym_includes) + sym_eq,sym_over,sym_pling,sym_includes) ! These return single type based on types of a ! list of expressions call scan(parser) @@ -4901,9 +5293,9 @@ recursive function proc_sig(parser) result(iserr) call push_null_val(parser) call push_val(parser,parser%temp) call make_node(parser,sym,1) - case(sym_pct,sym_define,sym_dot,sym_query,sym_amp,& + case(sym_pct,sym_assign,sym_dot,sym_query,sym_amp,& sym_hash,sym_caret,sym_dcaret,sym_d1:sym_d7,sym_invar,sym_shared,& - sym_type) + sym_type,sym_tilde,sym_bar) ! These return N types based on types of a ! list of N expressions call scan(parser) @@ -4917,11 +5309,11 @@ recursive function proc_sig(parser) result(iserr) call push_null_val(parser) call push_val(parser,parser%temp) call make_node(parser,sym,1) - case(sym_dash) + case(sym_dcolon) call scan(parser) if(typ_list(parser,m)) return call make_node(parser,sym_result,m) - call make_node(parser,sym_dash,1) + call make_node(parser,sym_dcolon,1) call push_num_val(parser,m) call swap_vals(parser) call push_null_val(parser) @@ -4932,18 +5324,156 @@ recursive function proc_sig(parser) result(iserr) call swap_vals(parser) call push_null_val(parser) end select + if(expect(parser,sym_close)) return else call push_num_val(parser,0) call push_null_val(parser) call push_null_val(parser) endif iserr=.false. - return - end function proc_sig + return + end function proc_sig + + function builtin_flags(parser,flags) result(iserr) + type(parse_state),intent(inout):: parser + integer,intent(out):: flags + logical:: iserr + iserr=.true. + flags=0 + if(parser%sym==sym_open_attr) then + call scan(parser) + do + select case(parser%sym) + case(sym_proc_is_generator) + flags=ior(flags,proc_is_generator) + case(sym_proc_is_impure) + flags=ior(flags,proc_is_impure) + case(sym_proc_has_for) + flags=ior(flags,proc_has_for) + case(sym_proc_is_dcomm) + flags=ior(flags,proc_is_dcomm) + case(sym_proc_is_file) + flags=ior(flags,proc_is_file) + case(sym_proc_is_not_inlinable) + flags=ior(flags,proc_is_not_inlinable) + case(sym_proc_needs_type) + flags=ior(flags,proc_needs_type) + case(sym_proc_prints_out) + flags=ior(flags,proc_prints_out) + case default + call parse_error(parser,'Bad PM__intrinsic attribute') + return + end select + call scan(parser) + if(parser%sym/=sym_comma) exit + call scan(parser) + enddo + if(expect(parser,sym_close_attr)) return + endif + iserr=.false. + end function builtin_flags + + !====================================================== + ! Intrinsic procedure definition + !====================================================== + function intrinsic(parser) result(iserr) + type(parse_state),intent(inout):: parser + logical:: iserr + type(pm_ptr),target:: ptr + type(pm_ptr)::p,link + type(pm_reg),pointer:: reg + integer:: name,sym,opcode,opcode2,flags + reg=>pm_register(parser%context,'builtin',ptr) + iserr=.true. + + call scan(parser) + if(builtin_flags(parser,flags)) goto 999 + + if(parser%sym==sym_dot) then + call scan(parser) + flags=ior(flags,proccall_is_comm+proccall_is_general+proccall_is_ref) + endif + + if(.not.check_name(parser,name)) then + if(op(parser,name,.false.,.false.)) goto 999 + call push_sym_val(parser,name) + else + call push_sym_val(parser,name) + endif + + if(iand(flags,proccall_is_ref)==0) then + if(parser%sym==sym_pct) then + call scan(parser) + flags=ior(flags,proccall_is_comm) + elseif(parser%sym==sym_dash) then + call scan(parser) + flags=ior(flags,proccall_is_comm+proccall_is_general) + endif + endif + + ! Create full name: module!name + call push_sym(parser,& + -get_modl_name(parser%modl)) + ptr=top_val(parser) + name=ptr%offset + call push_sym(parser,name) + call name_vector(parser,parser%top-2) + + ! Link into list of delarations for this name + ptr=decl_entry(parser,int(ptr%offset),modl_proc,link) + call push_val(parser,link) + call push_val(parser,parser%modl) ! module + call push_num_val(parser,flags) ! flags + if(expect(parser,sym_open)) goto 999 + if(proc_sig(parser,iand(flags,proccall_is_comm)/=0)) return + + if(expect(parser,sym_colon)) goto 999 + if(parser%sym/=sym_string) then + call parse_error(parser,'Expected string operation name in "PM__intrinsic"') + goto 999 + endif + p=pm_dict_lookup(parser%context,parser%op_names,& + pm_type_val(parser%context,& + parser%lexval)) + if(pm_fast_isnull(p)) then + call parse_error(parser,'Bad intrinsic operation'//& + pm_value_as_string(parser%context,pm_type_val(parser%context,parser%lexval))) + goto 999 + endif + call scan(parser) + opcode=p%offset + + if(parser%sym==sym_open) then + call scan(parser) + if(expect(parser,sym_number)) goto 999 + p=pm_type_val(parser%context,parser%lexval) + opcode2=p%data%ln(p%offset) + if(expect(parser,sym_close)) goto 999 + elseif(parser%sym>=first_mode.and.parser%sym<=last_mode) then + opcode2=parser%sym + call scan(parser) + else + opcode2=0 + endif + + call push_num_val(parser,int(opcode)) + call push_num_val(parser,int(opcode2)) + call push_val(parser,pm_null_obj) + call push_null_val(parser) + call make_node(parser,sym_builtin,sysproc_num_args) + if(debug_parser) then + write(*,*) 'BUILTIN DECL>----------------' + call dump_parse_tree(parser%context,6,top_val(parser),2) + write(*,*) 'BI-DECL-------------' + endif + call add_proc_decl(parser,name,ptr) + iserr=.false. +999 call pm_delete_register(parser%context,reg) + contains + include 'fisnull.inc' + end function intrinsic + - !====================================================== - ! Built in procedure definition - !====================================================== function builtin(parser,opcode,opcode2,pdata,pflags) result(iserr) type(parse_state),intent(inout):: parser integer,intent(in):: opcode @@ -4967,7 +5497,7 @@ function builtin(parser,opcode,opcode2,pdata,pflags) result(iserr) endif if(parser%sym==sym_pct) then call scan(parser) - flags=ior(pflags,call_is_comm) + flags=ior(pflags,proccall_is_comm) else flags=pflags endif @@ -4987,13 +5517,13 @@ function builtin(parser,opcode,opcode2,pdata,pflags) result(iserr) call push_val(parser,parser%modl) ! module call push_num_val(parser,flags) ! flags if(expect(parser,sym_open)) goto 999 - if(proc_sig(parser)) return + if(proc_sig(parser,iand(flags,proccall_is_comm)/=0)) return call push_num_val(parser,int(opcode)) call push_num_val(parser,int(opcode2)) call push_val(parser,pdata) call push_null_val(parser) call make_node(parser,sym_builtin,sysproc_num_args) - if(debug_parser_extra) then + if(debug_parser) then write(*,*) 'BUILTIN DECL>----------------' call dump_parse_tree(parser%context,6,top_val(parser),2) write(*,*) 'BI-DECL-------------' @@ -5005,6 +5535,7 @@ function builtin(parser,opcode,opcode2,pdata,pflags) result(iserr) include 'fisnull.inc' end function builtin + !============================================================== ! Add top of stack as declaration of procedure name ! Stack must contain as top 2 entries @@ -5032,7 +5563,7 @@ end subroutine add_proc_decl !====================================================== ! Type declaration !====================================================== - function type_decl(parser) result(iserr) + function typ_decl(parser) result(iserr) type(parse_state):: parser logical:: iserr integer:: sym,m,n,name,basename,namein,base,nextra @@ -5042,7 +5573,7 @@ function type_decl(parser) result(iserr) integer:: sbase,svbase,pname sbase=parser%top svbase=parser%vtop - reg=>pm_register(parser%context,'type_decl',ptr) + reg=>pm_register(parser%context,'typ_decl',ptr) iserr=.true. nextra=0 sym=sym_includes @@ -5057,10 +5588,10 @@ function type_decl(parser) result(iserr) call push_val(parser,parser%modl) ! module ! Type parameters - if(type_params(parser,m)) goto 999 + if(typ_params(parser,m)) goto 999 params=top_val(parser) - ! <: typelist + ! in typelist if(parser%sym==sym_in) then call scan(parser) if(typ_list(parser,m)) return @@ -5075,7 +5606,7 @@ function type_decl(parser) result(iserr) call push_val(parser,link) ! [ : typelist ] - if(type_inclusions(parser,name)) goto 999 + if(typ_inclusions(parser,name)) goto 999 ! Body of declaration, either : ! struct or rec @@ -5084,19 +5615,13 @@ function type_decl(parser) result(iserr) if(parser%sym==sym_is) then sym=sym_is call scan(parser) - if(parser%sym==sym_struct.or.parser%sym==sym_rec) then - if(structrec(parser,params,basename,name,m)) goto 999 + if(parser%sym==sym_rec) then + if(rec(parser,params,basename,name,m)) goto 999 call make_node(parser,sym_list,1) m=1 elseif(parser%sym==sym_unique) then if(unique(parser,name)) goto 999 m=1 - elseif(parser%sym==sym_interface) then - call push_null_val(parser) - if(interface(parser,name,params)) goto 999 - m=0 - nextra=1 - sym=sym_interface else ! "type_list | ...type_list | type_list ..." sym=sym_includes @@ -5126,13 +5651,13 @@ function type_decl(parser) result(iserr) call push_null_val(parser) endif 10 continue - call make_node(parser,sym,typ_num_args+nextra) - if(debug_parser_extra) then + call make_node(parser,sym,type_num_args+nextra) + if(debug_parser) then write(*,*) 'TYPEDECL>----------------' call dump_parse_tree(parser%context,6,top_val(parser),2) write(*,*) 'END TYPEDECL-------------' endif - call add_type_decl(parser,name,ptr) + call add_typ_decl(parser,name,ptr) iserr=.false. 999 continue parser%top=sbase @@ -5142,12 +5667,12 @@ function type_decl(parser) result(iserr) include 'fisnull.inc' - end function type_decl + end function typ_decl !====================================================== ! Parameters to a type declaration !====================================================== - function type_params(parser,m) result(iserr) + function typ_params(parser,m) result(iserr) type(parse_state):: parser integer,intent(out):: m logical:: iserr @@ -5174,13 +5699,13 @@ function type_params(parser,m) result(iserr) call push_null_val(parser) endif iserr=.false. - end function type_params + end function typ_params !====================================================== ! : typelist !====================================================== - function type_inclusions(parser,name) result(iserr) + function typ_inclusions(parser,name) result(iserr) type(parse_state):: parser integer,intent(in):: name logical:: iserr @@ -5195,7 +5720,7 @@ function type_inclusions(parser,name) result(iserr) if(check_name(parser,namein)) then ! An in declaration creates an entry in the ! named parent type - call add_typein_decl(parser,namein,name) + call add_typ_in_decl(parser,namein,name) else call parse_error(parser,'Expecting type name') return @@ -5213,13 +5738,13 @@ function type_inclusions(parser,name) result(iserr) iserr=.false. contains include 'fisnull.inc' - end function type_inclusions + end function typ_inclusions !====================================================== ! Add a declaration that type 'namein' is ! included in type 'name' !====================================================== - subroutine add_typein_decl(parser,namein,name) + subroutine add_typ_in_decl(parser,namein,name) type(parse_state):: parser integer,intent(in):: namein,name type(pm_ptr):: ptrin @@ -5233,15 +5758,15 @@ subroutine add_typein_decl(parser,namein,name) call push_sym_val(parser,name) call make_node(parser,sym_type,1) call make_node(parser,sym_in,2) - call add_type_decl(parser,namein,ptrin) + call add_typ_decl(parser,namein,ptrin) contains include 'fisnull.inc' - end subroutine add_typein_decl + end subroutine add_typ_in_decl !====================================================== ! Add type declaration on top of vstack under name nam !====================================================== - subroutine add_type_decl(parser,nam,p) + subroutine add_typ_decl(parser,nam,p) type(parse_state):: parser integer,intent(in):: nam type(pm_ptr),intent(in):: p @@ -5269,7 +5794,7 @@ subroutine add_type_decl(parser,nam,p) endif contains include 'fisnull.inc' - end subroutine add_type_decl + end subroutine add_typ_decl !====================================================== ! type .. is unique @@ -5313,13 +5838,13 @@ end function unique !====================================================== ! Structure or record declaration !====================================================== - recursive function structrec(parser,params,basename,typname,nargs) result(iserr) + recursive function rec(parser,params,basename,typname,nargs) result(iserr) type(parse_state),intent(inout):: parser type(pm_ptr),intent(in):: params integer,intent(in):: basename,typname,nargs logical:: iserr integer:: i,tag,name,sym,base,vbase,line,pos,n,flags - logical:: hasuse + logical:: hasvar type(pm_ptr):: p iserr=.true. call make_qualified_name(parser,basename) @@ -5330,46 +5855,43 @@ recursive function structrec(parser,params,basename,typname,nargs) result(iserr) base=parser%top vbase=parser%vtop flags=0 + hasvar=.false. if(parser%sym==sym_caret) then call scan(parser) - flags=pm_typ_is_soa + flags=pm_type_is_soa endif if(parser%sym==sym_open_brace) then call scan(parser) else - if(parser%sym==sym_dotdotdot) then + if(parser%sym==sym_var) then + hasvar=.true. call scan(parser) else call parse_error(parser,& - 'Expected "{" or "..."') + 'Expected "{" or "var"') endif if(expect(parser,sym_open_brace)) return endif call push_sym(parser,tag) - hasuse=.false. n=0 do - if(parser%sym==sym_use) then + if(parser%sym==sym_var) then + if(hasvar) then + call parse_error(parser,'Cannot have "var" element in "rec var{...}"') + endif call scan(parser) if(check_name_no_repeat(parser,name,base+1)) then call push_sym(parser,-name) - hasuse=.true. else call parse_error(parser,& - 'Expected name of '//sym_names(sym)//' element') + 'Expected name of element') return endif - elseif(parser%sym==sym_proc) then - if(method(parser,typname,params,base)) return - n=n+1 - if(parser%sym/=sym_comma) exit - call scan(parser) - cycle elseif(check_name_no_repeat(parser,name,base+1)) then - call push_sym(parser,name) + call push_sym(parser,merge(-name,name,hasvar)) else call parse_error(parser,& - 'Expected name of '//sym_names(sym)//' element') + 'Expected name of element') return endif n=n+1 @@ -5379,16 +5901,16 @@ recursive function structrec(parser,params,basename,typname,nargs) result(iserr) else call push_null_val(parser) endif - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call scan(parser) if(expr(parser)) return - call make_node(parser,sym_define,2) + call make_node(parser,sym_assign,2) endif if(parser%sym/=sym_comma) exit call scan(parser) enddo - ! Structure definition record is: list{type},tag,typname,nargs,params,keys + ! Rec definition record is: list{type},tag,typname,nargs,params,keys call make_node(parser,sym_list,parser%vtop-vbase) call name_vector(parser,base) !if(hasuse) parser%vstack(parser%vtop)%offset=-parser%vstack(parser%vtop)%offset @@ -5396,110 +5918,14 @@ recursive function structrec(parser,params,basename,typname,nargs) result(iserr) call push_num_val(parser,nargs) call push_val(parser,params) call push_null_val(parser) - if(hasuse) flags=ior(flags,pm_typ_has_embedded) + ! if(hasuse) flags=ior(flags,pm_type_has_embedded) call push_num_val(parser,flags) call make_node(parser,sym,7) if(expect(parser,sym_close_brace)) return iserr=.false. contains include 'fisnull.inc' - end function structrec - - !====================================================== - ! Method definition proc name(...) { ... } - ! in struct, rec or interface - !====================================================== - recursive function method(parser,typname,params,base) result(iserr) - type(parse_state),intent(inout):: parser - integer,intent(in):: typname,base - type(pm_ptr),intent(in):: params - logical:: iserr - type(pm_ptr):: p - integer:: mname,name,tname,pbase - logical:: iscomm - iserr=.true. - call scan(parser) - if(check_name_no_repeat(parser,name,base+1)) then - p=parser%modl%data%ptr(parser%modl%offset+modl_name) - mname=-p%offset - call push_sym(parser,mname) - call push_sym(parser,typname) - call push_sym(parser,name) - call name_vector(parser,parser%top-3) - tname=parser%vstack(parser%vtop)%offset - parser%vtop=parser%vtop-1 - pbase=parser%top - iscomm=parser%sym==sym_pct - if(proctyp(parser,typname,params,.true.)) return - if(iscomm) call push_back(parser,sym_pct) - if(parser%sym/=sym_open_brace.and.parser%sym/=sym_colon) then - if(expect(parser,sym_open_brace)) return - endif - if(proc_decl(parser,tname,pbase)) return - call push_sym_val(parser,tname) - call make_node(parser,sym_proc,1) - call make_node(parser,sym_define,2) - parser%top=pbase - call push_sym(parser,name) - else - call parse_error(parser,'Expected method name') - return - endif - iserr=.false. - end function method - - !====================================================== - ! interface { ... } - !====================================================== - recursive function interface(parser,tname,params) result(iserr) - type(parse_state),intent(inout):: parser - integer,intent(in):: tname - type(pm_ptr),intent(in):: params - logical:: iserr - logical isvar - integer:: i,m,base,vbase,name,line,pos - type(pm_ptr):: tag - call get_sym_pos(parser,line,pos) - iserr=.true. - call scan(parser) - if(expect(parser,sym_open_brace)) return - base=parser%top - vbase=parser%vtop - call make_qualified_name(parser,tname) - tag=pop_val(parser) - call push_sym(parser,int(tag%offset)) - do - if(parser%sym==sym_proc) then - call scan(parser) - if(check_name_no_repeat(parser,name,base+1)) then - call push_sym(parser,name) - else - call parse_error(parser,'Expected method name') - return - endif - if(proctyp(parser,tname,params)) return - else - isvar=parser%sym==sym_var - if(isvar.or.parser%sym==sym_const) call scan(parser) - if(check_name_no_repeat(parser,name,base+1)) then - call push_sym(parser,merge(-name,name,isvar)) - else - call parse_error(parser,'Expected element name') - return - endif - if(expect(parser,sym_colon)) return - if(typ(parser)) return - endif - if(parser%sym==sym_close_brace) exit - if(expect(parser,sym_comma)) return - enddo - call make_node(parser,sym_list,parser%vtop-vbase) - call name_vector(parser,base) - if(expect(parser,sym_close_brace)) return - call make_node_at(parser,sym_interface,2,line,pos) - iserr=.false. - end function interface - + end function rec !====================================================== ! Parameter declarations @@ -5513,7 +5939,7 @@ function param_decl(parser) result(iserr) do call push_null_val(parser) if(.not.check_name(parser,name)) return - if(expect(parser,sym_define)) return + if(expect(parser,sym_assign)) return serror=parser%error_count call xexpr(parser) if(parser%error_count>serror) return @@ -5536,13 +5962,15 @@ subroutine decl(parser,is_root_module) integer:: dt type(pm_ptr):: old,p integer:: m,sym,name,name2,base,top,kind,line,pos - integer:: serror + integer:: serror,num_tests logical:: ok - call push_sym_val(parser,sym_pm_system) - call push_val(parser,parser%sysmodl) - call push_null_val(parser) - call make_node(parser,sym_use,3) - call new_import(parser,sym_pm_system,pop_val(parser)) + if(.not.(parser%modl==parser%sysmodl)) then + call push_sym_val(parser,sym_pm_system) + call push_val(parser,parser%sysmodl) + call push_null_val(parser) + call make_node(parser,sym_use,3) + call new_import(parser,sym_pm_system,pop_val(parser)) + endif do while(parser%sym==sym_use) call use_stmt if(parser%sym==sym_semi) then @@ -5558,23 +5986,36 @@ subroutine decl(parser,is_root_module) call skip_past_error(parser,.false.) endif enddo + num_tests=0 do select case(parser%sym) case(sym_proc) - call scan(parser) - if(parser%sym==sym_open) then - call push_back(parser,sym_proc) - exit - else - call push_back(parser,sym_proc) - endif if(proc_decl(parser)) goto 999 case(sym_type) - if(type_decl(parser)) goto 999 + if(typ_decl(parser)) goto 999 case(sym_param) if(param_decl(parser)) goto 999 case(sym_test) if(test_stmt(parser)) goto 999 + num_tests=num_tests+1 + case(sym_pm_if_compiling) + call scan(parser) + if(.not.pm_is_compiling) then + do while(parser%sym/=sym_pm_else) + call scan(parser) + enddo + call scan(parser) + endif + case(sym_pm_else) + call scan(parser) + do while(parser%sym/=sym_pm_endif) + call scan(parser) + enddo + call scan(parser) + case(sym_pm_endif) + call scan(parser) + case(sym_pm_intrinsic) + if(intrinsic(parser)) goto 999 case default exit end select @@ -5589,10 +6030,13 @@ subroutine decl(parser,is_root_module) call skip_past_error(parser,.false.) enddo if(is_root_module) then - call stmt_list(parser) - elseif(parser%sym/=sym_eof) then + call stmt_list(parser,num_to_include=num_tests) + else + if(parser%sym/=sym_eof) then call parse_error(parser,& - 'Library module cannot contain non-"debug" statement') + 'A library module cannot contain executable statements apart from "test"') + end if + call push_null_val(parser) end if if(parser%sym/=sym_eof) then call parse_error(parser,'Expected end of module') @@ -5750,7 +6194,7 @@ end subroutine decl recursive subroutine skip_past_error(parser,expr) type(parse_state),intent(inout):: parser logical,intent(in):: expr - if(debug_parser_extra) write(*,*) 'Skipping',expr + if(debug_parser) write(*,*) 'Skipping',expr do if(expr) then if(parser%sym<=num_sym.and.parser%sym>last_expr) then @@ -5759,7 +6203,7 @@ recursive subroutine skip_past_error(parser,expr) endif do while(parser%sym/=sym_eof.and.(parser%sym>num_sym.or.& parser%sym<=last_expr)) - if(parser%sym==sym_define) then + if(parser%sym==sym_assign) then call push_back(parser,sym_array) exit endif @@ -5781,7 +6225,7 @@ recursive subroutine skip_past_error(parser,expr) exit endif enddo - if(debug_parser_extra) write(*,*) 'Skipped' + if(debug_parser) write(*,*) 'Skipped' end subroutine skip_past_error !====================================================== @@ -5823,6 +6267,16 @@ subroutine drop_val(parser) parser%vtop=parser%vtop-1 end subroutine drop_val + !====================================================== + ! Replace second-to-top value on stack with top value + ! decreasing stack ptr by 1 + !====================================================== + subroutine push_down_val(parser) + type(parse_state),intent(inout):: parser + parser%vtop=parser%vtop-1 + parser%vstack(parser%vtop)=parser%vstack(parser%vtop+1) + end subroutine push_down_val + !====================================================== ! Top of value stack !====================================================== @@ -5887,6 +6341,16 @@ subroutine push_num_val(parser,n) include 'ftiny.inc' end subroutine push_num_val + !====================================================== + ! Pop a tiny integer from the value stack + !====================================================== + function pop_num_val(parser) result(num) + type(parse_state),intent(inout):: parser + integer:: num + num=parser%vstack(parser%vtop)%offset + parser%vtop=parser%vtop-1 + end function pop_num_val + !====================================================== ! Push token on to value stack !====================================================== @@ -6006,7 +6470,7 @@ subroutine make_node_at(parser,typeno,n,line,pos) val=pm_fast_newnc(parser%context,pm_pointer,n+5) - if(debug_parser_extra) then + if(debug_parser) then write(*,*) 'make node:',sym_names(typeno),& parser%vtop,n,val%data%esize endif @@ -6036,7 +6500,7 @@ subroutine make_node_at(parser,typeno,n,line,pos) parser%vstack(parser%vtop)=val parser%vline(parser%vtop)=line parser%vchar(parser%vtop)=pos - if(debug_parser_extra) then + if(debug_parser) then write(*,*) '------New node------',n+5 call dump_parse_tree(parser%context,6,val,2) write(*,*) '--------------------' @@ -6076,10 +6540,10 @@ subroutine new_modl(parser,name) modl=pm_dict_lookup(parser%context,parser%modl_dict,& nameval) if(pm_fast_isnull(modl)) then - if(pm_main_process.and.name/=sym_pm_system) then + if(pm_main_process.and.name/=sym_pm_system.and..false.) then call pm_name_string(parser%context,& int(nameval%offset),str) - call pm_module_filename(str,str2) + call pm_module_filename(str,str2,pm_opts%lib_path_set,pm_opts%lib_path) inquire(file=trim(str2),exist=ok) if(.not.ok) then call parse_error(parser,'module does not correspond to a source file, need: '//& @@ -6244,318 +6708,6 @@ function is_import(parser,name) result(ok) end function is_import - !====================================================== - ! Check that a node is valid - !====================================================== - subroutine check_node(node) - type(pm_ptr),intent(in):: node - if(pm_fast_vkind(node)==pm_pointer) then - if(node%data%ptr(node%offset)%offset/=9876) then - call pm_panic('Bad parse node') - endif - endif - contains - include 'fvkind.inc' - end subroutine check_node - - !======================================================= - ! Check that a node is valid and not a tiny int or value - !======================================================= - subroutine check_ptr_node(node) - type(pm_ptr),intent(in):: node - if(pm_fast_vkind(node)==pm_pointer) then - if(node%data%ptr(node%offset)%offset/=9876) then - call pm_panic('Bad parse node') - endif - else - call pm_panic('not ptr parser node') - endif - contains - include 'fvkind.inc' - end subroutine check_ptr_node - - !====================================================== - ! Return symbol associated with a node - !====================================================== - function node_sym(node) result(n) - type(pm_ptr),intent(in):: node - integer:: n - if(pm_fast_vkind(node)/=pm_pointer) then - n=0 - else - if(pm_debug_checks) call check_node(node) - n=node%data%ptr(node%offset+node_symbol)%offset - endif - contains - include 'fvkind.inc' - end function node_sym - - !====================================================== - ! Number of arguments in a node - !====================================================== - function node_numargs(node) result(n) - type(pm_ptr),intent(in):: node - integer:: n - if(pm_fast_vkind(node)/=pm_pointer) then - n=0 - else - if(pm_debug_checks) call check_node(node) - n=pm_fast_esize(node)-node_args+1 - endif - contains - include 'fesize.inc' - include 'fvkind.inc' - end function node_numargs - - !====================================================== - ! Return n-th argument of a node - !====================================================== - function node_arg(node,n) result(p) - type(pm_ptr),intent(in):: node - integer,intent(in):: n - type(pm_ptr):: p - if(pm_debug_checks) then - call check_ptr_node(node) - if(n<0.or.node_args+n-1>pm_fast_esize(node)) & - call pm_panic('node_arg - n out of range') - endif - p=node%data%ptr(node%offset+node_args+n-1) - contains - include 'fesize.inc' - end function node_arg - - !====================================================== - ! Return n-th argument of a node as a number - ! (that argument should be tiny-int) - !====================================================== - function node_num_arg(node,n) result(num) - type(pm_ptr),intent(in):: node - integer,intent(in):: n - integer:: num - type(pm_ptr):: p - if(pm_debug_checks) then - call check_ptr_node(node) - if(n<0.or.node_args+n-1>pm_fast_esize(node)) & - call pm_panic('node_arg - n out of range') - endif - p=node%data%ptr(node%offset+node_args+n-1) - num=p%offset - contains - include 'fesize.inc' - end function node_num_arg - - !====================================================== - ! Return n-th slot in a node (not the same as argument) - !====================================================== - function node_get(node,n) result(p) - type(pm_ptr),intent(in):: node - integer,intent(in):: n - type(pm_ptr):: p - if(pm_debug_checks) then - call check_ptr_node(node) - if(n<0.or.n>pm_fast_esize(node)) & - call pm_panic('node_get - n out of range') - endif - p=node%data%ptr(node%offset+n) - contains - include 'fesize.inc' - end function node_get - - !====================================================== - ! Return n-th slot in a node (not the same as argument) - ! as a number (must be tiny int) - !====================================================== - function node_get_num(node,n) result(num) - type(pm_ptr),intent(in):: node - integer,intent(in):: n - integer:: num - type(pm_ptr):: p - if(pm_debug_checks) then - call check_ptr_node(node) - if(n<0.or.n>pm_fast_esize(node)) & - call pm_panic('node_get_num - n out of range') - endif - p=node%data%ptr(node%offset+n) - num=p%offset - contains - include 'fesize.inc' - end function node_get_num - - !====================================================== - ! Set n-th slot in a node (not the same as argument) - ! to a number (tiny int) - !====================================================== - subroutine node_set_num(node,n,num) - type(pm_ptr),intent(in):: node - integer,intent(in):: n - integer,intent(in):: num - if(pm_debug_checks) then - call check_ptr_node(node) - if(n<0.or.n>pm_fast_esize(node)) & - call pm_panic('node_get_num - n out of range') - endif - node%data%ptr(node%offset+n)%offset=num - contains - include 'fesize.inc' - end subroutine node_set_num - - !====================================================== - ! Get the line number associated with a node - !====================================================== - function node_get_lineno(node) result(n) - type(pm_ptr),intent(in):: node - integer:: n - if(pm_debug_checks) & - call check_ptr_node(node) - n=node%data%ptr(node%offset+node_lineno)%offset - end function node_get_lineno - - !====================================================== - ! Get the character position (in source) associated - ! with a node - !====================================================== - function node_get_charno(node) result(n) - type(pm_ptr),intent(in):: node - integer:: n - if(pm_debug_checks) & - call check_ptr_node(node) - n=node%data%ptr(node%offset+node_charno)%offset - end function node_get_charno - - !====================================================== - ! Get the module object associated with a node - !====================================================== - function node_get_modl(node) result(modl) - type(pm_ptr),intent(in):: node - type(pm_ptr):: modl - if(pm_debug_checks) & - call check_ptr_node(node) - modl=node%data%ptr(node%offset+node_modl) - contains - include 'fvkind.inc' - end function node_get_modl - - !====================================================== - ! Get the module name associated with a node - !====================================================== - function node_get_modl_name(node) result(name) - type(pm_ptr),intent(in):: node - integer:: name - type(pm_ptr):: modl - if(pm_debug_checks) & - call check_ptr_node(node) - modl=node_get_modl(node) - name=modl%data%ptr(modl%offset+modl_name)%offset - end function node_get_modl_name - - - !====================================================== - ! Dump a module (debugging) - !====================================================== - subroutine dump_module(context,iunit,ptr) - type(pm_context),pointer:: context - integer,intent(in):: iunit - type(pm_ptr),intent(in):: ptr - character(len=100):: str - character(len=7),dimension(modl_include:modl_param):: dnames = & - (/ & - 'include',& - 'proc ',& - 'type ',& - 'param '/) - integer:: i,j,k,m - type(pm_ptr):: keys,vals,p - call pm_name_string(context,int(ptr%data%ptr(ptr%offset+1)%offset),str) - write(iunit,*) 'Module: ',trim(str) - write(iunit,*) 'Stmts:' - call dump_parse_tree(context,iunit,ptr%data%ptr(ptr%offset+modl_stmts),2) - do k=0,modl_local,modl_local - if(k==modl_local) then - write(iunit,*) 'Local:' - m=modl_proc - else - ! m=modl_include - m=modl_proc - endif - do j=m,modl_param - write(iunit,*) dnames(j),& - marked(ptr%data%ptr(ptr%offset+j+k)),'::' - keys=pm_dict_keys(context,ptr%data%ptr(ptr%offset+j+k)) - vals=pm_dict_vals(context,ptr%data%ptr(ptr%offset+j+k)) - write(iunit,*) marked(keys),marked(vals) - do i=1,pm_dict_size(context,ptr%data%ptr(ptr%offset+j+k)) - call pm_name_string(context,& - int(keys%data%ptr(keys%offset+i-1)%offset),str) - write(iunit,*) ' ',trim(str),'::' - write(iunit,*) marked(vals%data%ptr(vals%offset+i-1)) - p=vals%data%ptr(vals%offset+i-1) - call dump_parse_tree(context,iunit,& - p%data%ptr(p%offset),2) - enddo - enddo - enddo - end subroutine dump_module - - !====================================================== - ! Dump a parser tree (debugging) - !====================================================== - recursive subroutine dump_parse_tree(context,iunit,ptr,depth) - type(pm_context),pointer:: context - integer,intent(in):: iunit - type(pm_ptr),intent(in):: ptr - integer,intent(in):: depth - integer:: i, sym - character(len=80),parameter:: spaces = ' ' - character(len=100):: str - if(depth>30) then - write(iunit,*) spaces(:depth*2),'>>>' - return - endif - if(pm_fast_vkind(ptr)==pm_pointer) then - if(ptr%data%ptr(ptr%offset)%offset/=9876) then - if(ptr%data%ptr(ptr%offset)%offset==9875) then - write(iunit,*) spaces(1:depth*2),'REUSED NODE',& - ptr%offset,ptr%data%hash,ptr%data%esize - else - write(iunit,*) spaces(1:depth*2),'INVALID NODE' - return - endif - endif - sym=ptr%data%ptr(ptr%offset+1)%offset - if(sym>0.and.sym<=num_syshook) then - write(iunit,*) spaces(1:depth*2),sym_names(sym),ptr%data%esize,& - 'line',node_get_lineno(ptr),& - 'Marked:',marked(ptr),& - ptr%data%hash,ptr%offset,ptr%offset+ptr%data%esize - else if(sym==0) then - call pm_name_string(context,int(ptr%data%ptr(ptr%offset+1)%offset),str) - write(iunit,*) spaces(1:depth*2),'Module: ',trim(str) - return - else - write(iunit,*) spaces(1:depth*2),'???',trim(pm_name_as_string(context,sym)) - return - endif - do i=node_args,ptr%data%esize - call dump_parse_tree(context,iunit,ptr%data%ptr(ptr%offset+i),& - depth+1) - enddo - else if(pm_fast_isnull(ptr)) then - write(iunit,*) spaces(1:depth*2),'NULL' - else if(pm_fast_isname(ptr)) then - call pm_name_string(context,int(ptr%offset),str) - write(iunit,*) spaces(1:depth*2),'Name:',trim(str) - else if(pm_fast_istiny(ptr)) then - write(iunit,*) spaces(1:depth*2),'Tiny number:',ptr%offset - else - call pm_dump_tree(context,iunit,ptr,depth) - endif - contains - include 'fvkind.inc' - include 'fisnull.inc' - include 'fisname.inc' - include 'fistiny.inc' - end subroutine dump_parse_tree - !====================================================== ! Syntax error - print message ! and stop building parse tree @@ -6568,7 +6720,7 @@ subroutine parse_error(parser,emess) character(len=7):: lbuffer,lbuffer2 integer:: i,n if(pm_main_process) then - if(debug_parser_extra) write(*,*) '*****Error::',trim(emess) + if(debug_parser) write(*,*) '*****Error::',trim(emess) call pm_name_string(parser%context,& int(parser%modl%data%ptr(parser%modl%offset+modl_name)%offset),modname) write(lbuffer,'(I7)') parser%sym_lineno @@ -6599,12 +6751,12 @@ subroutine parse_error(parser,emess) caret=" " caret(n:n)="!" if(pm_opts%colour) then - write(*,'(3X,A,A67,A)') pm_error_start,caret,pm_error_end + write(*,'(3X,A,A67,A)') pm_opts%error_start,caret,pm_error_end else write(*,'(3X,A67)') caret endif 10 continue - write(*,'(A,A)') trim(pm_opts%error),trim(emess) + write(*,'(A,X,A)') trim(pm_opts%error),trim(emess) endif parser%error_count=parser%error_count+1 if(parser%error_count>max_errors) then diff --git a/src/symbol.f90 b/src/symbol.f90 index 6d0d86c..0b9528d 100755 --- a/src/symbol.f90 +++ b/src/symbol.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -54,21 +54,24 @@ module pm_symbol integer,parameter:: sym_ddollar = 10 integer,parameter:: sym_comma = 11 integer,parameter:: sym_dot = 12 - integer,parameter:: sym_assign = 13 - integer,parameter:: sym_underscore = 14 - integer,parameter:: sym_open_attr = 15 - integer,parameter:: sym_close_attr = 16 - integer,parameter:: sym_query = 17 - integer,parameter:: sym_arrow = 18 - integer,parameter:: sym_pct = 19 + integer,parameter:: sym_underscore = 13 + integer,parameter:: sym_open_attr = 14 + integer,parameter:: sym_close_attr = 15 + integer,parameter:: sym_query = 16 + integer,parameter:: sym_arrow = 17 + integer,parameter:: sym_pct = 18 + integer,parameter:: sym_pling = 19 integer,parameter:: sym_dash = 20 integer,parameter:: sym_caret = 21 integer,parameter:: sym_dcaret = 22 integer,parameter:: sym_dcolon = 23 - integer,parameter:: sym_define = 24 + integer,parameter:: sym_assign = 24 integer,parameter:: sym_cond = 25 - integer,parameter:: sym_string = 26 - integer,parameter:: sym_number = 27 + integer,parameter:: sym_move = 26 + integer,parameter:: sym_move_all = 27 + integer,parameter:: sym_swap = 28 + integer,parameter:: sym_string = 29 + integer,parameter:: sym_number = 30 ! Operators integer,parameter:: sym1 = sym_number @@ -79,86 +82,90 @@ module pm_symbol integer,parameter:: sym_ustar = sym1 + 5 integer,parameter:: sym_uhash = sym1 + 6 - integer,parameter:: sym_from_range = sym1 + 7 - integer,parameter:: first_operator = sym_from_range - integer,parameter:: sym_to_range = sym1 + 8 - integer,parameter:: sym2 = sym_to_range - integer,parameter:: sym_concat = sym2 + 1 - integer,parameter:: sym_eq = sym2 + 2 - integer,parameter:: sym_ne = sym2 + 3 - integer,parameter:: sym_ge = sym2 + 4 - integer,parameter:: sym_gt = sym2 + 5 - integer,parameter:: sym_plus = sym2 + 6 - integer,parameter:: sym_minus = sym2 + 7 - integer,parameter:: sym_mult = sym2 + 8 - integer,parameter:: sym_divide = sym2 + 9 + integer,parameter:: sym2 = sym_uhash + + integer,parameter:: sym_plus = sym2 + 1 + integer,parameter:: first_operator=sym_plus + integer,parameter:: sym_minus = sym2 + 2 + integer,parameter:: sym_mult = sym2 + 3 + integer,parameter:: sym_divide = sym2 + 4 + integer,parameter:: sym_concat = sym2 + 5 + integer,parameter:: first_non_idx_operator = sym_concat + integer,parameter:: sym_eq = sym2 + 6 + integer,parameter:: sym_ne = sym2 + 7 + integer,parameter:: sym_ge = sym2 + 8 + integer,parameter:: sym_gt = sym2 + 9 integer,parameter:: sym_pow = sym2 + 10 integer,parameter:: sym_dotdot = sym2 + 11 integer,parameter:: sym_bar = sym2 + 12 integer,parameter:: sym_hash= sym2 + 13 integer,parameter:: sym_amp = sym2 + 14 - integer,parameter:: sym_pling = sym2 + 15 + integer,parameter:: sym_tilde = sym2 + 15 ! These keywords and symbols are binary operators - integer,parameter:: first_key = sym_pling + integer,parameter:: first_key = sym_tilde integer,parameter:: sym_in = first_key + 1 - integer,parameter:: sym_and = first_key + 2 - integer,parameter:: sym_or = first_key + 3 - integer,parameter:: sym_xor = first_key + 4 + integer,parameter:: sym_not_in = first_key + 2 + integer,parameter:: sym_and = first_key + 3 + integer,parameter:: sym_or = first_key + 4 integer,parameter:: sym_shift = first_key + 5 integer,parameter:: sym_fmt = first_key + 6 integer,parameter:: sym_by = first_key + 7 integer,parameter:: sym_mod = first_key + 8 - integer,parameter:: sym_except = first_key + 9 - integer,parameter:: sym_includes = first_key + 10 - integer,parameter:: sym_ortho = first_key + 11 - integer,parameter:: sym_is = first_key + 12 - integer,parameter:: sym_as = first_key + 13 - - ! Unary operators - integer,parameter:: sym_not = first_key + 14 + integer,parameter:: sym_div = first_key + 9 + integer,parameter:: sym_except = first_key + 10 + integer,parameter:: sym_includes = first_key + 11 + integer,parameter:: sym_not_includes = first_key + 12 + integer,parameter:: sym_ortho = first_key + 13 + integer,parameter:: sym_is = first_key + 14 + integer,parameter:: sym_is_not = first_key + 15 + integer,parameter:: sym_not = first_key + 16 integer,parameter:: last_operator = sym_not ! Statement / expression general keywords - integer,parameter:: sym_null = last_operator + 1 - integer,parameter:: sym_key = last_operator + 2 - integer,parameter:: sym_arg = last_operator + 3 - integer,parameter:: sym_true = last_operator + 4 - integer,parameter:: sym_false = last_operator + 5 - integer,parameter:: sym_struct = last_operator + 6 - integer,parameter:: sym_rec = last_operator + 7 - integer,parameter:: sym_any = last_operator + 8 - integer,parameter:: sym_present = last_operator + 9 - integer,parameter:: sym_unique = last_operator + 10 - integer,parameter:: sym_fix = last_operator + 11 - integer,parameter:: sym_new = last_operator + 12 - integer,parameter:: sym_of = last_operator + 13 - integer,parameter:: sym_bounds = last_operator + 14 - integer,parameter:: last_expr = sym_bounds + integer,parameter:: sym_as = last_operator+1 + integer,parameter:: sym_null = last_operator + 2 + integer,parameter:: sym_true = last_operator + 3 + integer,parameter:: sym_false = last_operator + 4 + integer,parameter:: sym_struct = last_operator + 5 + integer,parameter:: sym_rec = last_operator + 6 + integer,parameter:: sym_any = last_operator + 7 + integer,parameter:: sym_present = last_operator + 8 + integer,parameter:: sym_unique = last_operator + 9 + integer,parameter:: sym_fix = last_operator + 10 + integer,parameter:: sym_new = last_operator + 11 + integer,parameter:: sym_when = last_operator + 12 + integer,parameter:: last_expr = sym_when integer,parameter:: last_word = last_expr ! Modes - integer,parameter:: sym_private = last_word + 1 - integer,parameter:: first_mode = sym_private - integer,parameter:: sym_invar = last_word + 2 - integer,parameter:: sym_complete = last_word + 3 - integer,parameter:: sym_universal= last_word + 4 - integer,parameter:: sym_local = last_word + 5 - integer,parameter:: sym_partial = last_word + 6 - integer,parameter:: sym_coherent = last_word + 7 - integer,parameter:: sym_chan = last_word + 8 - integer,parameter:: sym_mirrored = last_word + 9 - integer,parameter:: sym_shared = last_word + 10 - integer,parameter:: last_mode = sym_shared - integer,parameter:: last_key = sym_shared + integer,parameter:: sym_individual = last_word + 1 + integer,parameter:: first_mode = sym_individual + integer,parameter:: sym_connected = last_word + 2 + integer,parameter:: sym_local = last_word + 3 + integer,parameter:: sym_global = last_word + 4 + integer,parameter:: sym_complete = last_word + 5 + + integer,parameter:: sym_private = last_word + 6 + integer,parameter:: sym_chan = last_word + 7 + integer,parameter:: sym_nhd = last_word + 8 + integer,parameter:: sym_indexed = last_word + 9 + integer,parameter:: sym_joint = last_word + 10 + integer,parameter:: sym_uniform = last_word + 11 + integer,parameter:: sym_invar = last_word + 12 + integer,parameter:: sym_shared = last_word + 13 + + integer,parameter:: last_mode = sym_shared + integer,parameter:: last_key = sym_shared ! Declaration keywords - integer,parameter:: sym_use = last_key + 1 - integer,parameter:: first_decl = sym_use - integer,parameter:: sym_proc = last_key + 2 - integer,parameter:: sym_param = last_key + 3 - integer,parameter:: sym_type = last_key + 4 - integer,parameter:: sym_render = last_key + 5 + integer,parameter:: sym_package = last_key +1 + integer,parameter:: first_decl = sym_package + integer,parameter:: sym_use = last_key + 2 + integer,parameter:: sym_proc = last_key + 3 + integer,parameter:: sym_param = last_key + 4 + integer,parameter:: sym_type = last_key + 5 + integer,parameter:: sym_render = last_key + 6 integer,parameter:: last_decl = sym_render ! Statement keywords @@ -180,27 +187,27 @@ module pm_symbol integer,parameter:: sym_return = last_decl + 14 integer,parameter:: sym_also = last_decl + 15 integer,parameter:: sym_do = last_decl + 16 - integer,parameter:: sym_nhd = last_decl + 17 + integer,parameter:: sym_yield = last_decl + 17 integer,parameter:: sym_test = last_decl + 18 integer,parameter:: sym_default = last_decl + 19 integer,parameter:: sym_task = last_decl + 20 - integer,parameter:: sym_extern = last_decl + 21 + integer,parameter:: sym_assignment = last_decl + 21 integer,parameter:: sym_var = last_decl + 22 integer,parameter:: sym_const = last_decl + 23 integer,parameter:: sym_each = last_decl + 24 integer,parameter:: sym_where = last_decl + 25 - integer,parameter:: sym_with = last_decl + 26 - integer,parameter:: sym_conc = last_decl + 27 + integer,parameter:: sym_split = last_decl + 26 + integer,parameter:: sym_forall = last_decl + 27 integer,parameter:: sym_interface = last_decl + 28 integer,parameter:: sym_if_invar = last_decl + 29 integer,parameter:: sym_while_invar = last_decl + 30 integer,parameter:: sym_until_invar = last_decl + 31 integer,parameter:: sym_foreach_invar = last_decl + 32 integer,parameter:: sym_switch_invar = last_decl + 33 - integer,parameter:: sym_proceed= last_decl + 34 - integer,parameter:: sym_after= last_decl + 35 - integer,parameter:: sym_any_invar= last_decl + 36 - integer,parameter:: last_resv = sym_any_invar + integer,parameter:: sym_any_invar= last_decl + 34 + integer,parameter:: sym_all = last_decl + 35 + integer,parameter:: sym_sync_while = last_decl + 36 + integer,parameter:: last_resv = sym_sync_while ! Names used by internal system integer,parameter:: sym_pm_send = last_resv + 1 @@ -217,10 +224,28 @@ module pm_symbol integer,parameter:: sym_pm_dref_shared_slice = last_resv + 11 integer,parameter:: sym_pm_dref_here = last_resv + 12 integer,parameter:: sym_pm_ref = last_resv + 13 - integer,parameter:: sym_pm_head_node = last_resv + 14 - integer,parameter:: sym_pm_do_at = last_resv + 15 - integer,parameter:: sym_pm_do = last_resv + 16 - integer,parameter:: last_stmt = sym_pm_do + integer,parameter:: sym_pm_dref_any = last_resv + 14 + integer,parameter:: sym_pm_dref_any_slice = last_resv + 15 + integer,parameter:: sym_pm_head_node = last_resv + 16 + integer,parameter:: sym_pm_do_at = last_resv + 17 + integer,parameter:: sym_pm_do = last_resv + 18 + integer,parameter:: sym_pm_intrinsic = last_resv + 19 + integer,parameter:: sym_pm_each_index = last_resv + 20 + integer,parameter:: sym_pm_if_compiling = last_resv + 21 + integer,parameter:: sym_pm_else = last_resv + 22 + integer,parameter:: sym_pm_endif = last_resv + 23 + integer,parameter:: sym_pm_yield = last_resv + 24 + integer,parameter:: sym_pm_set_dotdotdot = last_resv + 25 + integer,parameter:: sym_pm_for = last_resv + 26 + integer,parameter:: sym_pm_foreach = last_resv + 27 + integer,parameter:: sym_pm_over = last_resv + 28 + integer,parameter:: sym_pm_context = last_resv + 29 + integer,parameter:: sym_pm_shared = last_resv + 30 + integer,parameter:: sym_pm_shared_always = last_resv + 31 + integer,parameter:: sym_pm_chan = last_resv + 32 + integer,parameter:: sym_pm_chan_always = last_resv + 33 + integer,parameter:: sym_pm_list = last_resv + 34 + integer,parameter:: last_stmt = sym_pm_list integer,parameter:: num_sym = last_stmt ! Non-reserved words that the compiler needs to know about @@ -245,12 +270,26 @@ module pm_symbol integer,parameter:: sym_cond_attr = num_sym + 14 integer,parameter:: sym_uncond = num_sym + 15 integer,parameter:: sym_ignore_rules = num_sym + 16 - + integer,parameter:: sym_keep_literals = num_sym + 17 + ! filesystem - integer,parameter:: sym_filesystem = num_sym + 17 + integer,parameter:: sym_filesystem = num_sym + 18 + + ! Attributes for intrinsics + integer,parameter:: sym_proc_is_generator = num_sym + 19 + integer,parameter:: sym_proc_is_impure = num_sym + 20 + integer,parameter:: sym_proc_has_for = num_sym + 21 + integer,parameter:: sym_proc_is_dcomm = num_sym + 22 + integer,parameter:: sym_proc_is_file = num_sym + 23 + integer,parameter:: sym_proc_is_not_inlinable = num_sym + 24 + integer,parameter:: sym_proc_needs_type = num_sym + 25 + integer,parameter:: sym_proc_prints_out = num_sym + 26 + + ! Specialised types + integer,parameter:: sym_literal = num_sym + 27 ! Symbols used as node types (actual name not really used) - integer,parameter:: node0 = num_sym + 17 + integer,parameter:: node0 = num_sym + 27 integer,parameter:: sym_iter = node0 + 1 integer,parameter:: sym_list = node0 + 2 integer,parameter:: sym_builtin = node0 + 3 @@ -263,7 +302,7 @@ module pm_symbol integer,parameter:: sym_result = node0 + 10 integer,parameter:: sym_sub = node0 + 11 integer,parameter:: sym_method_call = node0 + 12 - integer,parameter:: sym_dot_sub = node0 + 13 + integer,parameter:: sym_pm_subs = node0 + 13 integer,parameter:: sym_unused_node = node0 +14 integer,parameter:: sym_array_former = node0 + 15 integer,parameter:: sym_matrix_former = node0 + 16 @@ -294,12 +333,19 @@ module pm_symbol integer,parameter:: sym_dim = node0 + 41 integer,parameter:: sym_vdim = node0 + 42 integer,parameter:: sym_sync_assign = node0 + 43 - integer,parameter:: sym_get_filesystem = node0 + 44 - integer,parameter:: sym_nested_loop = node0 + 45 - integer,parameter:: sym_assign_list = node0 + 46 + integer,parameter:: sym_sync_assign_ref = node0 + 44 + integer,parameter:: sym_sync_assign_op = node0 + 45 + integer,parameter:: sym_get_filesystem = node0 + 46 + integer,parameter:: sym_nested_loop = node0 + 47 + integer,parameter:: sym_assign_list = node0 + 48 + integer,parameter:: sym_case_range = node0 + 49 + integer,parameter:: sym_dot_call = node0 + 50 + integer,parameter:: sym_key = node0 + 51 + integer,parameter:: sym_reference = node0 + 52 + integer,parameter:: sym_repl_line = node0 + 53 ! Misc. other symbols that need to be referenced by the compiler - integer,parameter:: hook = node0 + 47 + integer,parameter:: hook = node0 + 54 integer,parameter:: sym_pval_as = hook integer,parameter:: sym_pm_system = hook+1 integer,parameter:: sym_get_element = hook+2 @@ -310,7 +356,7 @@ module pm_symbol integer,parameter:: sym_import_shared = hook+7 integer,parameter:: sym_partition = hook+8 integer,parameter:: sym_check_conform = hook+9 - integer,parameter:: sym_dup = hook + 10 + integer,parameter:: sym_dupz = hook + 10 integer,parameter:: sym_assemble = hook + 11 integer,parameter:: sym_node_grid = hook + 12 integer,parameter:: sym_this_node = hook + 13 @@ -327,7 +373,47 @@ module pm_symbol integer,parameter:: sym_invar_dim = hook + 24 integer,parameter:: sym_fix_dim = hook + 25 integer,parameter:: sym_sync_messages = hook + 26 - integer,parameter:: hook1 = hook + 26 + integer,parameter:: sym_block_inouts=hook + 27 + integer,parameter:: sym_block_ins=hook + 28 + integer,parameter:: sym_block_proc=hook + 29 + integer,parameter:: sym_block_inouts_a=hook + 30 + integer,parameter:: sym_block_ins_a=hook + 31 + integer,parameter:: sym_block_proc_a=hook + 32 + integer,parameter:: sym_elem_at_index=hook + 33 + integer,parameter:: sym_amp_iter_args=hook + 34 + integer,parameter:: sym_star_iter_args=hook + 35 + integer,parameter:: sym_iter_args=hook + 36 + integer,parameter:: sym_pm_foreach_stmt=hook + 37 + integer,parameter:: sym_pm_foreach_invar_stmt=hook + 38 + integer,parameter:: sym_pm_for_stmt = hook + 39 + integer,parameter:: sym_pm_forall_stmt = hook + 40 + integer,parameter:: sym_pm_over_stmt = hook + 41 + integer,parameter:: sym_pm_par_stmt = hook + 42 + integer,parameter:: sym_lhs = hook + 43 + integer,parameter:: sym_rhs = hook + 44 + integer,parameter:: sym_make_var= hook + 45 + integer,parameter:: sym_make_chan_var = hook + 46 + integer,parameter:: sym_make_nhd_var = hook + 47 + integer,parameter:: sym_make_lcl_var = hook + 48 + integer,parameter:: sym_make_invar_var = hook + 49 + integer,parameter:: sym_make_shared_var = hook + 50 + integer,parameter:: sym_make_const = hook + 51 + integer,parameter:: sym_pm_at = hook + 52 + integer,parameter:: sym_pm_pling = hook + 53 + integer,parameter:: sym_lcl_stmt = hook + 54 + integer,parameter:: sym_dechan = hook + 55 + integer,parameter:: sym_check_iter = hook + 56 + integer,parameter:: sym_check_iter_amp = hook + 57 + integer,parameter:: sym_check_iter_star = hook + 58 + integer,parameter:: sym_all_stmt = hook + 59 + integer,parameter:: sym_lhs_and_val_sync = hook + 60 + integer,parameter:: sym_iter_ref = hook + 61 + integer,parameter:: sym_check_task = hook + 62 + integer,parameter:: sym_init_var = hook + 63 + integer,parameter:: sym_init_const = hook + 64 + integer,parameter:: sym_print = hook + 65 + integer,parameter:: sym_fix_tuple = hook + 66 + integer,parameter:: hook1 = hook + 66 integer,parameter:: sym_d1= hook1 + 1 integer,parameter:: sym_d2= hook1 + 2 @@ -336,21 +422,23 @@ module pm_symbol integer,parameter:: sym_d5= hook1 + 5 integer,parameter:: sym_d6= hook1 + 6 integer,parameter:: sym_d7= hook1 + 7 - integer,parameter:: sym_copy_out = hook1 + 8 - integer,parameter:: sym_copy_back = hook1 + 9 - integer,parameter:: sym_assignment = hook1 + 10 - integer,parameter:: sym_aliased_assign = hook1 + 11 - integer,parameter:: sym_first = hook1 + 12 - integer,parameter:: sym_next = hook1 + 13 - integer,parameter:: sym_checkcase = hook1 + 14 - integer,parameter:: sym_dim1= hook1 + 15 - integer,parameter:: sym_dim2= hook1 + 16 - integer,parameter:: sym_dim3= hook1 + 17 - integer,parameter:: sym_dim4= hook1 + 18 - integer,parameter:: sym_dim5= hook1 + 19 - integer,parameter:: sym_dim6= hook1 + 20 - integer,parameter:: sym_dim7= hook1 + 21 - integer,parameter:: hook2= hook1+21 + integer,parameter:: sym_copy_in = hook1 + 8 + integer,parameter:: sym_copy_out = hook1 + 9 + integer,parameter:: sym_pm_assign = hook1 + 10 + integer,parameter:: sym_pm_assign_ref = hook1 + 11 + integer,parameter:: sym_pm_assign_op = hook1 +12 + integer,parameter:: sym_first = hook1 + 13 + integer,parameter:: sym_next = hook1 + 14 + integer,parameter:: sym_checkcase = hook1 + 15 + integer,parameter:: sym_dim1= hook1 + 16 + integer,parameter:: sym_dim2= hook1 + 17 + integer,parameter:: sym_dim3= hook1 + 18 + integer,parameter:: sym_dim4= hook1 + 19 + integer,parameter:: sym_dim5= hook1 + 20 + integer,parameter:: sym_dim6= hook1 + 21 + integer,parameter:: sym_dim7= hook1 + 22 + integer,parameter:: sym_range = hook1 + 23 + integer,parameter:: hook2= hook1+23 integer,parameter:: sym_generate = hook2 + 1 integer,parameter:: sym_broadcast = hook2 +2 @@ -362,50 +450,52 @@ module pm_symbol integer,parameter:: sym_node_for = hook2 + 8 integer,parameter:: sym_import_param = hook2 + 9 integer,parameter:: sym_set_elem = hook2 + 10 - integer,parameter:: sym_assign_var = hook2 + 11 - integer,parameter:: sym_vector = hook2 + 12 - integer,parameter:: sym_matrix = hook2 + 13 - integer,parameter:: sym_pdup = hook2 + 14 - integer,parameter:: sym_active = hook2 + 15 - integer,parameter:: hook3 = hook2 + 15 + integer,parameter:: sym_assign_or_init = hook2 + 11 + integer,parameter:: sym_assign_var = hook2 + 12 + integer,parameter:: sym_vector = hook2 + 13 + integer,parameter:: sym_matrix = hook2 + 14 + integer,parameter:: sym_pdup = hook2 + 15 + integer,parameter:: sym_active = hook2 + 16 + integer,parameter:: hook3 = hook2 + 16 integer,parameter:: sym_do_dim = hook3 + 1 integer,parameter:: sym_shape = hook3 + 2 integer,parameter:: sym_poly= hook3 + 3 - integer,parameter:: sym_pm_over = hook3 + 4 - integer,parameter:: sym_next_enum = hook3 + 5 - integer,parameter:: sym_make_distr = hook3 + 6 - integer,parameter:: sym_check_import = hook3 + 7 - integer,parameter:: sym_for_get_element = hook3 + 8 - integer,parameter:: sym_for_set_element = hook3 + 9 - integer,parameter:: sym_get_distr = hook3 + 10 - integer,parameter:: sym_get_darray = hook3 + 11 - integer,parameter:: sym_make_local = hook3 + 12 - integer,parameter:: hook4 = hook3 + 12 + integer,parameter:: sym_next_enum = hook3 + 4 + integer,parameter:: sym_make_distr = hook3 + 5 + integer,parameter:: sym_check_import = hook3 + 6 + integer,parameter:: sym_for_get_element = hook3 + 7 + integer,parameter:: sym_for_set_element = hook3 + 8 + integer,parameter:: sym_get_distr = hook3 + 9 + integer,parameter:: sym_get_darray = hook3 + 10 + integer,parameter:: sym_make_local = hook3 + 11 + integer,parameter:: hook4 = hook3 + 11 integer,parameter:: sym_make_ldist = hook4 + 1 integer,parameter:: sym_make_global = hook4 + 2 integer,parameter:: sym_shared_to_local = hook4 + 3 integer,parameter:: sym_clone = hook4 + 4 integer,parameter:: sym_contains = hook4 + 5 - integer,parameter:: sym_this = hook4 + 6 + integer,parameter:: sym_mask = hook4 + 6 integer,parameter:: sym_here = hook4 + 7 integer,parameter:: sym_here_in_tile = hook4 + 8 integer,parameter:: sym_subregion = hook4 + 9 integer,parameter:: sym_region = hook4 + 10 - integer,parameter:: sym_distr_tag = hook4 + 11 - integer,parameter:: sym_tag = hook4 + 12 - integer,parameter:: sym_varray= hook4 + 13 - integer,parameter:: sym_map_array= hook4 + 14 - integer,parameter:: sym_map_varray= hook4 + 15 - integer,parameter:: sym_get_val_ref = hook4 + 16 - integer,parameter:: sym_local_distr = hook4 + 17 - integer,parameter:: sym_pm_chan = hook4 + 18 - integer,parameter:: sym_get_chan = hook4 + 19 - integer,parameter:: sym_pm_local = hook4 + 20 - integer,parameter:: sym_casts_to = hook4 + 21 - integer,parameter:: sym_combine_indices = hook4 + 22 - integer,parameter:: hook5 = hook4 + 22 + integer,parameter:: sym_outer = hook4 + 11 + integer,parameter:: sym_topology = hook4 + 12 + integer,parameter:: sym_distr_tag = hook4 + 13 + integer,parameter:: sym_tag = hook4 + 14 + integer,parameter:: sym_varray= hook4 + 15 + integer,parameter:: sym_map_array= hook4 + 16 + integer,parameter:: sym_map_varray= hook4 + 17 + integer,parameter:: sym_get_val_ref = hook4 + 18 + integer,parameter:: sym_local_distr = hook4 + 19 + integer,parameter:: sym_make_chan = hook4 + 20 + integer,parameter:: sym_get_chan = hook4 + 21 + integer,parameter:: sym_pm_local = hook4 + 22 + integer,parameter:: sym_casts_to = hook4 + 23 + integer,parameter:: sym_combine_indices = hook4 + 24 + integer,parameter:: hook5 = hook4 + 24 integer,parameter:: sym_pm_ref_type = hook5 + 1 integer,parameter:: sym_pling_local = hook5 + 2 @@ -434,14 +524,14 @@ module pm_symbol integer,parameter:: sym_blocking = hook5 + 25 integer,parameter:: sym_chunks = hook5 + 26 integer,parameter:: sym_get_chunk = hook5 + 27 - integer,parameter:: sym_pm_at = hook5 + 28 + integer,parameter:: sym_pm_atz = hook5 + 28 integer,parameter:: sym_push_mess = hook5 + 29 integer,parameter:: sym_pop_sync_mess = hook5 + 30 integer,parameter:: sym_join_param = hook5 + 31 integer,parameter:: sym_split_param = hook5 + 32 integer,parameter:: sym_dim_noinit = hook5 + 33 integer,parameter:: sym_pm_node = hook5 + 34 - integer,parameter:: sym_init_var = hook5 + 35 + integer,parameter:: sym_init_constx = hook5 + 35 integer,parameter:: sym_pm_dump = hook5 + 36 integer,parameter:: hook6 = 36 + hook5 @@ -458,7 +548,7 @@ module pm_symbol !============================================== - character(len=20),dimension(0:num_syshook)::sym_names + character(len=22),dimension(0:num_syshook)::sym_names data sym_names(0) /''/ data sym_names(sym_at) /'@'/ data sym_names(sym_dollar) /'$'/ @@ -472,19 +562,22 @@ module pm_symbol data sym_names(sym_ddollar) /'$$'/ data sym_names(sym_comma) /','/ data sym_names(sym_dot) /'.'/ - data sym_names(sym_assign) /':='/ data sym_names(sym_underscore) /'_'/ data sym_names(sym_open_attr) /'<<'/ data sym_names(sym_close_attr) /'>>'/ data sym_names(sym_query) /'?'/ data sym_names(sym_arrow) /'->'/ data sym_names(sym_pct) /'%'/ + data sym_names(sym_pling) /'!'/ data sym_names(sym_dash) /''''/ data sym_names(sym_caret) /'^'/ data sym_names(sym_dcaret) /'^^'/ data sym_names(sym_dcolon) /'::'/ - data sym_names(sym_define) /'='/ + data sym_names(sym_assign) /'='/ data sym_names(sym_cond) /'=>'/ + data sym_names(sym_move) /'<--'/ + data sym_names(sym_move_all) /'<=='/ + data sym_names(sym_swap) /'<->'/ data sym_names(sym_string) /''/ data sym_names(sym_number) /''/ @@ -496,9 +589,6 @@ module pm_symbol data sym_names(sym_lt) /'<'/ data sym_names(sym_ustar) /'unary *'/ - - data sym_names(sym_from_range) /'_...'/ - data sym_names(sym_to_range) /'..._'/ data sym_names(sym_concat) /'++'/ data sym_names(sym_eq) /'=='/ data sym_names(sym_ne) /'/='/ @@ -513,27 +603,28 @@ module pm_symbol data sym_names(sym_bar) /'|'/ data sym_names(sym_hash) /'#'/ data sym_names(sym_amp) /'&'/ - data sym_names(sym_pling) /'!'/ + data sym_names(sym_tilde) /'~'/ data sym_names(sym_in) /'in'/ + data sym_names(sym_not_in) /'notin'/ data sym_names(sym_and) /'and'/ data sym_names(sym_or) /'or'/ - data sym_names(sym_xor) /'xor'/ data sym_names(sym_shift) /'shift'/ data sym_names(sym_fmt) /'fmt'/ data sym_names(sym_by) /'by'/ data sym_names(sym_mod) /'mod'/ + data sym_names(sym_div) /'div'/ data sym_names(sym_except) /'except'/ data sym_names(sym_includes) /'inc'/ + data sym_names(sym_not_includes) /'notinc'/ data sym_names(sym_ortho) /'ortho'/ data sym_names(sym_is) /'is'/ + data sym_names(sym_is_not) /'isnt'/ data sym_names(sym_as) /'as'/ data sym_names(sym_not) /'not'/ ! Statement / expression general keywords data sym_names(sym_null) /'null'/ - data sym_names(sym_key) /'key'/ - data sym_names(sym_arg) /'arg'/ data sym_names(sym_true) /'true'/ data sym_names(sym_false) /'false'/ data sym_names(sym_struct) /'struct'/ @@ -543,22 +634,25 @@ module pm_symbol data sym_names(sym_unique) /'unique'/ data sym_names(sym_fix) /'fix'/ data sym_names(sym_new) /'new'/ - data sym_names(sym_bounds) /'bounds'/ - data sym_names(sym_of) /'of'/ + data sym_names(sym_when) /'when'/ + + data sym_names(sym_individual) /'indiv'/ + data sym_names(sym_connected) /'cntd'/ + data sym_names(sym_local) /'lcl'/ + data sym_names(sym_global) /'gbl'/ + data sym_names(sym_complete) /'cplt'/ data sym_names(sym_private) /'priv'/ - data sym_names(sym_invar) /'invar'/ - data sym_names(sym_complete) /'complete'/ - data sym_names(sym_universal) /'universal'/ - data sym_names(sym_local) /'local'/ - - data sym_names(sym_partial) /'partial'/ - data sym_names(sym_coherent) /'coherent'/ data sym_names(sym_chan) /'chan'/ - data sym_names(sym_mirrored) /'uniform'/ - data sym_names(sym_shared) /'shared'/ + data sym_names(sym_nhd) /'nhd'/ + data sym_names(sym_indexed) /'idx'/ + data sym_names(sym_joint) /'jnt'/ + data sym_names(sym_uniform) /'unif'/ + data sym_names(sym_invar) /'invar'/ + data sym_names(sym_shared) /'shrd'/ ! Declaration keywords + data sym_names(sym_package) /'package'/ data sym_names(sym_use) /'use'/ data sym_names(sym_proc) /'proc'/ data sym_names(sym_param) /'param'/ @@ -582,26 +676,26 @@ module pm_symbol data sym_names(sym_while) /'while'/ data sym_names(sym_return) /'return'/ data sym_names(sym_do) /'do'/ - data sym_names(sym_nhd) /'nhd'/ + data sym_names(sym_yield) /'yield'/ data sym_names(sym_test) /'test'/ data sym_names(sym_default) /'default'/ data sym_names(sym_task) /'task'/ - data sym_names(sym_extern) /'extern'/ + data sym_names(sym_assignment) /'assign'/ data sym_names(sym_var) /'var'/ - data sym_names(sym_const) /'const'/ + data sym_names(sym_const) /'let'/ data sym_names(sym_each) /'foreach'/ data sym_names(sym_where) /'where'/ - data sym_names(sym_with) /'with'/ - data sym_names(sym_conc) /'forall'/ + data sym_names(sym_split) /'split'/ + data sym_names(sym_forall) /'forall'/ data sym_names(sym_interface) /'interface'/ - data sym_names(sym_switch_invar) /'iswitch'/ - data sym_names(sym_if_invar) /''/ - data sym_names(sym_while_invar) /''/ - data sym_names(sym_until_invar) /''/ - data sym_names(sym_foreach_invar) /''/ - data sym_names(sym_proceed) /'proceed'/ - data sym_names(sym_after) /'after'/ - data sym_names(sym_any_invar) /''/ + data sym_names(sym_switch_invar) /'switch invar'/ + data sym_names(sym_if_invar) /'if invar'/ + data sym_names(sym_while_invar) /'while invar'/ + data sym_names(sym_until_invar) /'until invar'/ + data sym_names(sym_foreach_invar) /'foreach invar'/ + data sym_names(sym_any_invar) /'any invar'/ + data sym_names(sym_all) /'all'/ + data sym_names(sym_sync_while) /'sync(while)'/ data sym_names(sym_pm_send) /'PM__send'/ data sym_names(sym_pm_recv) /'PM__recv'/ @@ -616,10 +710,28 @@ module pm_symbol data sym_names(sym_pm_dref_shared_slice) /'PM__dref_is'/ data sym_names(sym_pm_dref_here) /'PM__drefhere'/ data sym_names(sym_pm_ref) /'PM__ref'/ + data sym_names(sym_pm_dref_any) /'PM__anyref'/ + data sym_names(sym_pm_dref_any_slice) /'PM__anyref_s'/ data sym_names(sym_pm_head_node) /'PM__head_node'/ data sym_names(sym_pm_do_at) /'PM__do_at'/ data sym_names(sym_pm_do) /'PM__do'/ - + data sym_names(sym_pm_intrinsic) /'PM__intrinsic'/ + data sym_names(sym_pm_each_index) /'PM__each_index'/ + data sym_names(sym_pm_if_compiling) /'PM__if_compiling'/ + data sym_names(sym_pm_else) /'PM__else'/ + data sym_names(sym_pm_endif) /'PM__endif'/ + data sym_names(sym_pm_yield) /'PM__yield'/ + data sym_names(sym_pm_set_dotdotdot) /'PM__set_dotdotdot'/ + data sym_names(sym_pm_for) /'PM__for'/ + data sym_names(sym_pm_foreach) /'PM__foreach'/ + data sym_names(sym_pm_over) /'PM__over'/ + data sym_names(sym_pm_context) /'PM__context'/ + data sym_names(sym_pm_shared) /'PM__shrd'/ + data sym_names(sym_pm_shared_always) /'PM__shrd_always'/ + data sym_names(sym_pm_chan) /'PM__chan'/ + data sym_names(sym_pm_chan_always) /'PM__chan_always'/ + data sym_names(sym_pm_list) /'PM__list'/ + !=============================================================== data sym_names(sym_array) /'PM__array'/ @@ -640,13 +752,24 @@ module pm_symbol data sym_names(sym_cond_attr) /'cond'/ data sym_names(sym_uncond) /'uncond'/ data sym_names(sym_ignore_rules) /'PM__ignore'/ + data sym_names(sym_keep_literals) /'keep_literals'/ + data sym_names(sym_filesystem) /'IO'/ - data sym_names(sym_filesystem) /'filesystem'/ + data sym_names(sym_proc_is_generator) /'is_generator'/ + data sym_names(sym_proc_is_impure) /'is_impure'/ + data sym_names(sym_proc_has_for) /'has_for'/ + data sym_names(sym_proc_is_dcomm) /'is_dcomm'/ + data sym_names(sym_proc_is_file) /'is_file'/ + data sym_names(sym_proc_is_not_inlinable) /'is_not_inlinable'/ + data sym_names(sym_proc_needs_type) /'needs_type'/ + data sym_names(sym_proc_prints_out) /'prints_out'/ + data sym_names(sym_literal) /'literal'/ + ! Symbols that are node names only data sym_names(sym_iter) /''/ - data sym_names(sym_list) /''/ + data sym_names(sym_list) /'list'/ data sym_names(sym_builtin) /''/ data sym_names(sym_each_proc) /''/ data sym_names(sym_mode) /''/ @@ -657,7 +780,7 @@ module pm_symbol data sym_names(sym_result) /''/ data sym_names(sym_sub) /'[]'/ data sym_names(sym_method_call) /''/ - data sym_names(sym_dot_sub) /''/ + data sym_names(sym_pm_subs) /'PM__subs'/ data sym_names(sym_unused_node) /''/ data sym_names(sym_array_former) /''/ data sym_names(sym_matrix_former) /'PM__matrix'/ @@ -674,7 +797,7 @@ module pm_symbol data sym_names(sym_local_sub) /''/ data sym_names(sym_set_mode) /''/ data sym_names(sym_export) /''/ - data sym_names(sym_export_param) /''/ + data sym_names(sym_export_param) /'PM__export_param'/ data sym_names(sym_export_as_new) /''/ data sym_names(sym_amp_error) /''/ data sym_names(sym_also) /''/ @@ -689,10 +812,17 @@ module pm_symbol data sym_names(sym_cast) /'PM__cast'/ data sym_names(sym_dim) /'PM__dim'/ data sym_names(sym_vdim) /'PM__vdim'/ - data sym_names(sym_sync_assign) /''/ + data sym_names(sym_sync_assign) /'PM__sync_assign'/ + data sym_names(sym_sync_assign_ref) /'PM__sync_assign_ref'/ + data sym_names(sym_sync_assign_op) /'PM__sync_assign_op'/ data sym_names(sym_get_filesystem) /'PM__filesys'/ data sym_names(sym_nested_loop) /'PM__nested_loop'/ data sym_names(sym_assign_list) /''/ + data sym_names(sym_case_range) /'PM__caserange'/ + data sym_names(sym_dot_call) /''/ + data sym_names(sym_key) /''/ + data sym_names(sym_reference) /''/ + data sym_names(sym_repl_line) /''/ ! Misc. symbols referenced by compiler @@ -705,13 +835,13 @@ module pm_symbol data sym_names(sym_import_shared) /'PM__importshrd'/ data sym_names(sym_partition) /'PM__partition'/ data sym_names(sym_check_conform) /'check_conform'/ - data sym_names(sym_dup) /'PM__dup'/ + data sym_names(sym_dupz) /'PM__dup'/ data sym_names(sym_assemble) /'PM__assemble'/ data sym_names(sym_node_grid) /'node_grid'/ data sym_names(sym_this_node) /'this_node'/ data sym_names(sym_grid) /'grid'/ data sym_names(sym_indices) /'indices'/ - data sym_names(sym_get_ref) /'PM__getref'/ + data sym_names(sym_get_ref) /'PM__get_ref'/ data sym_names(sym_set_ref) /'PM__set_ref'/ data sym_names(sym_make_subref) /'PM__subref'/ data sym_names(sym_make_sublhs) /'PM__sublhs'/ @@ -722,6 +852,49 @@ module pm_symbol data sym_names(sym_invar_dim) /'PM__invar_dim'/ data sym_names(sym_fix_dim) /'PM__fix_dim'/ data sym_names(sym_sync_messages) /'PM__sync_messages'/ + data sym_names(sym_block_inouts) /'PM__inouts'/ + data sym_names(sym_block_ins) /'PM__ins'/ + data sym_names(sym_block_proc) /'PM__block_proc'/ + data sym_names(sym_block_inouts_a) /'PM__inouts_a'/ + data sym_names(sym_block_ins_a) /'PM__ins_a'/ + data sym_names(sym_block_proc_a) /'PM__block_proc_a'/ + data sym_names(sym_elem_at_index) /'element_at_index'/ + data sym_names(sym_amp_iter_args) /'PM__amp_iter_args'/ + data sym_names(sym_star_iter_args) /'PM__star_iter_args'/ + data sym_names(sym_iter_args) /'PM__iter_args'/ + data sym_names(sym_pm_foreach_stmt) /'PM__foreach_stmt'/ + data sym_names(sym_pm_foreach_invar_stmt) /'PM__foreach_invar_stmt'/ + data sym_names(sym_pm_for_stmt) /'PM__for_stmt'/ + data sym_names(sym_pm_forall_stmt) /'PM__forall_stmt'/ + data sym_names(sym_pm_over_stmt) /'PM__over_stmt'/ + data sym_names(sym_pm_par_stmt) /'PM__par_stmt'/ + data sym_names(sym_lhs) /'PM__lhs'/ + data sym_names(sym_rhs) /'PM__rhs_and_val'/ + data sym_names(sym_make_var) /'PM__make_var'/ + data sym_names(sym_make_chan_var) /'PM__make_chan_var'/ + data sym_names(sym_make_nhd_var) /'PM__make_nhd_var'/ + data sym_names(sym_make_lcl_var) /'PM__make_lcl_var'/ + data sym_names(sym_make_invar_var) /'PM__make_invar_var'/ + data sym_names(sym_make_shared_var) /'PM__make_shrd_var'/ + data sym_names(sym_make_const) /'PM__make_const'/ + + data sym_names(sym_pm_at) /'PM__chan_stmt'/ + data sym_names(sym_pm_pling) /'PM__invar_stmt'/ + data sym_names(sym_lcl_stmt) /'PM__shrd_stmt'/ + + data sym_names(sym_dechan) /'PM__dechan'/ + data sym_names(sym_check_iter) /'PM__check_iter'/ + data sym_names(sym_check_iter_amp) /'PM__check_iter_amp'/ + data sym_names(sym_check_iter_star) /'PM__check_iter_star'/ + + data sym_names(sym_all_stmt) /'PM__all_stmt'/ + data sym_names(sym_lhs_and_val_sync) /'PM__lhs_and_val_sync'/ + data sym_names(sym_iter_ref) /'PM__iter_ref'/ + data sym_names(sym_check_task) /'PM__check_task'/ + data sym_names(sym_init_var) /'PM__init_var'/ + data sym_names(sym_init_const) /'PM__init_const'/ + data sym_names(sym_print) /'print'/ + data sym_names(sym_fix_tuple) /'PM__fix_tuple'/ data sym_names(sym_d1) /'PM__d1'/ data sym_names(sym_d2) /'PM__d2'/ @@ -731,10 +904,11 @@ module pm_symbol data sym_names(sym_d6) /'PM__d6'/ data sym_names(sym_d7) /'PM__d7'/ + data sym_names(sym_copy_in) /'PM__copy_in'/ data sym_names(sym_copy_out) /'PM__copy_out'/ - data sym_names(sym_copy_back) /'PM__copy_back'/ - data sym_names(sym_assignment) /'PM__assign'/ - data sym_names(sym_aliased_assign) /'PM__aliased_assign'/ + data sym_names(sym_pm_assign) /'PM__assign'/ + data sym_names(sym_pm_assign_ref) /'PM__assign_ref'/ + data sym_names(sym_pm_assign_op) /'PM__assign_op'/ data sym_names(sym_first) /'PM__first'/ data sym_names(sym_next) /'PM__next'/ data sym_names(sym_checkcase) /'PM__checkcase'/ @@ -746,6 +920,8 @@ module pm_symbol data sym_names(sym_dim5) /'tuple5d'/ data sym_names(sym_dim6) /'tuple6d'/ data sym_names(sym_dim7) /'tuple7d'/ + + data sym_names(sym_range) /'range'/ data sym_names(sym_generate) /'PM__generate'/ data sym_names(sym_broadcast) /'PM__broadcast'/ @@ -755,8 +931,9 @@ module pm_symbol data sym_names(sym_get_tile_sz) /'PM__get_tilesz'/ data sym_names(sym_make_mask) /'PM__make_mask'/ data sym_names(sym_node_for) /'node_for'/ - data sym_names(sym_import_param) /'PM__impparam'/ + data sym_names(sym_import_param) /'PM__import_param'/ data sym_names(sym_set_elem) /'PM__setaelem'/ + data sym_names(sym_assign_or_init) /'PM__assign_or_init'/ data sym_names(sym_assign_var) /'PM__assign_var'/ data sym_names(sym_vector) /'vector'/ data sym_names(sym_matrix) /'matrix'/ @@ -766,7 +943,6 @@ module pm_symbol data sym_names(sym_do_dim) /'PM__do_dim'/ data sym_names(sym_shape) /'shape'/ data sym_names(sym_poly) /'poly'/ - data sym_names(sym_pm_over) /'PM__over'/ data sym_names(sym_next_enum) /'next_enum'/ data sym_names(sym_make_distr) /'PM__distr'/ data sym_names(sym_check_import) /'PM__checkimp'/ @@ -781,11 +957,13 @@ module pm_symbol data sym_names(sym_shared_to_local) /'PM__shared_to_local'/ data sym_names(sym_clone) /'PM__clone'/ data sym_names(sym_contains) /'contains'/ - data sym_names(sym_this) /'this'/ - data sym_names(sym_here) /'here'/ - data sym_names(sym_here_in_tile) /'here_in_tile'/ - data sym_names(sym_subregion) /'schedule'/ - data sym_names(sym_region) /'region'/ + data sym_names(sym_mask) /'PM__mask'/ + data sym_names(sym_here) /'PM__here'/ + data sym_names(sym_here_in_tile) /'PM__here_in_tile'/ + data sym_names(sym_subregion) /'PM__schedule'/ + data sym_names(sym_region) /'PM__region'/ + data sym_names(sym_outer) /'PM__outer'/ + data sym_names(sym_topology) /'PM__topology'/ data sym_names(sym_distr_tag) /'PM__distr_tag'/ data sym_names(sym_tag) /'PM__tag'/ data sym_names(sym_varray) /'PM__varray'/ @@ -793,7 +971,7 @@ module pm_symbol data sym_names(sym_map_varray) /'PM__mapvarray'/ data sym_names(sym_get_val_ref) /'PM__valref'/ data sym_names(sym_local_distr) /'local_distr'/ - data sym_names(sym_pm_chan) /'PM__chan'/ + data sym_names(sym_make_chan) /'PM__make_chan'/ data sym_names(sym_get_chan) /'PM__getchan'/ data sym_names(sym_pm_local) /'PM__local'/ data sym_names(sym_casts_to) /'casts_to'/ @@ -805,7 +983,7 @@ module pm_symbol data sym_names(sym_dims) /'dims'/ data sym_names(sym_make_dollar) /'PM__makeidxdim'/ data sym_names(sym_make_dtuple) /'PM__makeidx'/ - data sym_names(sym_stretch_dim) /'PM__strdim'/ + data sym_names(sym_stretch_dim) /'PM__underscore'/ data sym_names(sym_pm_nhd) /'PM__nhd'/ data sym_names(sym_envelope) /'envelope'/ data sym_names(sym_set_nhd) /'PM__set_nhd'/ @@ -832,9 +1010,9 @@ module pm_symbol data sym_names(sym_dim_noinit) /'PM__dim_noinit'/ data sym_names(sym_chunks) /'chunks'/ data sym_names(sym_get_chunk) /'chunk'/ - data sym_names(sym_pm_at) /'PM__at'/ + data sym_names(sym_pm_atz) /'PM__atz'/ data sym_names(sym_pm_node) /'PM__node'/ - data sym_names(sym_init_var) /'PM__init_var'/ + data sym_names(sym_init_constx) /'PM__init_constx'/ data sym_names(sym_infer_stack) /'infer_stack'/ data sym_names(sym_infer_type) /'infer_type'/ @@ -1110,7 +1288,7 @@ recursive subroutine pm_name_string(context,m,str) if(pm_fast_esize(ptr)>1) then do i=2,pm_fast_esize(ptr) call pm_name_string(context,ptr%data%i(ptr%offset+i),str2) - str=trim(str)//''''//str2 + str=trim(str)//'::'//str2 enddo endif else @@ -1118,7 +1296,7 @@ recursive subroutine pm_name_string(context,m,str) -first,str) call pm_name_string(context,& second,str2) - str=trim(str)//''''//str2 + str=trim(str)//'::'//str2 endif else if(pm_fast_esize(ptr)==1.and.ptr%data%i(ptr%offset)==sym_pm_system) then @@ -1131,7 +1309,7 @@ recursive subroutine pm_name_string(context,m,str) if(i==0) then str=trim(str2) else - str=trim(str)//''''//trim(str2) + str=trim(str)//'::'//trim(str2) endif enddo endif @@ -1147,7 +1325,7 @@ recursive subroutine pm_name_string(context,m,str) str='_'//trim(str2) else call pm_name_string(context,first,str) - str=trim(str)//'''_'//trim(str2) + str=trim(str)//'::_'//trim(str2) endif else str='?type' @@ -1156,7 +1334,7 @@ recursive subroutine pm_name_string(context,m,str) write(str,'(1h?,i8,1h?)') n endif else if(n<0) then - str='use ' + str='var ' call pm_name_string(context,-n,str(5:)) else str='EOF' diff --git a/src/sysdefs.f90 b/src/sysdefs.f90 index 31efde6..d0988cf 100755 --- a/src/sysdefs.f90 +++ b/src/sysdefs.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -14,7 +14,6 @@ ! ! The above copyright notice and this permission notice shall be included in ! all copies or substantial portions of the Software. -! ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE @@ -38,40 +37,107 @@ module pm_sysdefs use pm_vmdefs implicit none - ! Flag values for procs - ! (note values 1=proc_is_comm,... defined in parser) - integer,parameter:: proc_is_thru_each = 2**12 - integer,parameter:: proc_is_empty_each = 2**13 - integer,parameter:: proc_is_dup_each = 2**14 - integer,parameter:: proc_is_var = 2**15 - integer,parameter:: proc_is_generator = 2**16 - integer,parameter:: proc_needs_type = 2**17 - integer,parameter:: proc_is_recursive = 2**18 - integer,parameter:: proc_unfinished = 2**19 - integer,parameter:: proc_is_impure = 2**20 - integer,parameter:: proc_is_not_inlinable = 2**21 - integer,parameter:: proc_has_for = 2**22 - integer,parameter:: proc_is_not_pure_each = 2**23 - integer,parameter:: proc_has_vkeys = 2**24 - integer,parameter:: proc_is_dcomm = 2**25 - integer,parameter:: proc_is_variant = 2**26 - integer,parameter:: proc_needs_par = 2**27 - - integer,parameter:: proc_taints = proc_is_impure & - + proc_is_not_inlinable + proc_has_for & - + proc_is_not_pure_each + proc_is_variant & - + proc_needs_par contains subroutine sysdefs(parser) type(parse_state):: parser integer:: line + logical:: ok + line=1 call dcl_module(parser,'PM__system') parser%sysmodl=parser%modl + call pm_open_file(3,'sysmod.pmm',ok) + if(.not.ok) then + if(pm_main_process) then + write(*,*) 'Cannot open sysmod.pmm' + endif + call pm_stop('Compilation terminated') + endif + !write(*,*) 'Parsing',trim(str) + call parse_file_on_unit(parser,3,.false.) + close(3) + return + + call dcl_type(parser,'literal is ^^^any',line) + call dcl_type(parser,'int_literal is ^^^int',line) + call dcl_type(parser,'real_literal is ^^^real',line) + call dcl_type(parser,'bool_literal is ^^^bool',line) + call dcl_type(parser,'string_literal is ^^^string',line) + + call dcl_proc(parser,'mod(int_literal,int_literal)->(int_literal)',op_mod_fold,0,line,0) + call dcl_proc(parser,'==(int_literal,int_literal)->(bool_literal)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(int_literal,int_literal)->(bool_literal)',op_ne_fold,0,line,0) + call dcl_proc(parser,'>=(int_literal,int_literal)->(bool_literal)',op_ge_fold,0,line,0) + call dcl_proc(parser,'>(int_literal,int_literal)->(bool_literal)',op_gt_fold,0,line,0) + call dcl_proc(parser,'+(int_literal,int_literal)->(int_literal)',op_add_fold,0,line,0) + call dcl_proc(parser,'-(int_literal,int_literal)->(int_literal)',op_sub_fold,0,line,0) + call dcl_proc(parser,'*(int_literal,int_literal)->(int_literal)',op_mult_fold,0,line,0) + call dcl_proc(parser,'/(int_literal,int_literal)->(int_literal)',op_divide_fold,0,line,0) + call dcl_proc(parser,'**(int_literal,int_literal)->(int_literal)',op_pow_fold,0,line,0) + call dcl_proc(parser,'max(int_literal,int_literal)->(int_literal)',op_max_fold,0,line,0) + call dcl_proc(parser,'min(int_literal,int_literal)->(int_literal)',op_min_fold,0,line,0) + call dcl_proc(parser,'-(int_literal)->(int_literal)',op_uminus_fold,0,line,0) + call dcl_proc(parser,'string(int_literal)->(string)',op_string_fold,0,line,0) + call dcl_proc(parser,'abs(int_literal)->(int_literal)',op_abs_fold,0,line,0) + call dcl_proc(parser,'~(int_literal)->(int_literal)',op_bnot_fold,0,line,0) + call dcl_proc(parser,'&(int_literal,int_literal)->(int_literal)',op_band_fold,0,line,0) + call dcl_proc(parser,'|(int_literal,int_literal)->(int_literal)',op_bor_fold,0,line,0) + call dcl_proc(parser,'xor(int_literal,int_literal)->(int_literal)',op_bxor_fold,0,line,0) + call dcl_proc(parser,'shift(int_literal,int_literal)->(int_literal)',& + op_bshift_fold,0,line,0) + call dcl_proc(parser,'pdiff(int_literal,int_literal)->(int_literal)',op_pdiff_fold,0,line,0) + call dcl_proc(parser,'sign(int_literal,int_literal)->(int_literal)',op_sign_fold,0,line,0) + call dcl_proc(parser,'rem(int_literal,int_literal)->(int_literal)',op_modulo_fold,0,line,0) + call dcl_proc(parser,'and(bool_literal,bool_literal)->(bool_literal)',op_and_fold,0,line,0) + call dcl_proc(parser,'or(bool_literal,bool_literal)->(bool_literal)',op_or_fold,0,line,0) + call dcl_proc(parser,'except(bool_literal,bool_literal)->(bool_literal)',op_except_fold,0,line,0) + call dcl_proc(parser,'==(bool_literal,bool_literal)->(bool_literal)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(bool_literal,bool_literal)->(bool_literal)',op_ne_fold,0,line,0) + call dcl_proc(parser,'==(string_literal,string_literal)->(bool_literal)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(string_literal,string_literal)->(bool_literal)',op_ne_fold,0,line,0) + call dcl_proc(parser,'==(real_literal,real_literal)->(bool_literal)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(real_literal,real_literal)->(bool_literal)',op_ne_fold,0,line,0) + call dcl_proc(parser,'++(string_literal,string_literal)->(string_literal)',op_concat_fold,0,line,0) + + call dcl_proc(parser,'mod(fix int,fix int)->(fix int)',op_mod_fold,0,line,0) + call dcl_proc(parser,'==(fix int,fix int)->(fix bool)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(fix int,fix int)->(fix bool)',op_ne_fold,0,line,0) + call dcl_proc(parser,'>=(fix int,fix int)->(fix bool)',op_ge_fold,0,line,0) + call dcl_proc(parser,'>(fix int,fix int)->(fix bool)',op_gt_fold,0,line,0) + call dcl_proc(parser,'+(fix int,fix int)->(fix int)',op_add_fold,0,line,0) + call dcl_proc(parser,'-(fix int,fix int)->(fix int)',op_sub_fold,0,line,0) + call dcl_proc(parser,'*(fix int,fix int)->(fix int)',op_mult_fold,0,line,0) + call dcl_proc(parser,'/(fix int,fix int)->(fix int)',op_divide_fold,0,line,0) + call dcl_proc(parser,'**(fix int,fix int)->(fix int)',op_pow_fold,0,line,0) + call dcl_proc(parser,'max(fix int,fix int)->(fix int)',op_max_fold,0,line,0) + call dcl_proc(parser,'min(fix int,fix int)->(fix int)',op_min_fold,0,line,0) + call dcl_proc(parser,'-(fix int)->(fix int)',op_uminus_fold,0,line,0) + call dcl_proc(parser,'string(fix int)->(string)',op_string_fold,0,line,0) + call dcl_proc(parser,'abs(fix int)->(fix int)',op_abs_fold,0,line,0) + call dcl_proc(parser,'~(fix int)->(fix int)',op_bnot_fold,0,line,0) + call dcl_proc(parser,'&(fix int,fix int)->(fix int)',op_band_fold,0,line,0) + call dcl_proc(parser,'|(fix int,fix int)->(fix int)',op_bor_fold,0,line,0) + call dcl_proc(parser,'xor(fix int,fix int)->(fix int)',op_bxor_fold,0,line,0) + call dcl_proc(parser,'shift(fix int,fix int)->(fix int)',& + op_bshift_fold,0,line,0) + call dcl_proc(parser,'pdiff(fix int,fix int)->(fix int)',op_pdiff_fold,0,line,0) + call dcl_proc(parser,'sign(fix int,fix int)->(fix int)',op_sign_fold,0,line,0) + call dcl_proc(parser,'rem(fix int,fix int)->(fix int)',op_modulo_fold,0,line,0) + call dcl_proc(parser,'and(fix bool,fix bool)->(fix bool)',op_and_fold,0,line,0) + call dcl_proc(parser,'or(fix bool,fix bool)->(fix bool)',op_or_fold,0,line,0) + call dcl_proc(parser,'except(fix bool,fix bool)->(fix bool)',op_except_fold,0,line,0) + call dcl_proc(parser,'==(fix bool,fix bool)->(fix bool)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(fix bool,fix bool)->(fix bool)',op_ne_fold,0,line,0) + call dcl_proc(parser,'==(fix string,fix string)->(fix bool)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(fix string,fix string)->(fix bool)',op_ne_fold,0,line,0) + call dcl_proc(parser,'==(fix real,fix real)->(fix bool)',op_eq_fold,0,line,0) + call dcl_proc(parser,'/=(fix real,fix real)->(fix bool)',op_ne_fold,0,line,0) + call dcl_proc(parser,'++(fix string,fix string)->(fix string)',op_concat_fold,0,line,0) + ! ************************************** ! BASIC TYPES ! ************************************** @@ -81,7 +147,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'print(x) { print(string(x)) }',line) call dcl_proc(parser,'print_all(string)',op_print,1,line,proc_is_impure) call dcl_uproc(parser,'print_all(x) { print_all(string(x)) }',line) - call dcl_proc(parser,'++(string,string)->string',op_concat,0,line,0) + call dcl_proc(parser,'++(string,string)->(string)',op_concat,0,line,0) call dcl_uproc(parser,'++(x:string,y)=$++.(x,string(y))',line) call dcl_uproc(parser,'++(x,y)=$++.(string(x),string(y))',line) call dcl_uproc(parser,'string(x:string)=x',line) @@ -91,469 +157,469 @@ subroutine sysdefs(parser) ! sint type call dcl_proc(parser,'PM__assign_var(&sint,sint)',& op_assign_i,0,line,0) - call dcl_proc(parser,'mod(sint,sint)->sint',op_mod_i,0,line,0) - call dcl_proc(parser,'==(sint,sint)->bool',op_eq_i,0,line,0) - call dcl_proc(parser,'/=(sint,sint)->bool',op_ne_i,0,line,0) - call dcl_proc(parser,'>=(sint,sint)->bool',op_ge_i,0,line,0) - call dcl_proc(parser,'>(sint,sint)->bool',op_gt_i,0,line,0) - call dcl_proc(parser,'+(sint,sint)->sint',op_add_i,0,line,0) - call dcl_proc(parser,'-(sint,sint)->sint',op_sub_i,0,line,0) - call dcl_proc(parser,'*(sint,sint)->sint',op_mult_i,0,line,0) - call dcl_proc(parser,'/(sint,sint)->sint',op_divide_i,0,line,0) - call dcl_proc(parser,'**(sint,sint)->sint',op_pow_i,0,line,0) - call dcl_proc(parser,'max(sint,sint)->sint',op_max_i,0,line,0) - call dcl_proc(parser,'min(sint,sint)->sint',op_min_i,0,line,0) - call dcl_proc(parser,'-(sint)->sint',op_uminus_i,0,line,0) - call dcl_proc(parser,'string(sint)->string',op_string_i,0,line,0) - call dcl_proc(parser,'int(sint)->int',op_long_i,0,line,0) - call dcl_proc(parser,'sreal(sint)->sreal',op_real_i,0,line,0) - call dcl_proc(parser,'real(sint)->real',op_double_i,0,line,0) + call dcl_proc(parser,'mod(sint,sint)->(sint)',op_mod_i,0,line,0) + call dcl_proc(parser,'==(sint,sint)->(bool)',op_eq_i,0,line,0) + call dcl_proc(parser,'/=(sint,sint)->(bool)',op_ne_i,0,line,0) + call dcl_proc(parser,'>=(sint,sint)->(bool)',op_ge_i,0,line,0) + call dcl_proc(parser,'>(sint,sint)->(bool)',op_gt_i,0,line,0) + call dcl_proc(parser,'+(sint,sint)->(sint)',op_add_i,0,line,0) + call dcl_proc(parser,'-(sint,sint)->(sint)',op_sub_i,0,line,0) + call dcl_proc(parser,'*(sint,sint)->(sint)',op_mult_i,0,line,0) + call dcl_proc(parser,'/(sint,sint)->(sint)',op_divide_i,0,line,0) + call dcl_proc(parser,'**(sint,sint)->(sint)',op_pow_i,0,line,0) + call dcl_proc(parser,'max(sint,sint)->(sint)',op_max_i,0,line,0) + call dcl_proc(parser,'min(sint,sint)->(sint)',op_min_i,0,line,0) + call dcl_proc(parser,'-(sint)->(sint)',op_uminus_i,0,line,0) + call dcl_proc(parser,'string(sint)->(string)',op_string_i,0,line,0) + call dcl_proc(parser,'int(sint)->(int)',op_long_i,0,line,0) + call dcl_proc(parser,'sreal(sint)->(sreal)',op_real_i,0,line,0) + call dcl_proc(parser,'real(sint)->(real)',op_double_i,0,line,0) call dcl_uproc(parser,'sint(x:sint)=x',line) - call dcl_proc(parser,'abs(sint)->sint',op_abs_i,0,line,0) - call dcl_proc(parser,'bit_not(sint)->sint',op_bnot_i,0,line,0) - call dcl_proc(parser,'&(sint,sint)->sint',op_band_i,0,line,0) - call dcl_proc(parser,'|(sint,sint)->sint',op_bor_i,0,line,0) - call dcl_proc(parser,'xor(sint,sint)->sint',op_bxor_i,0,line,0) - call dcl_proc(parser,'shift(sint,sint)->sint',op_bshift_i,0,line,0) - call dcl_proc(parser,'pdiff(sint,sint)->sint',op_pdiff_i,0,line,0) - call dcl_proc(parser,'sign(sint,sint)->sint',op_sign_i,0,line,0) - call dcl_proc(parser,'rem(sint,sint)->sint',op_modulo_i,0,line,0) - call dcl_proc(parser,'int8(sint)->int8',op_i8_i,0,line,0) - call dcl_proc(parser,'int16(sint)->int16',op_i16_i,0,line,0) - call dcl_proc(parser,'int32(sint)->int32',op_i32_i,0,line,0) - call dcl_proc(parser,'int64(sint)->int64',op_i64_i,0,line,0) - call dcl_proc(parser,'lint(sint)->lint',op_offset_i,0,line,0) + call dcl_proc(parser,'abs(sint)->(sint)',op_abs_i,0,line,0) + call dcl_proc(parser,'bit_not(sint)->(sint)',op_bnot_i,0,line,0) + call dcl_proc(parser,'&(sint,sint)->(sint)',op_band_i,0,line,0) + call dcl_proc(parser,'|(sint,sint)->(sint)',op_bor_i,0,line,0) + call dcl_proc(parser,'xor(sint,sint)->(sint)',op_bxor_i,0,line,0) + call dcl_proc(parser,'shift(sint,sint)->(sint)',op_bshift_i,0,line,0) + call dcl_proc(parser,'pdiff(sint,sint)->(sint)',op_pdiff_i,0,line,0) + call dcl_proc(parser,'sign(sint,sint)->(sint)',op_sign_i,0,line,0) + call dcl_proc(parser,'rem(sint,sint)->(sint)',op_modulo_i,0,line,0) + call dcl_proc(parser,'int8(sint)->(int8)',op_i8_i,0,line,0) + call dcl_proc(parser,'int16(sint)->(int16)',op_i16_i,0,line,0) + call dcl_proc(parser,'int32(sint)->(int32)',op_i32_i,0,line,0) + call dcl_proc(parser,'int64(sint)->(int64)',op_i64_i,0,line,0) + call dcl_proc(parser,'lint(sint)->(lint)',op_offset_i,0,line,0) ! int type call dcl_proc(parser,'PM__assign_var(&int,int)',& op_assign_ln,0,line,0) - call dcl_proc(parser,'mod(int,int)->''int',op_mod_ln,0,line,0) - call dcl_proc(parser,'==(int,int)->''bool',op_eq_ln,0,line,0) - call dcl_proc(parser,'/=(int,int)->''bool',op_ne_ln,0,line,0) - call dcl_proc(parser,'>=(int,int)->''bool',op_ge_ln,0,line,0) - call dcl_proc(parser,'>(int,int)->''bool',op_gt_ln,0,line,0) - call dcl_proc(parser,'+(int,int)->''int',op_add_ln,0,line,0) - call dcl_uproc(parser,'+(x:int,y:''0)=x',line) - call dcl_uproc(parser,'+(x:''0,y:int)=y',line) - call dcl_proc(parser,'-(int,int)->''int',op_sub_ln,0,line,0) - call dcl_uproc(parser,'-(x:int,y:''0)=x',line) - call dcl_proc(parser,'*(int,int)->''int',op_mult_ln,0,line,0) + call dcl_proc(parser,'mod(int,int)->(int)',op_mod_ln,0,line,0) + call dcl_proc(parser,'==(int,int)->(bool)',op_eq_ln,0,line,0) + call dcl_proc(parser,'/=(int,int)->(bool)',op_ne_ln,0,line,0) + call dcl_proc(parser,'>=(int,int)->(bool)',op_ge_ln,0,line,0) + call dcl_proc(parser,'>(int,int)->(bool)',op_gt_ln,0,line,0) + call dcl_proc(parser,'+(int,int)->(int)',op_add_ln,0,line,0) +!!$ call dcl_uproc(parser,'+(x:int,y:''0)=x',line) +!!$ call dcl_uproc(parser,'+(x:''0,y:int)=y',line) + call dcl_proc(parser,'-(int,int)->(int)',op_sub_ln,0,line,0) +!!$ call dcl_uproc(parser,'-(x:int,y:''0)=x',line) + call dcl_proc(parser,'*(int,int)->(int)',op_mult_ln,0,line,0) call dcl_uproc(parser,'*(x:int,y:''1)=x',line) - call dcl_uproc(parser,'*(x:''1,y:int)=y',line) - call dcl_proc(parser,'/(int,int)->''int',op_divide_ln,0,line,0) +!!$ call dcl_uproc(parser,'*(x:''1,y:int)=y',line) + call dcl_proc(parser,'/(int,int)->(int)',op_divide_ln,0,line,0) call dcl_uproc(parser,'/(x:int,y:''1)=x',line) - call dcl_proc(parser,'**(int,int)->''int',op_pow_ln,0,line,0) - call dcl_uproc(parser,'**(x:int,y:''0)=1',line) - call dcl_uproc(parser,'**(x:int,y:''1)=x',line) - call dcl_uproc(parser,'**(x:int,y:''2)=x*x',line) - call dcl_proc(parser,'max(int,int)->''int',op_max_ln,0,line,0) - call dcl_proc(parser,'min(int,int)->''int',op_min_ln,0,line,0) - call dcl_proc(parser,'-(int)->''int',op_uminus_ln,0,line,0) - call dcl_proc(parser,'string(int)->string',op_string_ln,0,line,0) - call dcl_proc(parser,'sint(int)->sint',op_int_ln,0,line,0) - call dcl_proc(parser,'sreal(int)->sreal',op_real_ln,0,line,0) - call dcl_proc(parser,'real(int)->real',op_double_ln,0,line,0) + call dcl_proc(parser,'**(int,int)->(int)',op_pow_ln,0,line,0) +!!$ call dcl_uproc(parser,'**(x:int,y:''0)=1',line) +!!$ call dcl_uproc(parser,'**(x:int,y:''1)=x',line) +!!$ call dcl_uproc(parser,'**(x:int,y:''2)=x*x',line) + call dcl_proc(parser,'max(int,int)->(int)',op_max_ln,0,line,0) + call dcl_proc(parser,'min(int,int)->(int)',op_min_ln,0,line,0) + call dcl_proc(parser,'-(int)->(int)',op_uminus_ln,0,line,0) + call dcl_proc(parser,'string(int)->(string)',op_string_ln,0,line,0) + call dcl_proc(parser,'sint(int)->(sint)',op_int_ln,0,line,0) + call dcl_proc(parser,'sreal(int)->(sreal)',op_real_ln,0,line,0) + call dcl_proc(parser,'real(int)->(real)',op_double_ln,0,line,0) call dcl_uproc(parser,'int(x:int)=x',line) - call dcl_proc(parser,'abs(int)->int',op_abs_ln,0,line,0) - call dcl_proc(parser,'!(int)->int',op_bnot_ln,0,line,0) - call dcl_proc(parser,'&(int,int)->int',op_band_ln,0,line,0) - call dcl_proc(parser,'|(int,int)->int',op_bor_ln,0,line,0) - call dcl_proc(parser,'xor(int,int)->int',op_bxor_ln,0,line,0) - call dcl_proc(parser,'shift(int,int)->int',& + call dcl_proc(parser,'abs(int)->(int)',op_abs_ln,0,line,0) + call dcl_proc(parser,'~(int)->(int)',op_bnot_ln,0,line,0) + call dcl_proc(parser,'&(int,int)->(int)',op_band_ln,0,line,0) + call dcl_proc(parser,'|(int,int)->(int)',op_bor_ln,0,line,0) + call dcl_proc(parser,'xor(int,int)->(int)',op_bxor_ln,0,line,0) + call dcl_proc(parser,'shift(int,int)->(int)',& op_bshift_ln,0,line,0) - call dcl_proc(parser,'pdiff(int,int)->''int',op_pdiff_ln,0,line,0) - call dcl_proc(parser,'sign(int,int)->''int',op_sign_ln,0,line,0) - call dcl_proc(parser,'rem(int,int)->''int',op_modulo_ln,0,line,0) - call dcl_proc(parser,'int8(int)->int8',op_i8_ln,0,line,0) - call dcl_proc(parser,'int16(int)->int16',op_i16_ln,0,line,0) - call dcl_proc(parser,'int32(int)->int32',op_i32_ln,0,line,0) - call dcl_proc(parser,'int64(int)->int64',op_i64_ln,0,line,0) - call dcl_proc(parser,'lint(int)->lint',op_offset_ln,0,line,0) + call dcl_proc(parser,'pdiff(int,int)->(int)',op_pdiff_ln,0,line,0) + call dcl_proc(parser,'sign(int,int)->(int)',op_sign_ln,0,line,0) + call dcl_proc(parser,'rem(int,int)->(int)',op_modulo_ln,0,line,0) + call dcl_proc(parser,'int8(int)->(int8)',op_i8_ln,0,line,0) + call dcl_proc(parser,'int16(int)->(int16)',op_i16_ln,0,line,0) + call dcl_proc(parser,'int32(int)->(int32)',op_i32_ln,0,line,0) + call dcl_proc(parser,'int64(int)->(int64)',op_i64_ln,0,line,0) + call dcl_proc(parser,'lint(int)->(lint)',op_offset_ln,0,line,0) ! lint type call dcl_proc(parser,'PM__assign_var(&lint,lint)',& op_assign_offset,0,line,0) - call dcl_proc(parser,'mod(lint,lint)->lint',op_mod_offset,0,line,0) - call dcl_proc(parser,'==(lint,lint)->bool',op_eq_offset,0,line,0) - call dcl_proc(parser,'/=(lint,lint)->bool',op_ne_offset,0,line,0) - call dcl_proc(parser,'>=(lint,lint)->bool',op_ge_offset,0,line,0) - call dcl_proc(parser,'>(lint,lint)->bool',op_gt_offset,0,line,0) - call dcl_proc(parser,'+(lint,lint)->lint',op_add_offset,0,line,0) + call dcl_proc(parser,'mod(lint,lint)->(lint)',op_mod_offset,0,line,0) + call dcl_proc(parser,'==(lint,lint)->(bool)',op_eq_offset,0,line,0) + call dcl_proc(parser,'/=(lint,lint)->(bool)',op_ne_offset,0,line,0) + call dcl_proc(parser,'>=(lint,lint)->(bool)',op_ge_offset,0,line,0) + call dcl_proc(parser,'>(lint,lint)->(bool)',op_gt_offset,0,line,0) + call dcl_proc(parser,'+(lint,lint)->(lint)',op_add_offset,0,line,0) call dcl_uproc(parser,'+(x:lint,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:lint)=y',line) - call dcl_proc(parser,'-(lint,lint)->lint',op_sub_offset,0,line,0) + call dcl_proc(parser,'-(lint,lint)->(lint)',op_sub_offset,0,line,0) call dcl_uproc(parser,'-(x:lint,y:''0)=x',line) - call dcl_proc(parser,'*(lint,lint)->lint',op_mult_offset,0,line,0) + call dcl_proc(parser,'*(lint,lint)->(lint)',op_mult_offset,0,line,0) call dcl_uproc(parser,'*(x:lint,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:lint)=y',line) - call dcl_proc(parser,'/(lint,lint)->lint',op_divide_offset,0,line,0) + call dcl_proc(parser,'/(lint,lint)->(lint)',op_divide_offset,0,line,0) call dcl_uproc(parser,'/(x:lint,y:''1)=x',line) - call dcl_proc(parser,'**(lint,lint)->lint',op_pow_offset,0,line,0) + call dcl_proc(parser,'**(lint,lint)->(lint)',op_pow_offset,0,line,0) call dcl_uproc(parser,'**(x:lint,y:''0)=1',line) call dcl_uproc(parser,'**(x:lint,y:''1)=x',line) call dcl_uproc(parser,'**(x:lint,y:''2)=x*x',line) - call dcl_proc(parser,'max(lint,lint)->lint',op_max_offset,0,line,0) - call dcl_proc(parser,'min(lint,lint)->lint',op_min_offset,0,line,0) - call dcl_proc(parser,'-(lint)->lint',op_uminus_offset,0,line,0) - call dcl_proc(parser,'string(lint)->string',op_string_offset,0,line,0) - call dcl_proc(parser,'sint(lint)->sint',op_int_offset,0,line,0) - call dcl_proc(parser,'sreal(lint)->sreal',op_real_offset,0,line,0) - call dcl_proc(parser,'real(lint)->real',op_double_offset,0,line,0) + call dcl_proc(parser,'max(lint,lint)->(lint)',op_max_offset,0,line,0) + call dcl_proc(parser,'min(lint,lint)->(lint)',op_min_offset,0,line,0) + call dcl_proc(parser,'-(lint)->(lint)',op_uminus_offset,0,line,0) + call dcl_proc(parser,'string(lint)->(string)',op_string_offset,0,line,0) + call dcl_proc(parser,'sint(lint)->(sint)',op_int_offset,0,line,0) + call dcl_proc(parser,'sreal(lint)->(sreal)',op_real_offset,0,line,0) + call dcl_proc(parser,'real(lint)->(real)',op_double_offset,0,line,0) call dcl_uproc(parser,'lint(x:lint)=x',line) - call dcl_proc(parser,'abs(lint)->lint',op_abs_offset,0,line,0) - call dcl_proc(parser,'!(lint)->lint',op_bnot_offset,0,line,0) - call dcl_proc(parser,'&(lint,lint)->lint',op_band_offset,0,line,0) - call dcl_proc(parser,'|(lint,lint)->lint',op_bor_offset,0,line,0) - call dcl_proc(parser,'xor(lint,lint)->lint',op_bxor_offset,0,line,0) - call dcl_proc(parser,'shift(lint,lint)->lint',& + call dcl_proc(parser,'abs(lint)->(lint)',op_abs_offset,0,line,0) + call dcl_proc(parser,'~(lint)->(lint)',op_bnot_offset,0,line,0) + call dcl_proc(parser,'&(lint,lint)->(lint)',op_band_offset,0,line,0) + call dcl_proc(parser,'|(lint,lint)->(lint)',op_bor_offset,0,line,0) + call dcl_proc(parser,'xor(lint,lint)->(lint)',op_bxor_offset,0,line,0) + call dcl_proc(parser,'shift(lint,lint)->(lint)',& op_bshift_offset,0,line,0) - call dcl_proc(parser,'pdiff(lint,lint)->lint',op_pdiff_offset,0,line,0) - call dcl_proc(parser,'sign(lint,lint)->lint',op_sign_offset,0,line,0) - call dcl_proc(parser,'rem(lint,lint)->lint',op_modulo_offset,0,line,0) - call dcl_proc(parser,'int8(lint)->int8',op_i8_offset,0,line,0) - call dcl_proc(parser,'int16(lint)->int16',op_i16_offset,0,line,0) - call dcl_proc(parser,'int32(lint)->int32',op_i32_offset,0,line,0) - call dcl_proc(parser,'int64(lint)->int64',op_i64_offset,0,line,0) - call dcl_proc(parser,'int(lint)->int',op_long_offset,0,line,0) + call dcl_proc(parser,'pdiff(lint,lint)->(lint)',op_pdiff_offset,0,line,0) + call dcl_proc(parser,'sign(lint,lint)->(lint)',op_sign_offset,0,line,0) + call dcl_proc(parser,'rem(lint,lint)->(lint)',op_modulo_offset,0,line,0) + call dcl_proc(parser,'int8(lint)->(int8)',op_i8_offset,0,line,0) + call dcl_proc(parser,'int16(lint)->(int16)',op_i16_offset,0,line,0) + call dcl_proc(parser,'int32(lint)->(int32)',op_i32_offset,0,line,0) + call dcl_proc(parser,'int64(lint)->(int64)',op_i64_offset,0,line,0) + call dcl_proc(parser,'int(lint)->(int)',op_long_offset,0,line,0) ! int8 type call dcl_proc(parser,'PM__assign_var(&int8,int8)',& op_assign_i8,0,line,0) - call dcl_proc(parser,'mod(int8,int8)->int8',op_mod_i8,0,line,0) - call dcl_proc(parser,'==(int8,int8)->bool',op_eq_i8,0,line,0) - call dcl_proc(parser,'/=(int8,int8)->bool',op_ne_i8,0,line,0) - call dcl_proc(parser,'>=(int8,int8)->bool',op_ge_i8,0,line,0) - call dcl_proc(parser,'>(int8,int8)->bool',op_gt_i8,0,line,0) - call dcl_proc(parser,'+(int8,int8)->int8',op_add_i8,0,line,0) + call dcl_proc(parser,'mod(int8,int8)->(int8)',op_mod_i8,0,line,0) + call dcl_proc(parser,'==(int8,int8)->(bool)',op_eq_i8,0,line,0) + call dcl_proc(parser,'/=(int8,int8)->(bool)',op_ne_i8,0,line,0) + call dcl_proc(parser,'>=(int8,int8)->(bool)',op_ge_i8,0,line,0) + call dcl_proc(parser,'>(int8,int8)->(bool)',op_gt_i8,0,line,0) + call dcl_proc(parser,'+(int8,int8)->(int8)',op_add_i8,0,line,0) call dcl_uproc(parser,'+(x:int8,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:int8)=y',line) - call dcl_proc(parser,'-(int8,int8)->int8',op_sub_i8,0,line,0) + call dcl_proc(parser,'-(int8,int8)->(int8)',op_sub_i8,0,line,0) call dcl_uproc(parser,'-(x:int8,y:''0)=x',line) - call dcl_proc(parser,'*(int8,int8)->int8',op_mult_i8,0,line,0) + call dcl_proc(parser,'*(int8,int8)->(int8)',op_mult_i8,0,line,0) call dcl_uproc(parser,'*(x:int8,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:int8)=y',line) - call dcl_proc(parser,'/(int8,int8)->int8',op_divide_i8,0,line,0) + call dcl_proc(parser,'/(int8,int8)->(int8)',op_divide_i8,0,line,0) call dcl_uproc(parser,'/(x:int8,y:''1)=x',line) - call dcl_proc(parser,'**(int8,int8)->int8',op_pow_i8,0,line,0) + call dcl_proc(parser,'**(int8,int8)->(int8)',op_pow_i8,0,line,0) call dcl_uproc(parser,'**(x:int8,y:''0)=1',line) call dcl_uproc(parser,'**(x:int8,y:''1)=x',line) call dcl_uproc(parser,'**(x:int8,y:''2)=x*x',line) - call dcl_proc(parser,'max(int8,int8)->int8',op_max_i8,0,line,0) - call dcl_proc(parser,'min(int8,int8)->int8',op_min_i8,0,line,0) - call dcl_proc(parser,'-(int8)->int8',op_uminus_i8,0,line,0) - call dcl_proc(parser,'sint(int8)->sint',op_int_i8,0,line,0) - call dcl_proc(parser,'sreal(int8)->sreal',op_real_i8,0,line,0) - call dcl_proc(parser,'real(int8)->real',op_double_i8,0,line,0) + call dcl_proc(parser,'max(int8,int8)->(int8)',op_max_i8,0,line,0) + call dcl_proc(parser,'min(int8,int8)->(int8)',op_min_i8,0,line,0) + call dcl_proc(parser,'-(int8)->(int8)',op_uminus_i8,0,line,0) + call dcl_proc(parser,'sint(int8)->(sint)',op_int_i8,0,line,0) + call dcl_proc(parser,'sreal(int8)->(sreal)',op_real_i8,0,line,0) + call dcl_proc(parser,'real(int8)->(real)',op_double_i8,0,line,0) call dcl_uproc(parser,'int8(x:int8)=x',line) - call dcl_proc(parser,'abs(int8)->int8',op_abs_i8,0,line,0) - call dcl_proc(parser,'!(int8)->int8',op_bnot_i8,0,line,0) - call dcl_proc(parser,'&(int8,int8)->int8',op_band_i8,0,line,0) - call dcl_proc(parser,'|(int8,int8)->int8',op_bor_i8,0,line,0) - call dcl_proc(parser,'xor(int8,int8)->int8',op_bxor_i8,0,line,0) - call dcl_proc(parser,'shift(int8,int8)->int8',& + call dcl_proc(parser,'abs(int8)->(int8)',op_abs_i8,0,line,0) + call dcl_proc(parser,'~(int8)->(int8)',op_bnot_i8,0,line,0) + call dcl_proc(parser,'&(int8,int8)->(int8)',op_band_i8,0,line,0) + call dcl_proc(parser,'|(int8,int8)->(int8)',op_bor_i8,0,line,0) + call dcl_proc(parser,'xor(int8,int8)->(int8)',op_bxor_i8,0,line,0) + call dcl_proc(parser,'shift(int8,int8)->(int8)',& op_bshift_i8,0,line,0) - call dcl_proc(parser,'pdiff(int8,int8)->int8',op_pdiff_i8,0,line,0) - call dcl_proc(parser,'sign(int8,int8)->int8',op_sign_i8,0,line,0) - call dcl_proc(parser,'rem(int8,int8)->int8',op_modulo_i8,0,line,0) - call dcl_proc(parser,'int16(int8)->int16',op_i16_i8,0,line,0) - call dcl_proc(parser,'int32(int8)->int32',op_i32_i8,0,line,0) - call dcl_proc(parser,'int64(int8)->int64',op_i64_i8,0,line,0) - call dcl_proc(parser,'int(int8)->int',op_long_i8,0,line,0) - call dcl_proc(parser,'lint(int8)->lint',op_offset_i8,0,line,0) + call dcl_proc(parser,'pdiff(int8,int8)->(int8)',op_pdiff_i8,0,line,0) + call dcl_proc(parser,'sign(int8,int8)->(int8)',op_sign_i8,0,line,0) + call dcl_proc(parser,'rem(int8,int8)->(int8)',op_modulo_i8,0,line,0) + call dcl_proc(parser,'int16(int8)->(int16)',op_i16_i8,0,line,0) + call dcl_proc(parser,'int32(int8)->(int32)',op_i32_i8,0,line,0) + call dcl_proc(parser,'int64(int8)->(int64)',op_i64_i8,0,line,0) + call dcl_proc(parser,'int(int8)->(int)',op_long_i8,0,line,0) + call dcl_proc(parser,'lint(int8)->(lint)',op_offset_i8,0,line,0) ! int16 type call dcl_proc(parser,'PM__assign_var(&int16,int16)',& op_assign_i16,0,line,0) - call dcl_proc(parser,'mod(int16,int16)->int16',op_mod_i16,0,line,0) - call dcl_proc(parser,'==(int16,int16)->bool',op_eq_i16,0,line,0) - call dcl_proc(parser,'/=(int16,int16)->bool',op_ne_i16,0,line,0) - call dcl_proc(parser,'>=(int16,int16)->bool',op_ge_i16,0,line,0) - call dcl_proc(parser,'>(int16,int16)->bool',op_gt_i16,0,line,0) - call dcl_proc(parser,'+(int16,int16)->int16',op_add_i16,0,line,0) + call dcl_proc(parser,'mod(int16,int16)->(int16)',op_mod_i16,0,line,0) + call dcl_proc(parser,'==(int16,int16)->(bool)',op_eq_i16,0,line,0) + call dcl_proc(parser,'/=(int16,int16)->(bool)',op_ne_i16,0,line,0) + call dcl_proc(parser,'>=(int16,int16)->(bool)',op_ge_i16,0,line,0) + call dcl_proc(parser,'>(int16,int16)->(bool)',op_gt_i16,0,line,0) + call dcl_proc(parser,'+(int16,int16)->(int16)',op_add_i16,0,line,0) call dcl_uproc(parser,'+(x:int16,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:int16)=y',line) - call dcl_proc(parser,'-(int16,int16)->int16',op_sub_i16,0,line,0) + call dcl_proc(parser,'-(int16,int16)->(int16)',op_sub_i16,0,line,0) call dcl_uproc(parser,'-(x:int16,y:''0)=x',line) - call dcl_proc(parser,'*(int16,int16)->int16',op_mult_i16,0,line,0) + call dcl_proc(parser,'*(int16,int16)->(int16)',op_mult_i16,0,line,0) call dcl_uproc(parser,'*(x:int16,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:int16)=y',line) - call dcl_proc(parser,'/(int16,int16)->int16',op_divide_i16,0,line,0) + call dcl_proc(parser,'/(int16,int16)->(int16)',op_divide_i16,0,line,0) call dcl_uproc(parser,'/(x:int16,y:''1)=x',line) - call dcl_proc(parser,'**(int16,int16)->int16',op_pow_i16,0,line,0) + call dcl_proc(parser,'**(int16,int16)->(int16)',op_pow_i16,0,line,0) call dcl_uproc(parser,'**(x:int16,y:''0)=1',line) call dcl_uproc(parser,'**(x:int16,y:''1)=x',line) call dcl_uproc(parser,'**(x:int16,y:''2)=x*x',line) - call dcl_proc(parser,'max(int16,int16)->int16',op_max_i16,0,line,0) - call dcl_proc(parser,'min(int16,int16)->int16',op_min_i16,0,line,0) - call dcl_proc(parser,'-(int16)->int16',op_uminus_i16,0,line,0) - call dcl_proc(parser,'sint(int16)->sint',op_int_i16,0,line,0) - call dcl_proc(parser,'sreal(int16)->sreal',op_real_i16,0,line,0) - call dcl_proc(parser,'real(int16)->real',op_double_i16,0,line,0) + call dcl_proc(parser,'max(int16,int16)->(int16)',op_max_i16,0,line,0) + call dcl_proc(parser,'min(int16,int16)->(int16)',op_min_i16,0,line,0) + call dcl_proc(parser,'-(int16)->(int16)',op_uminus_i16,0,line,0) + call dcl_proc(parser,'sint(int16)->(sint)',op_int_i16,0,line,0) + call dcl_proc(parser,'sreal(int16)->(sreal)',op_real_i16,0,line,0) + call dcl_proc(parser,'real(int16)->(real)',op_double_i16,0,line,0) call dcl_uproc(parser,'int16(x:int16)=x',line) - call dcl_proc(parser,'abs(int16)->int16',op_abs_i16,0,line,0) - call dcl_proc(parser,'!(int16)->int16',op_bnot_i16,0,line,0) - call dcl_proc(parser,'&(int16,int16)->int16',op_band_i16,0,line,0) - call dcl_proc(parser,'|(int16,int16)->int16',op_bor_i16,0,line,0) - call dcl_proc(parser,'xor(int16,int16)->int16',op_bxor_i16,0,line,0) - call dcl_proc(parser,'shift(int16,int16)->int16',& + call dcl_proc(parser,'abs(int16)->(int16)',op_abs_i16,0,line,0) + call dcl_proc(parser,'~(int16)->(int16)',op_bnot_i16,0,line,0) + call dcl_proc(parser,'&(int16,int16)->(int16)',op_band_i16,0,line,0) + call dcl_proc(parser,'|(int16,int16)->(int16)',op_bor_i16,0,line,0) + call dcl_proc(parser,'xor(int16,int16)->(int16)',op_bxor_i16,0,line,0) + call dcl_proc(parser,'shift(int16,int16)->(int16)',& op_bshift_i16,0,line,0) - call dcl_proc(parser,'pdiff(int16,int16)->int16',op_pdiff_i16,0,line,0) - call dcl_proc(parser,'sign(int16,int16)->int16',op_sign_i16,0,line,0) - call dcl_proc(parser,'rem(int16,int16)->int16',op_modulo_i16,0,line,0) - call dcl_proc(parser,'int8(int16)->int16',op_i8_i16,0,line,0) - call dcl_proc(parser,'int32(int16)->int32',op_i32_i16,0,line,0) - call dcl_proc(parser,'int64(int16)->int64',op_i64_i16,0,line,0) - call dcl_proc(parser,'int(int16)->int',op_long_i16,0,line,0) - call dcl_proc(parser,'lint(int16)->lint',op_offset_i16,0,line,0) + call dcl_proc(parser,'pdiff(int16,int16)->(int16)',op_pdiff_i16,0,line,0) + call dcl_proc(parser,'sign(int16,int16)->(int16)',op_sign_i16,0,line,0) + call dcl_proc(parser,'rem(int16,int16)->(int16)',op_modulo_i16,0,line,0) + call dcl_proc(parser,'int8(int16)->(int16)',op_i8_i16,0,line,0) + call dcl_proc(parser,'int32(int16)->(int32)',op_i32_i16,0,line,0) + call dcl_proc(parser,'int64(int16)->(int64)',op_i64_i16,0,line,0) + call dcl_proc(parser,'int(int16)->(int)',op_long_i16,0,line,0) + call dcl_proc(parser,'lint(int16)->(lint)',op_offset_i16,0,line,0) ! int32 type call dcl_proc(parser,'PM__assign_var(&int32,int32)',& op_assign_i32,0,line,0) - call dcl_proc(parser,'mod(int32,int32)->int32',op_mod_i32,0,line,0) - call dcl_proc(parser,'==(int32,int32)->bool',op_eq_i32,0,line,0) - call dcl_proc(parser,'/=(int32,int32)->bool',op_ne_i32,0,line,0) - call dcl_proc(parser,'>=(int32,int32)->bool',op_ge_i32,0,line,0) - call dcl_proc(parser,'>(int32,int32)->bool',op_gt_i32,0,line,0) - call dcl_proc(parser,'+(int32,int32)->int32',op_add_i32,0,line,0) + call dcl_proc(parser,'mod(int32,int32)->(int32)',op_mod_i32,0,line,0) + call dcl_proc(parser,'==(int32,int32)->(bool)',op_eq_i32,0,line,0) + call dcl_proc(parser,'/=(int32,int32)->(bool)',op_ne_i32,0,line,0) + call dcl_proc(parser,'>=(int32,int32)->(bool)',op_ge_i32,0,line,0) + call dcl_proc(parser,'>(int32,int32)->(bool)',op_gt_i32,0,line,0) + call dcl_proc(parser,'+(int32,int32)->(int32)',op_add_i32,0,line,0) call dcl_uproc(parser,'+(x:int32,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:int32)=y',line) - call dcl_proc(parser,'-(int32,int32)->int32',op_sub_i32,0,line,0) + call dcl_proc(parser,'-(int32,int32)->(int32)',op_sub_i32,0,line,0) call dcl_uproc(parser,'-(x:int32,y:''0)=x',line) - call dcl_proc(parser,'*(int32,int32)->int32',op_mult_i32,0,line,0) + call dcl_proc(parser,'*(int32,int32)->(int32)',op_mult_i32,0,line,0) call dcl_uproc(parser,'*(x:int32,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:int32)=y',line) - call dcl_proc(parser,'/(int32,int32)->int32',op_divide_i32,0,line,0) + call dcl_proc(parser,'/(int32,int32)->(int32)',op_divide_i32,0,line,0) call dcl_uproc(parser,'/(x:int32,y:''1)=x',line) - call dcl_proc(parser,'**(int32,int32)->int32',op_pow_i32,0,line,0) + call dcl_proc(parser,'**(int32,int32)->(int32)',op_pow_i32,0,line,0) call dcl_uproc(parser,'**(x:int32,y:''0)=1',line) call dcl_uproc(parser,'**(x:int32,y:''1)=x',line) call dcl_uproc(parser,'**(x:int32,y:''2)=x*x',line) - call dcl_proc(parser,'max(int32,int32)->int32',op_max_i32,0,line,0) - call dcl_proc(parser,'min(int32,int32)->int32',op_min_i32,0,line,0) - call dcl_proc(parser,'-(int32)->int32',op_uminus_i32,0,line,0) - call dcl_proc(parser,'sint(int32)->sint',op_int_i32,0,line,0) - call dcl_proc(parser,'sreal(int32)->sreal',op_real_i32,0,line,0) - call dcl_proc(parser,'real(int32)->real',op_double_i32,0,line,0) + call dcl_proc(parser,'max(int32,int32)->(int32)',op_max_i32,0,line,0) + call dcl_proc(parser,'min(int32,int32)->(int32)',op_min_i32,0,line,0) + call dcl_proc(parser,'-(int32)->(int32)',op_uminus_i32,0,line,0) + call dcl_proc(parser,'sint(int32)->(sint)',op_int_i32,0,line,0) + call dcl_proc(parser,'sreal(int32)->(sreal)',op_real_i32,0,line,0) + call dcl_proc(parser,'real(int32)->(real)',op_double_i32,0,line,0) call dcl_uproc(parser,'int32(x:int32)=x',line) - call dcl_proc(parser,'abs(int32)->int32',op_abs_i32,0,line,0) - call dcl_proc(parser,'!(int32)->int32',op_bnot_i32,0,line,0) - call dcl_proc(parser,'&(int32,int32)->int32',op_band_i32,0,line,0) - call dcl_proc(parser,'|(int32,int32)->int32',op_bor_i32,0,line,0) - call dcl_proc(parser,'xor(int32,int32)->int32',op_bxor_i32,0,line,0) - call dcl_proc(parser,'shift(int32,int32)->int32',& + call dcl_proc(parser,'abs(int32)->(int32)',op_abs_i32,0,line,0) + call dcl_proc(parser,'~(int32)->(int32)',op_bnot_i32,0,line,0) + call dcl_proc(parser,'&(int32,int32)->(int32)',op_band_i32,0,line,0) + call dcl_proc(parser,'|(int32,int32)->(int32)',op_bor_i32,0,line,0) + call dcl_proc(parser,'xor(int32,int32)->(int32)',op_bxor_i32,0,line,0) + call dcl_proc(parser,'shift(int32,int32)->(int32)',& op_bshift_i32,0,line,0) - call dcl_proc(parser,'pdiff(int32,int32)->int32',op_pdiff_i32,0,line,0) - call dcl_proc(parser,'sign(int32,int32)->int32',op_sign_i32,0,line,0) - call dcl_proc(parser,'rem(int32,int32)->int32',op_modulo_i32,0,line,0) - call dcl_proc(parser,'int8(int32)->int32',op_i8_i32,0,line,0) - call dcl_proc(parser,'int16(int32)->int32',op_i16_i32,0,line,0) - call dcl_proc(parser,'int64(int32)->int64',op_i64_i32,0,line,0) - call dcl_proc(parser,'int(int32)->int',op_long_i32,0,line,0) - call dcl_proc(parser,'lint(int32)->lint',op_offset_i32,0,line,0) + call dcl_proc(parser,'pdiff(int32,int32)->(int32)',op_pdiff_i32,0,line,0) + call dcl_proc(parser,'sign(int32,int32)->(int32)',op_sign_i32,0,line,0) + call dcl_proc(parser,'rem(int32,int32)->(int32)',op_modulo_i32,0,line,0) + call dcl_proc(parser,'int8(int32)->(int32)',op_i8_i32,0,line,0) + call dcl_proc(parser,'int16(int32)->(int32)',op_i16_i32,0,line,0) + call dcl_proc(parser,'int64(int32)->(int64)',op_i64_i32,0,line,0) + call dcl_proc(parser,'int(int32)->(int)',op_long_i32,0,line,0) + call dcl_proc(parser,'lint(int32)->(lint)',op_offset_i32,0,line,0) ! int64 type call dcl_proc(parser,'PM__assign_var(&int64,int64)',& op_assign_i64,0,line,0) - call dcl_proc(parser,'mod(int64,int64)->int64',op_mod_i64,0,line,0) - call dcl_proc(parser,'==(int64,int64)->bool',op_eq_i64,0,line,0) - call dcl_proc(parser,'/=(int64,int64)->bool',op_ne_i64,0,line,0) - call dcl_proc(parser,'>=(int64,int64)->bool',op_ge_i64,0,line,0) - call dcl_proc(parser,'>(int64,int64)->bool',op_gt_i64,0,line,0) - call dcl_proc(parser,'+(int64,int64)->int64',op_add_i64,0,line,0) + call dcl_proc(parser,'mod(int64,int64)->(int64)',op_mod_i64,0,line,0) + call dcl_proc(parser,'==(int64,int64)->(bool)',op_eq_i64,0,line,0) + call dcl_proc(parser,'/=(int64,int64)->(bool)',op_ne_i64,0,line,0) + call dcl_proc(parser,'>=(int64,int64)->(bool)',op_ge_i64,0,line,0) + call dcl_proc(parser,'>(int64,int64)->(bool)',op_gt_i64,0,line,0) + call dcl_proc(parser,'+(int64,int64)->(int64)',op_add_i64,0,line,0) call dcl_uproc(parser,'+(x:int64,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:int64)=y',line) - call dcl_proc(parser,'-(int64,int64)->int64',op_sub_i64,0,line,0) + call dcl_proc(parser,'-(int64,int64)->(int64)',op_sub_i64,0,line,0) call dcl_uproc(parser,'-(x:int64,y:''0)=x',line) - call dcl_proc(parser,'*(int64,int64)->int64',op_mult_i64,0,line,0) + call dcl_proc(parser,'*(int64,int64)->(int64)',op_mult_i64,0,line,0) call dcl_uproc(parser,'*(x:int64,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:int64)=y',line) - call dcl_proc(parser,'/(int64,int64)->int64',op_divide_i64,0,line,0) + call dcl_proc(parser,'/(int64,int64)->(int64)',op_divide_i64,0,line,0) call dcl_uproc(parser,'/(x:int64,y:''1)=x',line) - call dcl_proc(parser,'**(int64,int64)->int64',op_pow_i64,0,line,0) + call dcl_proc(parser,'**(int64,int64)->(int64)',op_pow_i64,0,line,0) call dcl_uproc(parser,'**(x:int64,y:''0)=1',line) call dcl_uproc(parser,'**(x:int64,y:''1)=x',line) call dcl_uproc(parser,'**(x:int64,y:''2)=x*x',line) - call dcl_proc(parser,'max(int64,int64)->int64',op_max_i64,0,line,0) - call dcl_proc(parser,'min(int64,int64)->int64',op_min_i64,0,line,0) - call dcl_proc(parser,'-(int64)->int64',op_uminus_i64,0,line,0) - call dcl_proc(parser,'string(int64)->string',op_string_i64,0,line,0) - call dcl_proc(parser,'sint(int64)->sint',op_int_i64,0,line,0) - call dcl_proc(parser,'sreal(int64)->sreal',op_real_i64,0,line,0) - call dcl_proc(parser,'real(int64)->real',op_double_i64,0,line,0) + call dcl_proc(parser,'max(int64,int64)->(int64)',op_max_i64,0,line,0) + call dcl_proc(parser,'min(int64,int64)->(int64)',op_min_i64,0,line,0) + call dcl_proc(parser,'-(int64)->(int64)',op_uminus_i64,0,line,0) + call dcl_proc(parser,'string(int64)->(string)',op_string_i64,0,line,0) + call dcl_proc(parser,'sint(int64)->(sint)',op_int_i64,0,line,0) + call dcl_proc(parser,'sreal(int64)->(sreal)',op_real_i64,0,line,0) + call dcl_proc(parser,'real(int64)->(real)',op_double_i64,0,line,0) call dcl_uproc(parser,'int64(x:int64)=x',line) - call dcl_proc(parser,'abs(int64)->int64',op_abs_i64,0,line,0) - call dcl_proc(parser,'!(int64)->int64',op_bnot_i64,0,line,0) - call dcl_proc(parser,'&(int64,int64)->int64',op_band_i64,0,line,0) - call dcl_proc(parser,'|(int64,int64)->int64',op_bor_i64,0,line,0) - call dcl_proc(parser,'xor(int64,int64)->int64',op_bxor_i64,0,line,0) - call dcl_proc(parser,'shift(int64,int64)->int64',& + call dcl_proc(parser,'abs(int64)->(int64)',op_abs_i64,0,line,0) + call dcl_proc(parser,'~(int64)->(int64)',op_bnot_i64,0,line,0) + call dcl_proc(parser,'&(int64,int64)->(int64)',op_band_i64,0,line,0) + call dcl_proc(parser,'|(int64,int64)->(int64)',op_bor_i64,0,line,0) + call dcl_proc(parser,'xor(int64,int64)->(int64)',op_bxor_i64,0,line,0) + call dcl_proc(parser,'shift(int64,int64)->(int64)',& op_bshift_i64,0,line,0) - call dcl_proc(parser,'pdiff(int64,int64)->int64',op_pdiff_i64,0,line,0) - call dcl_proc(parser,'sign(int64,int64)->int64',op_sign_i64,0,line,0) - call dcl_proc(parser,'rem(int64,int64)->int64',op_modulo_i64,0,line,0) - call dcl_proc(parser,'int8(int64)->int64',op_i8_i64,0,line,0) - call dcl_proc(parser,'int16(int64)->int64',op_i16_i64,0,line,0) - call dcl_proc(parser,'int32(int64)->int64',op_i32_i64,0,line,0) - call dcl_proc(parser,'int(int64)->int',op_long_i64,0,line,0) - call dcl_proc(parser,'lint(int64)->lint',op_offset_i64,0,line,0) + call dcl_proc(parser,'pdiff(int64,int64)->(int64)',op_pdiff_i64,0,line,0) + call dcl_proc(parser,'sign(int64,int64)->(int64)',op_sign_i64,0,line,0) + call dcl_proc(parser,'rem(int64,int64)->(int64)',op_modulo_i64,0,line,0) + call dcl_proc(parser,'int8(int64)->(int64)',op_i8_i64,0,line,0) + call dcl_proc(parser,'int16(int64)->(int64)',op_i16_i64,0,line,0) + call dcl_proc(parser,'int32(int64)->(int64)',op_i32_i64,0,line,0) + call dcl_proc(parser,'int(int64)->(int)',op_long_i64,0,line,0) + call dcl_proc(parser,'lint(int64)->(lint)',op_offset_i64,0,line,0) ! sreal type call dcl_proc(parser,'PM__assign_var(&sreal,sreal)',& op_assign_r,0,line,0) - call dcl_proc(parser,'mod(sreal,sreal)->sreal',op_mod_r,0,line,0) - call dcl_proc(parser,'==(sreal,sreal)->bool',op_eq_r,0,line,0) - call dcl_proc(parser,'/=(sreal,sreal)->bool',op_ne_r,0,line,0) - call dcl_proc(parser,'>=(sreal,sreal)->bool',op_ge_r,0,line,0) - call dcl_proc(parser,'>(sreal,sreal)->bool',op_gt_r,0,line,0) - call dcl_proc(parser,'+(sreal,sreal)->sreal',op_add_r,0,line,0) - call dcl_proc(parser,'-(sreal,sreal)->sreal',op_sub_r,0,line,0) - call dcl_proc(parser,'*(sreal,sreal)->sreal',op_mult_r,0,line,0) - call dcl_proc(parser,'/(sreal,sreal)->sreal',op_divide_r,0,line,0) - call dcl_proc(parser,'**(sreal,sreal)->sreal',op_pow_r,0,line,0) - call dcl_proc(parser,'max(sreal,sreal)->sreal',op_max_r,0,line,0) - call dcl_proc(parser,'min(sreal,sreal)->sreal',op_min_r,0,line,0) - call dcl_proc(parser,'-(sreal)->sreal',op_uminus_r,0,line,0) - call dcl_proc(parser,'string(sreal)->string',op_string_r,0,line,0) - call dcl_proc(parser,'strunc(sreal)->sint',op_int_r,0,line,0) - call dcl_proc(parser,'trunc(sreal)->int',op_long_r,0,line,0) - call dcl_proc(parser,'ltrunc(sreal)->lint',op_offset_r,0,line,0) - call dcl_proc(parser,'real(sreal)->real',op_double_r,0,line,0) + call dcl_proc(parser,'mod(sreal,sreal)->(sreal)',op_mod_r,0,line,0) + call dcl_proc(parser,'==(sreal,sreal)->(bool)',op_eq_r,0,line,0) + call dcl_proc(parser,'/=(sreal,sreal)->(bool)',op_ne_r,0,line,0) + call dcl_proc(parser,'>=(sreal,sreal)->(bool)',op_ge_r,0,line,0) + call dcl_proc(parser,'>(sreal,sreal)->(bool)',op_gt_r,0,line,0) + call dcl_proc(parser,'+(sreal,sreal)->(sreal)',op_add_r,0,line,0) + call dcl_proc(parser,'-(sreal,sreal)->(sreal)',op_sub_r,0,line,0) + call dcl_proc(parser,'*(sreal,sreal)->(sreal)',op_mult_r,0,line,0) + call dcl_proc(parser,'/(sreal,sreal)->(sreal)',op_divide_r,0,line,0) + call dcl_proc(parser,'**(sreal,sreal)->(sreal)',op_pow_r,0,line,0) + call dcl_proc(parser,'max(sreal,sreal)->(sreal)',op_max_r,0,line,0) + call dcl_proc(parser,'min(sreal,sreal)->(sreal)',op_min_r,0,line,0) + call dcl_proc(parser,'-(sreal)->(sreal)',op_uminus_r,0,line,0) + call dcl_proc(parser,'string(sreal)->(string)',op_string_r,0,line,0) + call dcl_proc(parser,'strunc(sreal)->(sint)',op_int_r,0,line,0) + call dcl_proc(parser,'trunc(sreal)->(int)',op_long_r,0,line,0) + call dcl_proc(parser,'ltrunc(sreal)->(lint)',op_offset_r,0,line,0) + call dcl_proc(parser,'real(sreal)->(real)',op_double_r,0,line,0) call dcl_uproc(parser,'sreal(x:sreal)=x',line) - call dcl_proc(parser,'abs(sreal)->sreal',op_abs_r,0,line,0) - call dcl_proc(parser,'acos(sreal)->sreal',op_acos_r,0,line,0) - call dcl_proc(parser,'asin(sreal)->sreal',op_asin_r,0,line,0) - call dcl_proc(parser,'atan(sreal)->sreal',op_atan_r,0,line,0) - call dcl_proc(parser,'atan2(sreal,sreal)->sreal',op_atan2_r,0,line,0) - call dcl_proc(parser,'cos(sreal)->sreal',op_cos_r,0,line,0) - call dcl_proc(parser,'cosh(sreal)->sreal',op_cosh_r,0,line,0) - call dcl_proc(parser,'exp(sreal)->sreal',op_exp_r,0,line,0) - call dcl_proc(parser,'log(sreal)->sreal',op_log_r,0,line,0) - call dcl_proc(parser,'log10(sreal)->sreal',op_log10_r,0,line,0) - call dcl_proc(parser,'sin(sreal)->sreal',op_sin_r,0,line,0) - call dcl_proc(parser,'sinh(sreal)->sreal',op_sinh_r,0,line,0) - call dcl_proc(parser,'sqrt(sreal)->sreal',op_sqrt_r,0,line,0) - call dcl_proc(parser,'tan(sreal)->sreal',op_tan_r,0,line,0) - call dcl_proc(parser,'tanh(sreal)->sreal',op_tanh_r,0,line,0) - call dcl_proc(parser,'floor(sreal)->sreal',op_floor_r,0,line,0) - call dcl_proc(parser,'ceil(sreal)->sreal',op_ceil_r,0,line,0) - call dcl_proc(parser,'rem(sreal,sreal)->sreal',op_modulo_r,0,line,0) - call dcl_proc(parser,'sign(sreal,sreal)->sreal',op_sign_r,0,line,0) - call dcl_proc(parser,'pdiff(sreal,sreal)->sreal',op_pdiff_r,0,line,0) - call dcl_proc(parser,'lint(sreal)->lint',op_offset_r,0,line,0) - call dcl_proc(parser,'scpx(sreal)->scpx',op_complex_r,0,line,0) - call dcl_proc(parser,'_scpx2(sreal,sreal)->scpx',op_complex2_r,0,line,0) + call dcl_proc(parser,'abs(sreal)->(sreal)',op_abs_r,0,line,0) + call dcl_proc(parser,'acos(sreal)->(sreal)',op_acos_r,0,line,0) + call dcl_proc(parser,'asin(sreal)->(sreal)',op_asin_r,0,line,0) + call dcl_proc(parser,'atan(sreal)->(sreal)',op_atan_r,0,line,0) + call dcl_proc(parser,'atan2(sreal,sreal)->(sreal)',op_atan2_r,0,line,0) + call dcl_proc(parser,'cos(sreal)->(sreal)',op_cos_r,0,line,0) + call dcl_proc(parser,'cosh(sreal)->(sreal)',op_cosh_r,0,line,0) + call dcl_proc(parser,'exp(sreal)->(sreal)',op_exp_r,0,line,0) + call dcl_proc(parser,'log(sreal)->(sreal)',op_log_r,0,line,0) + call dcl_proc(parser,'log10(sreal)->(sreal)',op_log10_r,0,line,0) + call dcl_proc(parser,'sin(sreal)->(sreal)',op_sin_r,0,line,0) + call dcl_proc(parser,'sinh(sreal)->(sreal)',op_sinh_r,0,line,0) + call dcl_proc(parser,'sqrt(sreal)->(sreal)',op_sqrt_r,0,line,0) + call dcl_proc(parser,'tan(sreal)->(sreal)',op_tan_r,0,line,0) + call dcl_proc(parser,'tanh(sreal)->(sreal)',op_tanh_r,0,line,0) + call dcl_proc(parser,'floor(sreal)->(sreal)',op_floor_r,0,line,0) + call dcl_proc(parser,'ceil(sreal)->(sreal)',op_ceil_r,0,line,0) + call dcl_proc(parser,'rem(sreal,sreal)->(sreal)',op_modulo_r,0,line,0) + call dcl_proc(parser,'sign(sreal,sreal)->(sreal)',op_sign_r,0,line,0) + call dcl_proc(parser,'pdiff(sreal,sreal)->(sreal)',op_pdiff_r,0,line,0) + call dcl_proc(parser,'lint(sreal)->(lint)',op_offset_r,0,line,0) + call dcl_proc(parser,'scpx(sreal)->(scpx)',op_complex_r,0,line,0) + call dcl_proc(parser,'_scpx2(sreal,sreal)->(scpx)',op_complex2_r,0,line,0) call dcl_uproc(parser,'scpx(x:any_real,y:any_real)=_scpx2(sreal(x),sreal(y))',line) ! real type call dcl_proc(parser,'PM__assign_var(&real,real)',& op_assign_d,0,line,0) - call dcl_proc(parser,'mod(real,real)->real',op_mod_d,0,line,0) - call dcl_proc(parser,'==(real,real)->bool',op_eq_d,0,line,0) - call dcl_proc(parser,'/=(real,real)->bool',op_ne_d,0,line,0) - call dcl_proc(parser,'>=(real,real)->bool',op_ge_d,0,line,0) - call dcl_proc(parser,'>(real,real)->bool',op_gt_d,0,line,0) - call dcl_proc(parser,'+(real,real)->real',op_add_d,0,line,0) - call dcl_proc(parser,'-(real,real)->real',op_sub_d,0,line,0) - call dcl_proc(parser,'*(real,real)->real',op_mult_d,0,line,0) - call dcl_proc(parser,'/(real,real)->real',op_divide_d,0,line,0) - call dcl_proc(parser,'**(real,real)->real',op_pow_d,0,line,0) - call dcl_proc(parser,'max(real,real)->real',op_max_d,0,line,0) - call dcl_proc(parser,'min(real,real)->real',op_min_d,0,line,0) - call dcl_proc(parser,'-(real)->real',op_uminus_d,0,line,0) - call dcl_proc(parser,'string(real)->string',op_string_d,0,line,0) - call dcl_proc(parser,'strunc(real)->sint',op_int_d,0,line,0) - call dcl_proc(parser,'trunc(real)->int',op_long_d,0,line,0) - call dcl_proc(parser,'ltrunc(real)->lint',op_offset_d,0,line,0) - call dcl_proc(parser,'sreal(real)->sreal',op_real_d,0,line,0) + call dcl_proc(parser,'mod(real,real)->(real)',op_mod_d,0,line,0) + call dcl_proc(parser,'==(real,real)->(bool)',op_eq_d,0,line,0) + call dcl_proc(parser,'/=(real,real)->(bool)',op_ne_d,0,line,0) + call dcl_proc(parser,'>=(real,real)->(bool)',op_ge_d,0,line,0) + call dcl_proc(parser,'>(real,real)->(bool)',op_gt_d,0,line,0) + call dcl_proc(parser,'+(real,real)->(real)',op_add_d,0,line,0) + call dcl_proc(parser,'-(real,real)->(real)',op_sub_d,0,line,0) + call dcl_proc(parser,'*(real,real)->(real)',op_mult_d,0,line,0) + call dcl_proc(parser,'/(real,real)->(real)',op_divide_d,0,line,0) + call dcl_proc(parser,'**(real,real)->(real)',op_pow_d,0,line,0) + call dcl_proc(parser,'max(real,real)->(real)',op_max_d,0,line,0) + call dcl_proc(parser,'min(real,real)->(real)',op_min_d,0,line,0) + call dcl_proc(parser,'-(real)->(real)',op_uminus_d,0,line,0) + call dcl_proc(parser,'string(real)->(string)',op_string_d,0,line,0) + call dcl_proc(parser,'strunc(real)->(sint)',op_int_d,0,line,0) + call dcl_proc(parser,'trunc(real)->(int)',op_long_d,0,line,0) + call dcl_proc(parser,'ltrunc(real)->(lint)',op_offset_d,0,line,0) + call dcl_proc(parser,'sreal(real)->(sreal)',op_real_d,0,line,0) call dcl_uproc(parser,'real(x:real)=x',line) - call dcl_proc(parser,'abs(real)->real',op_abs_d,0,line,0) - call dcl_proc(parser,'acos(real)->real',op_acos_d,0,line,0) - call dcl_proc(parser,'asin(real)->real',op_asin_d,0,line,0) - call dcl_proc(parser,'atan(real)->real',op_atan_d,0,line,0) - call dcl_proc(parser,'atan2(real,real)->real',& + call dcl_proc(parser,'abs(real)->(real)',op_abs_d,0,line,0) + call dcl_proc(parser,'acos(real)->(real)',op_acos_d,0,line,0) + call dcl_proc(parser,'asin(real)->(real)',op_asin_d,0,line,0) + call dcl_proc(parser,'atan(real)->(real)',op_atan_d,0,line,0) + call dcl_proc(parser,'atan2(real,real)->(real)',& op_atan2_d,0,line,0) - call dcl_proc(parser,'cos(real)->real',op_cos_d,0,line,0) - call dcl_proc(parser,'cosh(real)->real',op_cosh_d,0,line,0) - call dcl_proc(parser,'exp(real)->real',op_exp_d,0,line,0) - call dcl_proc(parser,'log(real)->real',op_log_d,0,line,0) - call dcl_proc(parser,'log10(real)->real',op_log10_d,0,line,0) - call dcl_proc(parser,'sin(real)->real',op_sin_d,0,line,0) - call dcl_proc(parser,'sinh(real)->real',op_sinh_d,0,line,0) - call dcl_proc(parser,'sqrt(real)->real',op_sqrt_d,0,line,0) - call dcl_proc(parser,'tan(real)->real',op_tan_d,0,line,0) - call dcl_proc(parser,'tanh(real)->real',op_tanh_d,0,line,0) - call dcl_proc(parser,'floor(real)->real',op_floor_d,0,line,0) - call dcl_proc(parser,'ceil(real)->real',op_ceil_d,0,line,0) - call dcl_proc(parser,'rem(real,real)->real',op_modulo_d,0,line,0) - call dcl_proc(parser,'sign(real,real)->real',op_sign_d,0,line,0) - call dcl_proc(parser,'pdiff(real,real)->real',op_pdiff_d,0,line,0) - call dcl_proc(parser,'lint(real)->lint',op_offset_d,0,line,0) - call dcl_proc(parser,'cpx(real)->cpx',op_complex_d,0,line,0) - call dcl_proc(parser,'_cpx2(real,real)->cpx',op_complex2_d,0,line,0) + call dcl_proc(parser,'cos(real)->(real)',op_cos_d,0,line,0) + call dcl_proc(parser,'cosh(real)->(real)',op_cosh_d,0,line,0) + call dcl_proc(parser,'exp(real)->(real)',op_exp_d,0,line,0) + call dcl_proc(parser,'log(real)->(real)',op_log_d,0,line,0) + call dcl_proc(parser,'log10(real)->(real)',op_log10_d,0,line,0) + call dcl_proc(parser,'sin(real)->(real)',op_sin_d,0,line,0) + call dcl_proc(parser,'sinh(real)->(real)',op_sinh_d,0,line,0) + call dcl_proc(parser,'sqrt(real)->(real)',op_sqrt_d,0,line,0) + call dcl_proc(parser,'tan(real)->(real)',op_tan_d,0,line,0) + call dcl_proc(parser,'tanh(real)->(real)',op_tanh_d,0,line,0) + call dcl_proc(parser,'floor(real)->(real)',op_floor_d,0,line,0) + call dcl_proc(parser,'ceil(real)->(real)',op_ceil_d,0,line,0) + call dcl_proc(parser,'rem(real,real)->(real)',op_modulo_d,0,line,0) + call dcl_proc(parser,'sign(real,real)->(real)',op_sign_d,0,line,0) + call dcl_proc(parser,'pdiff(real,real)->(real)',op_pdiff_d,0,line,0) + call dcl_proc(parser,'lint(real)->(lint)',op_offset_d,0,line,0) + call dcl_proc(parser,'cpx(real)->(cpx)',op_complex_d,0,line,0) + call dcl_proc(parser,'_cpx2(real,real)->(cpx)',op_complex2_d,0,line,0) call dcl_uproc(parser,'cpx(x:real_num,y:real_num)=_cpx2(real(x),real(y))',line) ! scpx type call dcl_proc(parser,'PM__assign_var(&scpx,scpx)',& op_assign_c,0,line,0) - call dcl_proc(parser,'+(scpx,scpx)->scpx',op_add_c,0,line,0) - call dcl_proc(parser,'-(scpx,scpx)->scpx',op_sub_c,0,line,0) - call dcl_proc(parser,'*(scpx,scpx)->scpx',op_mult_c,0,line,0) - call dcl_proc(parser,'/(scpx,scpx)->scpx',op_divide_c,0,line,0) - call dcl_proc(parser,'**(scpx,sreal)->scpx',op_rpow_c,0,line,0) - call dcl_proc(parser,'**(scpx,scpx)->scpx',op_pow_c,0,line,0) - call dcl_proc(parser,'-(scpx)->scpx',op_uminus_c,0,line,0) - call dcl_proc(parser,'==(scpx,scpx)->bool',op_eq_c,0,line,0) - call dcl_proc(parser,'/=(scpx,scpx)->bool',op_ne_c,0,line,0) - call dcl_proc(parser,'re(scpx)->sreal',op_real_c,0,line,0) - call dcl_proc(parser,'abs(scpx)->scpx',op_abs_c,0,line,0) - call dcl_proc(parser,'acos(scpx)->scpx',op_acos_c,0,line,0) - call dcl_proc(parser,'asin(scpx)->scpx',op_asin_c,0,line,0) - call dcl_proc(parser,'atan(scpx)->scpx',op_atan_c,0,line,0) - call dcl_proc(parser,'atan2(scpx,scpx)->scpx',& + call dcl_proc(parser,'+(scpx,scpx)->(scpx)',op_add_c,0,line,0) + call dcl_proc(parser,'-(scpx,scpx)->(scpx)',op_sub_c,0,line,0) + call dcl_proc(parser,'*(scpx,scpx)->(scpx)',op_mult_c,0,line,0) + call dcl_proc(parser,'/(scpx,scpx)->(scpx)',op_divide_c,0,line,0) + call dcl_proc(parser,'**(scpx,sreal)->(scpx)',op_rpow_c,0,line,0) + call dcl_proc(parser,'**(scpx,scpx)->(scpx)',op_pow_c,0,line,0) + call dcl_proc(parser,'-(scpx)->(scpx)',op_uminus_c,0,line,0) + call dcl_proc(parser,'==(scpx,scpx)->(bool)',op_eq_c,0,line,0) + call dcl_proc(parser,'/=(scpx,scpx)->(bool)',op_ne_c,0,line,0) + call dcl_proc(parser,'re(scpx)->(sreal)',op_real_c,0,line,0) + call dcl_proc(parser,'abs(scpx)->(scpx)',op_abs_c,0,line,0) + call dcl_proc(parser,'acos(scpx)->(scpx)',op_acos_c,0,line,0) + call dcl_proc(parser,'asin(scpx)->(scpx)',op_asin_c,0,line,0) + call dcl_proc(parser,'atan(scpx)->(scpx)',op_atan_c,0,line,0) + call dcl_proc(parser,'atan2(scpx,scpx)->(scpx)',& op_atan2_c,0,line,0) - call dcl_proc(parser,'cos(scpx)->scpx',op_cos_c,0,line,0) - call dcl_proc(parser,'cosh(scpx)->scpx',op_cosh_c,0,line,0) - call dcl_proc(parser,'exp(scpx)->scpx',op_exp_c,0,line,0) - call dcl_proc(parser,'log(scpx)->scpx',op_log_c,0,line,0) - call dcl_proc(parser,'sin(scpx)->scpx',op_sin_c,0,line,0) - call dcl_proc(parser,'sinh(scpx)->scpx',op_sinh_c,0,line,0) - call dcl_proc(parser,'sqrt(scpx)->scpx',op_sqrt_c,0,line,0) - call dcl_proc(parser,'tan(scpx)->scpx',op_tan_c,0,line,0) - call dcl_proc(parser,'tanh(scpx)->scpx',op_tanh_c,0,line,0) - call dcl_proc(parser,'im(scpx)->sreal',op_imag_c,0,line,0) - call dcl_proc(parser,'conj(scpx)->scpx',op_conj_c,0,line,0) + call dcl_proc(parser,'cos(scpx)->(scpx)',op_cos_c,0,line,0) + call dcl_proc(parser,'cosh(scpx)->(scpx)',op_cosh_c,0,line,0) + call dcl_proc(parser,'exp(scpx)->(scpx)',op_exp_c,0,line,0) + call dcl_proc(parser,'log(scpx)->(scpx)',op_log_c,0,line,0) + call dcl_proc(parser,'sin(scpx)->(scpx)',op_sin_c,0,line,0) + call dcl_proc(parser,'sinh(scpx)->(scpx)',op_sinh_c,0,line,0) + call dcl_proc(parser,'sqrt(scpx)->(scpx)',op_sqrt_c,0,line,0) + call dcl_proc(parser,'tan(scpx)->(scpx)',op_tan_c,0,line,0) + call dcl_proc(parser,'tanh(scpx)->(scpx)',op_tanh_c,0,line,0) + call dcl_proc(parser,'im(scpx)->(sreal)',op_imag_c,0,line,0) + call dcl_proc(parser,'conj(scpx)->(scpx)',op_conj_c,0,line,0) ! cpx type call dcl_proc(parser,'PM__assign_var(&cpx,cpx)',& op_assign_dc,0,line,0) - call dcl_proc(parser,'+(cpx,cpx)->cpx',op_add_dc,0,line,0) - call dcl_proc(parser,'-(cpx,cpx)->cpx',op_sub_dc,0,line,0) - call dcl_proc(parser,'*(cpx,cpx)->cpx',op_mult_dc,0,line,0) - call dcl_proc(parser,'/(cpx,cpx)->cpx',op_divide_dc,0,line,0) - call dcl_proc(parser,'**(cpx,real)->cpx',op_dpow_dc,0,line,0) + call dcl_proc(parser,'+(cpx,cpx)->(cpx)',op_add_dc,0,line,0) + call dcl_proc(parser,'-(cpx,cpx)->(cpx)',op_sub_dc,0,line,0) + call dcl_proc(parser,'*(cpx,cpx)->(cpx)',op_mult_dc,0,line,0) + call dcl_proc(parser,'/(cpx,cpx)->(cpx)',op_divide_dc,0,line,0) + call dcl_proc(parser,'**(cpx,real)->(cpx)',op_dpow_dc,0,line,0) call dcl_uproc(parser,'**(x:cpx,y:sreal)=x**real(y)',line) - call dcl_proc(parser,'**(cpx,cpx)->cpx',op_pow_dc,0,line,0) - call dcl_proc(parser,'-(cpx)->cpx',op_uminus_dc,0,line,0) - call dcl_proc(parser,'==(cpx,cpx)->bool',op_eq_dc,0,line,0) - call dcl_proc(parser,'/=(cpx,cpx)->bool',op_ne_dc,0,line,0) - call dcl_proc(parser,'re(cpx)->real',op_real_dc,0,line,0) - call dcl_proc(parser,'abs(cpx)->cpx',op_abs_dc,0,line,0) - call dcl_proc(parser,'acos(cpx)->cpx',op_acos_dc,0,line,0) - call dcl_proc(parser,'asin(cpx)->cpx',op_asin_dc,0,line,0) - call dcl_proc(parser,'atan(cpx)->cpx',op_atan_dc,0,line,0) - call dcl_proc(parser,'atan2(cpx,cpx)->cpx',& + call dcl_proc(parser,'**(cpx,cpx)->(cpx)',op_pow_dc,0,line,0) + call dcl_proc(parser,'-(cpx)->(cpx)',op_uminus_dc,0,line,0) + call dcl_proc(parser,'==(cpx,cpx)->(bool)',op_eq_dc,0,line,0) + call dcl_proc(parser,'/=(cpx,cpx)->(bool)',op_ne_dc,0,line,0) + call dcl_proc(parser,'re(cpx)->(real)',op_real_dc,0,line,0) + call dcl_proc(parser,'abs(cpx)->(cpx)',op_abs_dc,0,line,0) + call dcl_proc(parser,'acos(cpx)->(cpx)',op_acos_dc,0,line,0) + call dcl_proc(parser,'asin(cpx)->(cpx)',op_asin_dc,0,line,0) + call dcl_proc(parser,'atan(cpx)->(cpx)',op_atan_dc,0,line,0) + call dcl_proc(parser,'atan2(cpx,cpx)->(cpx)',& op_atan2_dc,0,line,0) - call dcl_proc(parser,'cos(cpx)->cpx',op_cos_dc,0,line,0) - call dcl_proc(parser,'cosh(cpx)->cpx',op_cosh_dc,0,line,0) - call dcl_proc(parser,'exp(cpx)->cpx',op_exp_dc,0,line,0) - call dcl_proc(parser,'log(cpx)->cpx',op_log_dc,0,line,0) - call dcl_proc(parser,'sin(cpx)->cpx',op_sin_dc,0,line,0) - call dcl_proc(parser,'sinh(cpx)->cpx',op_sinh_dc,0,line,0) - call dcl_proc(parser,'sqrt(cpx)->cpx',op_sqrt_dc,0,line,0) - call dcl_proc(parser,'tan(cpx)->cpx',op_tan_dc,0,line,0) - call dcl_proc(parser,'tanh(cpx)->cpx',op_tanh_dc,0,line,0) - call dcl_proc(parser,'im(cpx)->real',op_imag_dc,0,line,0) - call dcl_proc(parser,'conj(cpx)->cpx',op_conj_dc,0,line,0) + call dcl_proc(parser,'cos(cpx)->(cpx)',op_cos_dc,0,line,0) + call dcl_proc(parser,'cosh(cpx)->(cpx)',op_cosh_dc,0,line,0) + call dcl_proc(parser,'exp(cpx)->(cpx)',op_exp_dc,0,line,0) + call dcl_proc(parser,'log(cpx)->(cpx)',op_log_dc,0,line,0) + call dcl_proc(parser,'sin(cpx)->(cpx)',op_sin_dc,0,line,0) + call dcl_proc(parser,'sinh(cpx)->(cpx)',op_sinh_dc,0,line,0) + call dcl_proc(parser,'sqrt(cpx)->(cpx)',op_sqrt_dc,0,line,0) + call dcl_proc(parser,'tan(cpx)->(cpx)',op_tan_dc,0,line,0) + call dcl_proc(parser,'tanh(cpx)->(cpx)',op_tanh_dc,0,line,0) + call dcl_proc(parser,'im(cpx)->(real)',op_imag_dc,0,line,0) + call dcl_proc(parser,'conj(cpx)->(cpx)',op_conj_dc,0,line,0) ! Cannot convert real to int (must use nint or trunc) call dcl_uproc(parser,& @@ -658,6 +724,13 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'balance(x:_to_scpx,y:scpx)=scpx(x),y',line) call dcl_uproc(parser,'balance(x:_to_cpx,y:cpx)=cpx(x),y',line) + call dcl_uproc(parser,& + 'div(x:any_int,y:any_int)=if(sz=>r,-1-r)'//& + 'where r=if(sz=>x,abs(x)-1)/if(sz=>y,abs(y))'//& + 'where sz=sign(x,y)==x',line) + call dcl_uproc(parser,& + '_divz(x:any_int,y:any_int)=z '//& + '{var z,_=balance(x,y);if(sign(x,y)==x):z=x/y else: z=-1-(abs(x)-1)/abs(y)}',line) call dcl_uproc(parser,& 'mod(x:real_num,y:real_num)=xx mod yy where xx,yy=balance(x,y)',line) call dcl_uproc(parser,& @@ -678,6 +751,14 @@ subroutine sysdefs(parser) '/(x:num,y:num)=xx/yy where xx,yy=balance(x,y)',line) call dcl_uproc(parser,& '**(x:num,y:num)=xx**yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '&(x:num,y:num)=xx&yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '|(x:num,y:num)=xx|yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + 'xor(x:num,y:num)=xx xor yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + 'shift(x:num,y:num)=xx shift yy where xx,yy=balance(x,y)',line) call dcl_uproc(parser,& 'max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y)',line) call dcl_uproc(parser,& @@ -686,44 +767,44 @@ subroutine sysdefs(parser) ! bool type call dcl_proc(parser,'PM__assign_var(&bool,bool)',& op_assign_l,0,line,0) - call dcl_proc(parser,'string(bool)->string',op_string_l,0,line,0) - call dcl_proc(parser,'and(bool,bool)->bool',op_and,0,line,0) - call dcl_proc(parser,'or(bool,bool)->bool',op_or,0,line,0) - call dcl_proc(parser,'not(bool)->bool',op_not,0,line,0) - call dcl_proc(parser,'==(bool,bool)->bool',op_eq_l,0,line,0) - call dcl_proc(parser,'/=(bool,bool)->bool',op_ne_l,0,line,0) - - ! Compile time bool values - call dcl_uproc(parser,'and(x:''false,y:''false)=''false',line) - call dcl_uproc(parser,'and(x:''true,y:''false)=''false',line) - call dcl_uproc(parser,'and(x:''false,y:''true)=''false',line) - call dcl_uproc(parser,'and(x:''true,y:''true)=''true',line) - call dcl_uproc(parser,'and(x:''true,y:bool)=y',line) - call dcl_uproc(parser,'and(x:''false,y:bool)=''false',line) - call dcl_uproc(parser,'and(x:bool,y:''true)=x',line) - call dcl_uproc(parser,'and(x:bool,y:''false)=''false',line) - call dcl_uproc(parser,'or(x:''false,y:''false)=''false',line) - call dcl_uproc(parser,'or(x:''true,y:''false)=''true',line) - call dcl_uproc(parser,'or(x:''false,y:''true)=''true',line) - call dcl_uproc(parser,'or(x:''true,y:''true)=''true',line) - call dcl_uproc(parser,'or(x:''true,y:bool)=''true',line) - call dcl_uproc(parser,'or(x:''false,y:bool)=y',line) - call dcl_uproc(parser,'or(x:bool,y:''true)=''true',line) - call dcl_uproc(parser,'or(x:bool,y:''false)=x',line) - call dcl_uproc(parser,'not(x:''true)=''false',line) - call dcl_uproc(parser,'not(x:''false)=''true',line) - call dcl_uproc(parser,'==(x:''false,y:''false)=''true',line) - call dcl_uproc(parser,'==(x:''true,y:''false)=''false',line) - call dcl_uproc(parser,'==(x:''false,y:''true)=''false',line) - call dcl_uproc(parser,'==(x:''true,y:''true)=''true',line) - call dcl_uproc(parser,'==(x:bool,y:''true)=x',line) - call dcl_uproc(parser,'==(x:''true,y:bool)=y',line) - call dcl_uproc(parser,'/=(x:''false,y:''false)=''false',line) - call dcl_uproc(parser,'/=(x:''true,y:''false)=''true',line) - call dcl_uproc(parser,'/=(x:''false,y:''true)=''true',line) - call dcl_uproc(parser,'/=(x:''true,y:''true)=''false',line) - call dcl_uproc(parser,'/=(x:bool,y:''false)=x',line) - call dcl_uproc(parser,'/=(x:''false,y:bool)=y',line) + call dcl_proc(parser,'string(bool)->(string)',op_string_l,0,line,0) + call dcl_proc(parser,'and(bool,bool)->(bool)',op_and,0,line,0) + call dcl_proc(parser,'or(bool,bool)->(bool)',op_or,0,line,0) + call dcl_proc(parser,'not(bool)->(bool)',op_not,0,line,0) + call dcl_proc(parser,'==(bool,bool)->(bool)',op_eq_l,0,line,0) + call dcl_proc(parser,'/=(bool,bool)->(bool)',op_ne_l,0,line,0) + +!!$ ! Compile time bool values +!!$ call dcl_uproc(parser,'and(x:''false,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'and(x:''true,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'and(x:''false,y:''true)=''false',line) +!!$ call dcl_uproc(parser,'and(x:''true,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'and(x:''true,y:bool)=y',line) +!!$ call dcl_uproc(parser,'and(x:''false,y:bool)=''false',line) +!!$ call dcl_uproc(parser,'and(x:bool,y:''true)=x',line) +!!$ call dcl_uproc(parser,'and(x:bool,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'or(x:''false,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'or(x:''true,y:''false)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''false,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''true,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''true,y:bool)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''false,y:bool)=y',line) +!!$ call dcl_uproc(parser,'or(x:bool,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'or(x:bool,y:''false)=x',line) +!!$ call dcl_uproc(parser,'not(x:''true)=''false',line) +!!$ call dcl_uproc(parser,'not(x:''false)=''true',line) +!!$ call dcl_uproc(parser,'==(x:''false,y:''false)=''true',line) +!!$ call dcl_uproc(parser,'==(x:''true,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'==(x:''false,y:''true)=''false',line) +!!$ call dcl_uproc(parser,'==(x:''true,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'==(x:bool,y:''true)=x',line) +!!$ call dcl_uproc(parser,'==(x:''true,y:bool)=y',line) +!!$ call dcl_uproc(parser,'/=(x:''false,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'/=(x:''true,y:''false)=''true',line) +!!$ call dcl_uproc(parser,'/=(x:''false,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'/=(x:''true,y:''true)=''false',line) +!!$ call dcl_uproc(parser,'/=(x:bool,y:''false)=x',line) +!!$ call dcl_uproc(parser,'/=(x:''false,y:bool)=y',line) ! Masked types call dcl_type(parser,'masked(x) is '//& @@ -740,12 +821,12 @@ subroutine sysdefs(parser) 'get(&x,y:masked(x)) {if y._there{x=y._val};return y._there}',line) ! Polymorphic types - call dcl_proc(parser,'get(x:*any,y:any)->=y',op_as,0,line,0) + call dcl_proc(parser,'get(x:*any,y:any)->(=y)',op_as,0,line,0) call dcl_proc(parser,'get(&x:any,y:*any)',op_get_poly,0,line,& proc_needs_type) - call dcl_proc(parser,'get(&x:any,y:*any)->bool',op_get_poly2,0,line,& + call dcl_proc(parser,'get(&x:any,y:*any)->(bool)',op_get_poly2,0,line,& proc_needs_type) - call dcl_proc(parser,'|(x:*any,y:any)->=y',op_get_poly_or,0,line,& + call dcl_proc(parser,'|(x:*any,y:any)->(=y)',op_get_poly_or,0,line,& proc_needs_type) ! val function having null effect @@ -843,13 +924,13 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'indices(x:tuple6d)=[''1,''2,''3,''4,''5,''6]',line) call dcl_uproc(parser,'indices(x:tuple7d)=[''1,''2,''3,''4,''5,''6,''7]',line) - call dcl_uproc(parser,'full_rank(x:tuple1d)=''1',line) - call dcl_uproc(parser,'full_rank(x:tuple2d)=''2',line) - call dcl_uproc(parser,'full_rank(x:tuple3d)=''3',line) - call dcl_uproc(parser,'full_rank(x:tuple4d)=''4',line) - call dcl_uproc(parser,'full_rank(x:tuple5d)=''5',line) - call dcl_uproc(parser,'full_rank(x:tuple6d)=''6',line) - call dcl_uproc(parser,'full_rank(x:tuple7d)=''7',line) + call dcl_uproc(parser,'full_rank(x:tuple1d)=1',line) + call dcl_uproc(parser,'full_rank(x:tuple2d)=2',line) + call dcl_uproc(parser,'full_rank(x:tuple3d)=3',line) + call dcl_uproc(parser,'full_rank(x:tuple4d)=4',line) + call dcl_uproc(parser,'full_rank(x:tuple5d)=5',line) + call dcl_uproc(parser,'full_rank(x:tuple6d)=6',line) + call dcl_uproc(parser,'full_rank(x:tuple7d)=7',line) call dcl_uproc(parser,'rank(x:tuple)=full_rank(x)',line) @@ -1266,6 +1347,12 @@ subroutine sysdefs(parser) ! RANGES AND SEQUENCES ! ***************************************************** + ! Not in operator + call dcl_uproc(parser,'notin(x,y)=not(x in y)',line) + + ! not inc operator + call dcl_uproc(parser,'notinc(x,y)=not(x inc y)',line) + ! Treat null as empty sequence in some cases call dcl_uproc(parser,'in(x,y:null)=''false',line) call dcl_uproc(parser,'in(x:null,y:null)=''true',line) @@ -1320,8 +1407,8 @@ subroutine sysdefs(parser) call dcl_type(parser,'range(t:range_base) is rec {_lo:t,_hi:t,_n:t}',line) call dcl_uproc(parser,'..(x:range_base,y:range_base)='//& 'new range {_lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,'..(x:fix int,y:fix int)='//& - 'new range {_lo=x,_hi=y,_n=max(''0,y-x+''1)}',line) +!!$ call dcl_uproc(parser,'..(x:fix int,y:fix int)='//& +!!$ 'new range {_lo=x,_hi=y,_n=max(''0,y-x+''1)}',line) call dcl_uproc(parser,'low(x:range)=x._lo',line) call dcl_uproc(parser,'high(x:range)=x._hi',line) call dcl_uproc(parser,'step(x:range)=convert(1,x._lo)',line) @@ -1509,7 +1596,7 @@ subroutine sysdefs(parser) 'intersect(x:range(any_int),y:strided_range(any_int))=intersect(y,x)',line) call dcl_proc(parser,& - '_intersect_seq(int,int,int,int,int,int,int,int)->int,int,int,int',& + '_intersect_seq(int,int,int,int,int,int,int,int)->(int,int,int,int)',& op_intersect_seq,0,line,0) call dcl_uproc(parser,'intersect(x:strided_range(any_int),y:strided_range(any_int))='//& 'new strided_range {_lo=lo,_hi=hi,_st=st,_n=n}'//& @@ -1630,11 +1717,11 @@ subroutine sysdefs(parser) op_intersect_bseq,1,line,0) call dcl_proc(parser,'_overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any)',& op_intersect_bseq,2,line,0) - call dcl_proc(parser,'_includes_aseq(any,any,any,any)->bool',& + call dcl_proc(parser,'_includes_aseq(any,any,any,any)->(bool)',& op_includes_aseq,0,line,0) - call dcl_proc(parser,'_index_aseq(any,any,any)->int',& + call dcl_proc(parser,'_index_aseq(any,any,any)->(int)',& op_index_aseq,0,line,0) - call dcl_proc(parser,'_in_aseq(any,any,any)->bool',& + call dcl_proc(parser,'_in_aseq(any,any,any)->(bool)',& op_in_aseq,0,line,0) !!$ call dcl_uproc(parser,'intersect(x:block_seq,y:block_seq) {'//& @@ -1746,19 +1833,19 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_shp(x:null)=x',line) call dcl_uproc(parser,'_size(x:stretch_dim or null)=''1',line) call dcl_uproc(parser,'_size(x)=size(x)',line) - call dcl_proc(parser,'_act(x:single_point)->PM__tinyint',op_miss_arg,0,line,0) + call dcl_proc(parser,'_act(x:single_point)->(PM__tinyint)',op_miss_arg,0,line,0) call dcl_uproc(parser,'_act(x)=x',line) call dcl_uproc(parser,'_sliceit(arg...)=tuple(arg...)',line) call dcl_uproc(parser,'active_dims(x:iterable_grid)=map_apply($_act,$_sliceit,x)',line) call dcl_uproc(parser,'active_dims(x:single_point)=null',line) - call dcl_proc(parser,'_act(x:single_point,y:any)->PM__tinyint',op_miss_arg,0,line,0) + call dcl_proc(parser,'_act(x:single_point,y:any)->(PM__tinyint)',op_miss_arg,0,line,0) call dcl_uproc(parser,'_act(x,y)=y',line) call dcl_uproc(parser,'active_dims(x:iterable_grid,y:tuple)=map_apply($_act,$_sliceit,x,y)',line) call dcl_uproc(parser,'active_dims(x:single_point,y)=null',line) - call dcl_uproc(parser,'_ar(x:single_point)=''0',line) - call dcl_uproc(parser,'_ar(x)=''1',line) + call dcl_uproc(parser,'_ar(x:single_point)=0',line) + call dcl_uproc(parser,'_ar(x)=1',line) call dcl_uproc(parser,'rank(x:iterable_grid)=map_reduce($_ar,$+,x)',line) - call dcl_uproc(parser,'element(x:iterable_grid,y:index)'//& + call dcl_uproc(parser,'element(x:iterable_grid,y:index)'//& '{t=_tup(y);return _ges(head(x),tail(x),head(t),tail(t),''false)}',line) call dcl_uproc(parser,'element(x:grid_slice,arg...:grid_slice)'//& '{t=_tup(arg...);'//& @@ -1799,7 +1886,7 @@ subroutine sysdefs(parser) 'map_reduce($inc,$and,x,y)',line) call dcl_uproc(parser,'#(x:grid,y:tuple(subs_dim))='//& 'map($#,x,y)',line) - call dcl_proc(parser,'_acthash(x:single_point,y:any)->PM__tinyint',op_miss_arg,0,line,0) + call dcl_proc(parser,'_acthash(x:single_point,y:any)->(PM__tinyint)',op_miss_arg,0,line,0) call dcl_uproc(parser,'_acthash(x,y)=x#y',line) call dcl_uproc(parser,'#(x:grid_slice,y:tuple(subs_dim) or grid_slice)='//& 'map_apply($_acthash,$_sliceit,x,y)',line) @@ -1822,7 +1909,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'contact(x:grid_slice,y:grid)='//& 'map($contract,x,y)',line) - call dcl_proc(parser,'gcd(x:int,y:int)->int',op_gcd,0,line,0) + call dcl_proc(parser,'gcd(x:int,y:int)->(int)',op_gcd,0,line,0) @@ -1992,7 +2079,7 @@ subroutine sysdefs(parser) '_contains(x.1,y)',line) call dcl_uproc(parser,'contains(x:extent,y:tuple(subs_dim))='//& 'map_reduce($_contains,$and,x,y)',line) - call dcl_proc(parser,'_rgd(x:stretch_dim)->PM__tinyint',op_miss_arg,0,line,0) + call dcl_proc(parser,'_rgd(x:stretch_dim)->(PM__tinyint)',op_miss_arg,0,line,0) call dcl_uproc(parser,'_rgd(x)=x',line) call dcl_uproc(parser,'_rigid_dims(x:grid_slice or tuple(subs_dim))='//& 'map_apply($_rgd,$_sliceit,x)',line) @@ -2272,31 +2359,31 @@ subroutine sysdefs(parser) !!$ call dcl_uproc(parser,'PM__generate(x:mshape,n,s:schedule)=_belts(s,x)',line) call dcl_proc(parser,& - '_doloop(int)->int',& + '_doloop(int)->(int)',& op_do_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_doloop(int,int)->int,int',& + '_doloop(int,int)->(int,int)',& op_do_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_doloop(int,int,int)->int,int,int',& + '_doloop(int,int,int)->(int,int,int)',& op_do_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_doloop(int,int,int,int)->int,int,int,int',& + '_doloop(int,int,int,int)->(int,int,int,int)',& op_do_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_doloop(int,int,int,int,int)->int,int,int,int,int',& + '_doloop(int,int,int,int,int)->(int,int,int,int,int)',& op_do_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_doloop(int,int,int,int,int,int)->int,int,int,int,int,int',& + '_doloop(int,int,int,int,int,int)->(int,int,int,int,int,int)',& op_do_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_doloop(int,int,int,int,int,int,int)->'//& + '_doloop(int,int,int,int,int,int,int)->()'//& 'int,int,int,int,int,int,int',& op_do_loop,0,line,& proc_is_generator) @@ -2325,31 +2412,31 @@ subroutine sysdefs(parser) 'i,j,k,l,m,n,o=_doloop(x.1,x.2,x.3,x.4,x.5,x.6,x.7)',line) call dcl_proc(parser,& - '_blockedloop(any)->int',& + '_blockedloop(any)->(int)',& op_blocked_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_blockedloop(any)->int,int',& + '_blockedloop(any)->(int,int)',& op_blocked_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_blockedloop(any)->int,int,int',& + '_blockedloop(any)->(int,int,int)',& op_blocked_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_blockedloop(any)->int,int,int,int',& + '_blockedloop(any)->(int,int,int,int)',& op_blocked_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_blockedloop(any)->int,int,int,int,int',& + '_blockedloop(any)->(int,int,int,int,int)',& op_blocked_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_blockedloop(any)->int,int,int,int,int,int',& + '_blockedloop(any)->(int,int,int,int,int,int)',& op_blocked_loop,0,line,& proc_is_generator) call dcl_proc(parser,& - '_blockedloop(any)->'//& + '_blockedloop(any)->()'//& 'int,int,int,int,int,int,int',& op_blocked_loop,0,line,& proc_is_generator) @@ -2380,12 +2467,12 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__generate(x:mshape,n,s)=_elts(dims(x),1,n)',line) call dcl_proc(parser,& - '_iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->int',& + '_iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->(int)',& op_iota,0,line,& proc_is_generator) call dcl_proc(parser,& '_iota(siz:int,start:int,finish:int,incr:int,'//& - 'first:int,trunc:int,totsiz:int)->int',& + 'first:int,trunc:int,totsiz:int)->(int)',& op_iota,0,line,& proc_is_generator) call dcl_uproc(parser,'_n(x:int)=x',line) @@ -2432,7 +2519,7 @@ subroutine sysdefs(parser) endif call dcl_proc(parser,& - '_indices(any)->int',op_indices,0,line,0) + '_indices(any)->(int)',op_indices,0,line,0) ! ************************************** ! ARRAYS @@ -2455,29 +2542,29 @@ subroutine sysdefs(parser) if(pm_is_compiling) then call dcl_uproc(parser,'size(x:any^mshape)=size(#x)',line) else - call dcl_proc(parser,'size(x:any^mshape)->int',op_get_size,0,line,0) + call dcl_proc(parser,'size(x:any^mshape)->(int)',op_get_size,0,line,0) endif - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false)->PM__dim x,y',& + call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false)->(PM__dim x,y)',& op_array,0,line,proc_needs_type) - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''true)->PM__vdim x,y',& + call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''true)->(PM__vdim x,y)',& op_var_array,0,line,proc_needs_type) - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''true)->PM__invar_dim x,y',& - op_array,0,line,proc_needs_type) - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''false)->PM__fix_dim x,y,z',& - merge(op_init_farray,op_array,pm_is_compiling),0,line,proc_needs_type) +!!$ call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''true)->(PM__invar_dim x,y)',& +!!$ op_array,0,line,proc_needs_type) +!!$ call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''false)->(PM__fix_dim x,y,z)',& +!!$ merge(op_init_farray,op_array,pm_is_compiling),0,line,proc_needs_type) call dcl_proc(parser,& - '_redim(x:any^any,y:any)->over x,y',& + '_redim(x:any^any,y:any)->(over x,y)',& op_redim,0,line,proc_needs_type) - call dcl_proc(parser,'PM__dim_noinit(x:any,y:any,z:any)->PM__dim x,y',& + call dcl_proc(parser,'PM__dim_noinit(x:any,y:any,z:any)->(PM__dim x,y)',& op_array_noinit,0,line,proc_needs_type) call dcl_uproc(parser,'#%(x:invar any^any)=_array_shape(x <>)',line) call dcl_uproc(parser,'#%(x)=_get_shape(x)',line) call dcl_uproc(parser,'_get_shape(x)=#x',line) call dcl_uproc(parser,'#(x:any^any)=_array_shape(x)',line) - call dcl_proc(parser,'_array_shape(x:any^any)->#x',op_get_dom,0,line,0) + call dcl_proc(parser,'_array_shape(x:any^any)->(#x)',op_get_dom,0,line,0) call dcl_uproc(parser,'dims(x:any^mshape)=dims(#x)',line) - call dcl_proc(parser,'PM__extractelm(x:any^any)->%x',& + call dcl_proc(parser,'PM__extractelm(x:any^any)->(%x)',& op_extractelm,0,line,0) call dcl_uproc(parser,'element(a:any^mshape,t:index)='//& @@ -2486,10 +2573,10 @@ subroutine sysdefs(parser) '{ PM__setaelem(&a,index(#(a),t),v) }',line) call dcl_uproc(parser,'_make_subref(a:any^mshape,t:index)='//& '_make_subref(a,index(#(a),t))',line) - call dcl_proc(parser,'_make_subref(a:any^mshape,i:int)->%a',& + call dcl_proc(parser,'_make_subref(a:any^mshape,i:int)->(%a)',& op_make_rf,0,line,0) - call dcl_proc(parser,'_get_aelem(x:any^any,y:int)->%x',& + call dcl_proc(parser,'_get_aelem(x:any^any,y:int)->(%x)',& op_array_get_elem,0,line,0) call dcl_proc(parser,'PM__setaelem(&x:any^any,y:int,z:any)',& op_array_set_elem,0,line,0) @@ -2592,25 +2679,16 @@ subroutine sysdefs(parser) ! ***************************************** ! Array templates - call dcl_type(parser,'array_template(a,d:mshape or dshape,v:fix bool,i:fix bool,f:fix bool)'//& - ' is rec {_a:a,_d:d,_s:int,_v:v,_i:i=''false,_f:f=''false}',line) + call dcl_type(parser,'array_template(a,d:mshape or dshape,v:fix bool)'//& + ' is rec {_a:a,_d:d,_s:int,_v:v}',line) call dcl_uproc(parser,& 'array(a:any,s:dshape)='//& 'new array_template {_a=a,_d=s,_s=s._size,_v=''false}',line) call dcl_uproc(parser,& 'array(a:any,s:mshape(tuple(range(int))))='//& 'new array_template {_a=a,_d=s,_s=size(s),_v=''false}',line) - call dcl_uproc(parser,& - 'array(a:any,s:fix mshape(tuple(range(int))))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false,_f=''true}',line) call dcl_uproc(parser,& 'array(a:any,s:tuple(range(any_int)))=array(a,shape(s))',line) - call dcl_uproc(parser,'dim%(a,d)=array(a,d)',line) - call dcl_uproc(parser,'dim%(a,s:invar mshape(tuple(range(int))))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false,_i=''true}',line) - call dcl_uproc(parser,'dim%(a,sh:invar tuple(range(any_int)))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false,_i=''true}'//& - 'where s=shape(sh)',line) call dcl_uproc(parser,& 'varray(a:any,s:mshape or dshape)='//& @@ -2635,10 +2713,8 @@ subroutine sysdefs(parser) ! Array creation from template call dcl_uproc(parser,'PM__dup(a:array_template(,shape,))='//& '_array(PM__dup(a._a),a._d,int(a._s),a._v)',line) - call dcl_uproc(parser,'PM__dup(a:array_template(,mshape,,,''true))='//& - '_array(PM__dup(a._a),a._d,int(a._s),a._v,''false)',line) - call dcl_uproc(parser,'PM__dup(a:array_template(,mshape,,''true,''false))='//& - '_array(PM__dup(a._a),a._d,int(a._s),a._v,''true)',line) + call dcl_uproc(parser,'PM__dup(a:array_template(,shape,''true))='//& + '_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v)',line) call dcl_uproc(parser,'PM__do_dim(a:any,d:mshape)='//& '_array(a,d,size(d),''false)',& @@ -2856,6 +2932,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__redim(a,d)=_redim(a,d)',line) call dcl_uproc(parser,'PM__local(a:any^dshape)=_redim(a,(#a)._tilesz)',line) call dcl_uproc(parser,'PM__local(a:any^mshape)=a',line) + call dcl_uproc(parser,'PM__local%(x:shared) shared =PM__local(x)',line) call dcl_uproc(parser,'element(a:any^dshape,t) { '//& 'p,i=node_and_index((#a).dist,(#a)._mshape#_tup(t));'//& 'var r=_arb(a);if p==_this_node():r=_get_aelem(a,i);_bcast_shared(&r,p);return r} ',line) @@ -3132,17 +3209,17 @@ subroutine sysdefs(parser) call dcl_type(parser,'PM__reftype(x) is x,^shared(x,,,,)',line) ! Support for internal ^(...) reference type - call dcl_proc(parser,'_v1(x:any)->PM__d1 x',op_elem,1,line,0) - call dcl_proc(parser,'_v2(x:any)->PM__d2 x',op_elem,2,line,0) - call dcl_proc(parser,'_v3(x:any)->PM__d3 x',op_elem,3,line,0) - call dcl_proc(parser,'_v4(x:any)->PM__d4 x',op_elem,4,line,0) - call dcl_proc(parser,'_v5(x:any)->PM__d5 x',op_elem,5,line,0) - - call dcl_proc(parser,'_v1%(r:any,s:any,h:any,x:any)->PM__d1% x',op_elem,1,line,0) - call dcl_proc(parser,'_v2%(r:any,s:any,h:any,x:any)->PM__d2% x',op_elem,2,line,0) - call dcl_proc(parser,'_v3%(r:any,s:any,h:any,x:any)->PM__d3% x',op_elem,3,line,0) - call dcl_proc(parser,'_v4%(r:any,s:any,h:any,x:any)->PM__d4% x',op_elem,4,line,0) - call dcl_proc(parser,'_v5%(r:any,s:any,h:any,x:any)->PM__d5% x',op_elem,5,line,0) + call dcl_proc(parser,'_v1(x:any)->(PM__d1 x)',op_elem,1,line,0) + call dcl_proc(parser,'_v2(x:any)->(PM__d2 x)',op_elem,2,line,0) + call dcl_proc(parser,'_v3(x:any)->(PM__d3 x)',op_elem,3,line,0) + call dcl_proc(parser,'_v4(x:any)->(PM__d4 x)',op_elem,4,line,0) + call dcl_proc(parser,'_v5(x:any)->(PM__d5 x)',op_elem,5,line,0) + + call dcl_proc(parser,'_v1%(r:any,s:any,h:any,x:any)->(PM__d1% x)',op_elem,1,line,0) + call dcl_proc(parser,'_v2%(r:any,s:any,h:any,x:any)->(PM__d2% x)',op_elem,2,line,0) + call dcl_proc(parser,'_v3%(r:any,s:any,h:any,x:any)->(PM__d3% x)',op_elem,3,line,0) + call dcl_proc(parser,'_v4%(r:any,s:any,h:any,x:any)->(PM__d4% x)',op_elem,4,line,0) + call dcl_proc(parser,'_v5%(r:any,s:any,h:any,x:any)->(PM__d5% x)',op_elem,5,line,0) ! Right hand side references call dcl_uproc(parser,'_make_null(x)=null',line) @@ -3234,7 +3311,7 @@ subroutine sysdefs(parser) call dcl_type(parser,'_p_ref is unique',line) call dcl_proc(parser,& - '_import_dref%(r:any,s:any,h:any,x:any)->^^x',op_import_dref,0,line,0) + '_import_dref%(r:any,s:any,h:any,x:any)->(^^x)',op_import_dref,0,line,0) ! Some trivial referencing cases call dcl_uproc(parser,'PM__sublhsamp%(x,t:subs)=PM__sublhs%(x,t)',line) @@ -3261,7 +3338,7 @@ subroutine sysdefs(parser) !!$ '_arb(x)'//& !!$ ':test "Cannot subscript distributed array in ""forall""" => ''false',line) call dcl_uproc(parser,'PM__sublhs%(region:mshape,x:any^dshape,y)=PM__subref%(x,y)',line) - call dcl_uproc(parser,'PM__subref%(x,y:indexed_dim)=PM__subref%(x,tuple(y <>))',line) + call dcl_uproc(parser,'PM__subref%(x,y:indexed_dim)=PM__subref%(x,_tup%(y))',line) ! Reference of non-distributed array with priv or indexed subscript @@ -3278,7 +3355,7 @@ subroutine sysdefs(parser) 'PM__dref($[](x,t),x,t,null,null)',line) ! Subscript or slice of distributed array - call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar index) <>'//& + call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar index) complete <>'//& '{tt=_tup(t);check_contains(#(x),tt);'//& 'return PM__dref(_arb(x),x,i,p,_s_ref) '//& 'where p,i=node_and_index((#x).dist,(#x)._mshape#tt)}',line) @@ -3290,20 +3367,20 @@ subroutine sysdefs(parser) '{tt=_tup(t);check_contains(#(x),tt);var xx=varray(_arb(x),empty(#x));'//& 'return PM__drefs(xx,x,tt,p,_p_ref) '//& 'where p=nodes_for_grid((#x).dist,tt)}',line) - call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar indexed)<>=PM__subref%(x,*t)',line) + call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar indexed) cond =PM__subref%(x,*t)',line) call dcl_uproc(parser,& - 'PM__subref%(region:shape(,blocked_distr),x:shared any^dshape(,blocked_distr),t:invar indexed) <> {'//& + 'PM__subref%(region:shape(,blocked_distr),x:shared any^dshape(,blocked_distr),t:invar indexed) uncond {'//& 'check_contains(#x,_dmap(t,here));'//& 'return PM__drefi(_arb(x),x,tt,[tt,#x],_d_ref) where tt=_tup(t)}',line) call dcl_uproc(parser,& - 'PM__subref%(x:shared any^dshape,t:invar indexed)<>=PM__subref%(x,*t)',line) + 'PM__subref%(x:shared any^dshape,t:invar indexed) uncond =PM__subref%(x,*t)',line) ! Subscript or slice of non-distristuted array which is itself result of variant slice call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:index)'//& '{tt=_tup(t);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt)'//& 'return PM__dref(_get_aelem(_v1%(x),i),x,i,null,null)}',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar index){'//& - 'tt=_tup(t <>);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt);'//& + 'tt=_tup%(t);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt);'//& 'return PM__drefi(_get_aelem(_v1%(x),i),x,t,null,null)}',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:subs) {'//& 'tt=_tup(t);check_contains(#(_v1%(x)),tt);'//& @@ -3331,12 +3408,12 @@ subroutine sysdefs(parser) ! Subscript of distributed reference call dcl_uproc(parser,'_arb%(x:partial)=_arb(x)',line) - call dcl_uproc(parser,'_arb%(x:complete)=_arb(x <>)',line) - call dcl_uproc(parser,'_arb%(x:chan)=_arb(x <>)',line) - call dcl_uproc(parser,'_arb%(x:invar)=_arb(x <>)',line) + call dcl_uproc(parser,'_arb%(x:complete) complete <>=_arb(x)',line) + call dcl_uproc(parser,'_arb%(x:chan) complete <>=_arb(x)',line) + call dcl_uproc(parser,'_arb%(x:invar) complete <>=_arb(x)',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:invar subs)='//& - 'PM__drefi(_arb%(_v1%(x)),x,_tup(t <>))',line) + 'PM__drefi(_arb%(_v1%(x)),x,_tup%(t))',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:priv subs)='//& 'PM__dref(_arb%(_v1%(x)),x,_tup(t))',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:priv subs)='//& @@ -3348,7 +3425,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar indexed)='//& 'PM__drefi(_arb%(_v1%(x)),x,_tup(t))',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar subs)='//& - 'PM__drefi(_arb%(_v1%(x)),x,_tup(t <>))',line) + 'PM__drefi(_arb%(_v1%(x)),x,_tup%(t))',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:priv subs)='//& 'PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_dp_ref)',line) @@ -3396,7 +3473,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_cap%(x:contains(indexed),h)<>=PM__dref(_v1%(x),x,new _here {here=h})',line) call dcl_uproc(parser,'_capn%(x,h)<>=PM__dref(_v1%(x),x,new _here {here=h})',line) - ! Treat @ variables differently only for limited circumstances in drefs + ! Treat ! variables differently only for limited circumstances in drefs call dcl_uproc(parser,'_drat(at,tile,t)=''false',line) call dcl_uproc(parser,'_drat(at:''true,tile:tuple(range or block_seq),t:indexed and _dr)=''true',line) call dcl_type(parser,'_di(n) is indexed_dim(''1,''1,,n) or int',line) @@ -3418,40 +3495,40 @@ subroutine sysdefs(parser) ' d=#region._mshape;a={_getref(_import_dref%(x),j): j in d};'//& ' p=index(dims(region.dist),node);'//& ' _send_slice(p,a,region.dist[node])}}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) <> {'//& - 'chan var xx=_v1%(x);_getref_s(&xx@,region,^^(x),at <>);_bcast_shared(&xx);return xx}',line) - call dcl_uproc(parser,'_getref_s(&xx,region,x,at) {'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) complete <> {'//& + 'chan var xx=_v1%(x);_getref_s%(&xx!,^^(x),at);_bcast_shared(&xx);return xx}',line) + call dcl_uproc(parser,'_getref_s%(&xx:invar,x:invar,at:invar) PM__node {'//& 'PM__head_node{_irecv(_v4(x),&xx)};'//& '_scatter(x,region);'//& '_sync_messages(xx,x)}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(_comp,,,int,_s_ref),at:invar) <>{'//& - 'chan var xx=_v1%(x);_getref_sc(&xx@,region,^^(x),at <>);_bcast_shared(&xx);return xx}',line) - call dcl_uproc(parser,'_getref_sc(&xx,region,x,at) {'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(_comp,,,int,_s_ref),at:invar) complete <>{'//& + 'chan var xx=_v1%(x);_getref_sc%(&xx!,^^(x),at);_bcast_shared(&xx);return xx}',line) + call dcl_uproc(parser,'_getref_sc%(&xx:invar,x:invar,at:invar) PM__node {'//& '_scatter(x,region);PM__head_node{_recv(_v4(x),&xx)};'//& '_sync_messages(xx,x)}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) <> {'//& - 'chan var a=_v1%(x);_getref_d(&^(PM__local(^(&a@) <>)),region,subregion(schedule),'//& - '^^(x),at <>);'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) complete <> {'//& + 'chan var a=_v1%(x);_getref_d%(&^(PM__local%(^(&a!))),'//& + '^^(x),at <>);'//& '_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_d(&a,region,subregion,x,at) {'//& + call dcl_uproc(parser,'_getref_d%(&a:invar,x:invar,at:invar) PM__node {'//& '_get_dindex_from_dref(&a,x,t.2,'//& - '_local_region(region._tile,subregion),region,t.1,'//& + '_local_region(region._tile,subregion(schedule)),region,t.1,'//& '_drat(at,region._tile,t.1)) where t=_v4(x)'//& '}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) <> {'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) complete <> {'//& 'chan var a=_arb(_v2%(x));'//& - '_getref_dc(&a@,region,subregion(schedule),^^(x),at <>);_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_dc(&a,region,subregion,x,at) {'//& + '_getref_dc%(&a!,^^(x),at <>);_bcast_shared(&a);return a}',line) + call dcl_uproc(parser,'_getref_dc%(&a:invar,x:invar,at:invar) PM__node {'//& 'PM__head_node{_get_dindex(&^(PM__local(^(&a))),PM__local(_v2(x)),t.2,'//& - '_local_region(region._tile,subregion),region,t.1,_drat(at,region._tile,t.1)) '//& + '_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) '//& ' where t=_v4(x)}}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) <> {'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) complete <> {'//& 'chan var a=_v1%(x);'//& - '_getref_dp(&^(^^(^(&a))),region,subregion(schedule),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>);'//& + '_getref_dp%(&^(^^(^(&a))),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>);'//& '_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_dp(&a,region,subregion,x,at,atq,t) {'//& + call dcl_uproc(parser,'_getref_dp%(&a:invar,x:invar,at:invar,atq:invar,t:invar) PM__node {'//& 'PM__head_node{_get_dindex_from_ref(&a,x,t.2,'//& - ' _local_region(region._tile,subregion),region,'//& + ' _local_region(region._tile,subregion(schedule)),region,'//& ' t.1,atq,_drat(at,region._tile,t.1))}'//& '}',line) @@ -3465,7 +3542,6 @@ subroutine sysdefs(parser) ' PM__recv pp,xx,vvv,_cap%(x,here),ppp,at,_getref(xx,null);'//& ' v[u]=vvv};return v}',line) - ! Resolve reference locally (once communicated) call dcl_uproc(parser,'_getref_elem(x:any^mshape,i)=_get_aelem(x,i)',line) call dcl_uproc(parser,& @@ -3502,11 +3578,11 @@ subroutine sysdefs(parser) ! Assignment of distributed and/or shared or uniform references call dcl_uproc(parser,'PM__assign%(&x:priv,y,at) {'//& '_sync%(&x);PM__assign(&x,y <>)}',line) - call dcl_uproc(parser,'PM__assign%(&x:invar,y,at) {_assign_to_invar%(&x,y) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar) '//& - '{ _sync%(&x);PM__assign(&x,y <>) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar) '//& - '{ _sync%(&x);PM__assign(&x,y <>) }',line) + call dcl_uproc(parser,'PM__assign%(&x:invar,y,at) {_sync%(&x);_assign_to_invar%(&x,y) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar) complete '//& + '{ PM__assign(&x,y <>) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar) shared'//& + '{ PM__assign(&x,y) }',line) call dcl_uproc(parser,& '_assign_to_invar%(&x:invar,y:priv) '//& '{ test "Can only assign an ""invar"" value to an ""invar"" variable" => ''false }',line) @@ -3540,12 +3616,13 @@ subroutine sysdefs(parser) '{ PM__assign(&^(_getlhs(^(&xx),null)),PM__import_val(y))}}',line) call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y,at) {'//& - '_set_ref_dp(&^(^^(_cap%(^(&x),here))),^(^^(y)),'//& - ' region,subregion(schedule),$_just_assign,^^(^??),at,_v4(x) <>)}',line) + '_set_ref_dp%(&^(^^(_cap%(^(&x),here))),^(^^(y)),'//& + ' $_just_assign,^^(^??),at,_v4(x) <>)}',line) call dcl_uproc(parser,'_just_assign(x,y)=y',line) - call dcl_uproc(parser,'_set_ref_dp(&x,y,region,subregion,prc,atq,at,t) {'//& + call dcl_uproc(parser,'_set_ref_dp%(&x:invar,y:invar,'//& + ' prc:invar,atq:invar,at:invar,t:invar) PM__node {'//& '_set_dindex_of_ref(&x,y,t.2,'//& - '_local_region(region._tile,subregion),'//& + '_local_region(region._tile,subregion(schedule)),'//& 'region,t.1,prc,atq,at)'//& '}',line) @@ -3553,10 +3630,10 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__assign%(&x:priv,y:priv,pr,at) {PM__assign(&x,y,pr)}',line) call dcl_uproc(parser,'PM__assign%(&x:priv,y:invar,pr,at) {PM__assign(&x,y,pr)}',line) call dcl_uproc(parser,'PM__assign%(&x:invar,y,pr,at) { _assign_to_invar%(&x,y,pr,at) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar,pr,at) '//& - '{ PM__assign(&x,y,pr <>) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar,pr,at) '//& - '{ PM__assign(&x,y,pr <>) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar,pr:uniform,at:uniform) complete'//& + '{ PM__assign(&x,y,pr <>) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar,pr:uniform,at:uniform) shared '//& + '{ PM__assign(&x,y,pr) }',line) call dcl_uproc(parser,'_assign_to_invar%(&x:invar,y:priv,pr,at){'//& '_assign_to_invar%(&x,_reduce_for_assign%(pr,y,x),pr,at)}',line) call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_p_ref),y,pr,at) {'//& @@ -3576,9 +3653,9 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_sp_ref),y:invar,pr,at) {'//& 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),y,pr)}}',line) call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y:priv,pr,at) {'//& - '_set_dindex_of_ref(&^(^^(_cap%(^(&x),here))),^^(y),t.2,'//& + '_set_dindex_of_ref%(&^(^^(_cap%(^(&x),here))),^^(y),t.2,'//& '_local_region(region._tile,subregion(schedule)),'//& - 'region,t.1,pr,^^(^??),at <>)'//& + 'region,t.1,pr,^^(^??),at <>)'//& 'where t=_v4%(x)}',line) ! Resolve LHS reference (locally after communication) @@ -3949,6 +4026,10 @@ subroutine sysdefs(parser) '}',line) ! Resolve x[ indexed ][ whatever ] = priv + call dcl_uproc(parser,& + '_set_dindex_of_ref%(&x:invar,y:invar,shapex:invar,this_tile:invar,local_region:invar,tt:invar indexed,'//& + ' pr:invar proc,complt:invar,at:invar) PM__node <>:'//& + '_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt,pr,complt,at)',line) call dcl_uproc(parser,& '_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt:indexed,'//& ' pr:proc,complt,at) {'//& @@ -4003,7 +4084,7 @@ subroutine sysdefs(parser) call dcl_type(parser,'_nhd is rec{_nbhd,_tile,_tilesz,_interior,_limits}',line) call dcl_type(parser,'nbhd(t) is struct^{_array:farray(t),_nbhd,_index,_here}',line) - call dcl_uproc(parser,'PM__nhd%(x:invar envelope or extent,bound:invar)<>='//& + call dcl_uproc(parser,'PM__nhd%(x:invar envelope or extent,bound:invar) shared <>='//& 'new _nhd {_nbhd=x,_tile=t,_tilesz=#t,_interior=overlap(t,region._tile),'//& '_limits=_expand_limits(region._extent,envelope(x),bound)} '//& 'where t=_get_halo(region,region._tile,envelope(x))',line) @@ -4046,7 +4127,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__nhd_join(x)=x._array',line) call dcl_uproc(parser,'PM__nhd_join(x,y)=new _join{head=x,tail=y._array}',line) call dcl_uproc(parser,'PM__nhd_var%(x,n:_nhd,i,h)<>='//& - 'new nbhd{_array=_make_nhd(^(x,shared),n._tilesz <>),_nbhd=n,_index=i,_here=h}',line) + 'new nbhd{_array=_make_nhd%(^(x,shared),n._tilesz),_nbhd=n,_index=i,_here=h}',line) call dcl_uproc(parser,'PM__nhd_active(region,nbhd,bound:null)=region._extent',line) call dcl_uproc(parser,& 'PM__nhd_active(region,nbhd,bound:tuple)=map($_nhd_active,region._extent,nbhd,bound)',line) @@ -4056,7 +4137,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_nhd_active(r,n,b:range)=low(r)-min(0,low(b))..high(r)-max(0,high(b))',line) call dcl_uproc(parser,'_nhd_active(r,n,b:EXCLUDED)=_nhd_active(r,n,n)',line) - call dcl_uproc(parser,'_make_nhd(x,d){var v=array(x,d);return v}',line) + call dcl_uproc(parser,'_make_nhd%(x:invar,d:invar) shared <>{var v=array(x,d);return v}',line) call dcl_uproc(parser,'PM__set_edge%(&x,y,z){}',line) @@ -4090,7 +4171,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_positive(x)=x>0',line) call dcl_uproc(parser,& - 'PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) <> { '//& + 'PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) shared <> { '//& ' PM__head_node{this_tile=region._tile;this_tile_x=nbhd._tile;'//& ' pp=index2point(_this_node(),dims(region.dist));'//& ' foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) {'//& @@ -4117,7 +4198,7 @@ subroutine sysdefs(parser) '}}',line) call dcl_uproc(parser,& - 'PM__send_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) <> { '//& + 'PM__send_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { '//& ' PM__head_node{this_tile=region._tile;this_tile_x=nbhd._tile;'//& ' pp=index2point(_this_node(),dims(region.dist));'//& ' foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { '//& @@ -4144,12 +4225,12 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_foot(d,n:envelope)=if(_crss(d)=>n.cross,n.corner)',line) call dcl_uproc(parser,'_foot(d,n:extent)=n',line) - call dcl_uproc(parser,'PM__recv_nhd%(&a:invar,nbhd:invar,b:invar) <> {'//& + call dcl_uproc(parser,'PM__recv_nhd%(&a:invar,nbhd:invar,b:invar) shared <> {'//& 'PM__head_node{_apply_boundaries(&a,region,envelope(nbhd._nbhd),nbhd._tile,extent(region),'//& ' envelope(nbhd._nbhd),b,rank(extent(region)),''true)}}',line) call dcl_uproc(parser,& - 'PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) <> { '//& + 'PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { '//& ' PM__head_node{this_tile=region._tile;this_tile_x=nbhd._tile;'//& ' pp=index2point(_this_node(),dims(region.dist));'//& ' foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) {'//& @@ -4167,7 +4248,7 @@ subroutine sysdefs(parser) '}}',line) call dcl_uproc(parser,& - 'PM__bcast_nhd%(&a:invar,nbhd:invar,b:invar) <> {'//& + 'PM__bcast_nhd%(&a:invar,nbhd:invar,b:invar) shared <> {'//& 'if shrd_nnode()>1 {'//& ' foreach i in 1..chunks(region,envelope(nbhd._nbhd))-1 {'//& ' chunk=chunk(region,envelope(nbhd._nbhd),i,b);'//& @@ -4444,7 +4525,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'nbr%(x:chan,t:shared disp_index,v:shared){'//& ' test "Default and chan values must have same type in ""nbr"""=>same_type(x,v);'//& ' j=displace(region._mshape,here,t);'//& - ' var y=v;if contains(region._mshape,j) {y=x@[j]};'//& + ' var y=v;if contains(region._mshape,j) {y=x![j]};'//& ' return y} ',line) call dcl_uproc(parser,& 'nbhd%(x:chan,t:shared disp_sub,v:shared) { '//& @@ -4452,7 +4533,7 @@ subroutine sysdefs(parser) ' var a=array(v,#t);'//& ' foreach invar i in t {'//& ' j=displace(region._mshape,here,i);'//& - ' if j in region._mshape {a[here]=x@[j]}'//& + ' if j in region._mshape {a[here]=x![j]}'//& ' };return a}',line) ! *** Blocked distributions *** @@ -4545,29 +4626,29 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& 'topology(tp,dis,d,l:int)=tp',line) - call dcl_proc(parser,'_get_dims(int,int)->int',op_get_dims,0,& + call dcl_proc(parser,'_get_dims(int,int)->(int)',op_get_dims,0,& line,proc_is_impure) - call dcl_proc(parser,'_get_dims(int,int,int)->int,int',& + call dcl_proc(parser,'_get_dims(int,int,int)->(int,int)',& op_get_dims,0,& line,proc_is_impure) - call dcl_proc(parser,'_get_dims(int,int,int,int)->int,int,int',& + call dcl_proc(parser,'_get_dims(int,int,int,int)->(int,int,int)',& op_get_dims,0,& line,proc_is_impure) call dcl_proc(parser,& - '_get_dims(int,int,int,int,int)->int,int,int,int',& + '_get_dims(int,int,int,int,int)->(int,int,int,int)',& op_get_dims,0,& line,proc_is_impure) - call dcl_proc(parser,'_get_dims(int,int,int,int,int,int)->'//& - 'int,int,int,int,int',& + call dcl_proc(parser,'_get_dims(int,int,int,int,int,int)->('//& + 'int,int,int,int,int)',& op_get_dims,0,& line,proc_is_impure) - call dcl_proc(parser,'_get_dims(int,int,int,int,int,int,int)->'//& - 'int,int,int,int,int,int',& + call dcl_proc(parser,'_get_dims(int,int,int,int,int,int,int)->('//& + 'int,int,int,int,int,int)',& op_get_dims,0,& line,proc_is_impure) call dcl_proc(parser,& - '_get_dims(int,int,int,int,int,int,int,int)->'//& - 'int,int,int,int,int,int,int',& + '_get_dims(int,int,int,int,int,int,int,int)->('//& + 'int,int,int,int,int,int,int)',& op_get_dims,0,& line,proc_is_impure) @@ -4915,9 +4996,9 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__setelem(&a:array_slice(any^any,),v,t:index) {'//& ' _set_elem(&a._a,v,a._s[t]) }',line) - call dcl_uproc(parser,'PM__get_elem%(x:shared,i,h)=PM__getelem(x,h)',line) + call dcl_uproc(parser,'PM__get_elem%(x,i,h)=PM__getelem(x,h)',line) call dcl_uproc(parser,'PM__set_elem%(&x:invar,v:complete,i,h)'//& - '{PM__setelem(&x,v,h <>);_assemble(&x,region <>)}',line) + '{PM__setelem(&x,v,h <>);_assemble%(&x,region)}',line) call dcl_uproc(parser,'PM__get_elem%(x:shared any^dshape,i,h)='//& 'element(PM__local(x),i)',line) @@ -4931,12 +5012,12 @@ subroutine sysdefs(parser) 'PM__setaelem(&x._a,i,v <>) check p==_this_node() '//& ' where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) }',line) !!! - call dcl_uproc(parser,'_assemble(&a:any^mshape,region:mshape) {}',line) + call dcl_uproc(parser,'_assemble%(&a:invar any^mshape,xregion:invar mshape) {}',line) - call dcl_uproc(parser,'_assemble(&a:array_slice(any^shape,),region:mshape) {}',line) + call dcl_uproc(parser,'_assemble%(&a:invar array_slice(any^shape,),xregion:invar mshape) {}',line) - call dcl_uproc(parser,'_assemble(&a:any^mshape,region) {'//& - ' dist=region.dist; '//& + call dcl_uproc(parser,'_assemble%(&a:invar any^mshape,xregion:invar) shared <> {'//& + ' dist=xregion.dist; '//& ' foreach p in #(dist) {'//& ' tile=dist[p];'//& ' i=index(dims(dist),p);'//& @@ -4955,8 +5036,8 @@ subroutine sysdefs(parser) ' } }',& line) - call dcl_uproc(parser,'_assemble(&a:array_slice(any^shape,),region) {'//& - ' dist=region.dist; '//& + call dcl_uproc(parser,'_assemble%(&a:invar array_slice(any^shape,),xregion:invar) shared <> {'//& + ' dist=xregion.dist; '//& ' foreach p in #(dist) {'//& ' tile=intersect((#(a._a))#a._s,dist[p]);'//& ' i=index(dims(dist),p);'//& @@ -4979,47 +5060,48 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__get_tilesz(d)=d._tile,d._size',line) call dcl_uproc(parser,'PM__get_tilesz(d:mshape)=d,size(d)',line) - ! Support for @ operator + ! Support for ! operator if(pm_is_compiling) then call dcl_uproc(parser,& - 'PM__makearray%(x:chan)<>=_makearray(x,region,size(region))',line) + 'PM__makearray%(x:chan) complete <>=_makearray(x,region,size(region))',line) call dcl_uproc(parser,& 'PM__makearray%(x:priv)=_makearray(x,region,size(region))'//& - ':test "Can only apply ""@"" to a ""chan"" " => ''false',line) + ':test "Can only apply ""!"" to a ""chan"" " => ''false',line) call dcl_uproc(parser,& 'PM__makearray%(x:invar)=_makearray(x,region,size(region))'//& - ':test "Cannot apply ""@"" to a ""shared"" or ""uniform"" value" => ''false',line) + ':test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => ''false',line) call dcl_proc(parser,& - '_makearray(x:any,y:any,z:any)->PM__invar_dim x,y',& + '_makearray(x:any,y:any,z:any)->(PM__invar_dim x,y)',& op_make_array,0,line,proc_needs_type) else call dcl_uproc(parser,& - 'PM__makearray%(x:chan)<>=_makearray(x,region)',line) + 'PM__makearray%(x:chan) complete <>=_makearray(x,region)',line) call dcl_uproc(parser,& 'PM__makearray%(x:priv)=_makearray(x,region)'//& - ':test "Can only apply ""@"" to a ""chan"" " => ''false',line) + ':test "Can only apply ""!"" to a ""chan"" " => ''false',line) call dcl_uproc(parser,& 'PM__makearray%(x:invar)=_makearray(x,region)'//& - ':test "Cannot apply ""@"" to a ""shared"" or ""uniform"" value" => ''false',line) + ':test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => ''false',line) call dcl_proc(parser,& - '_makearray(x:any,y:any)->PM__dim x,y',& + '_makearray(x:any,y:any)->(PM__dim x,y)',& op_make_array,0,line,proc_needs_type) !!$ call dcl_uproc(parser,'PM__correctarray(x)=_redim(PM__export endif ! active%() intrinsic - call dcl_uproc(parser,'active%(x)=masked(^(x,coherent),^(^??,coherent) <>)',line) + call dcl_uproc(parser,'active%(x)=_masked%(^(x,coherent),^(^??,coherent) <>)',line) + call dcl_uproc(parser,'_masked%(x) complete <>=masked(x)',line) call dcl_uproc(parser,'active%()=^(^??,coherent)',line) - call dcl_proc(parser,'PM__active()->bool',op_active,0,line,0) + call dcl_proc(parser,'PM__active()->(bool)',op_active,0,line,0) ! Imports and exports - call dcl_proc(parser,'_import_val(x:any)->=x',& + call dcl_proc(parser,'_import_val(x:any)->(=x)',& op_import_val,0,line,0) - call dcl_proc(parser,'PM__importshrd(x:any)->=x',& + call dcl_proc(parser,'PM__importshrd(x:any)->(=x)',& op_import_val,0,line,0) - call dcl_proc(parser,'PM__importvarg(x:any)->=x',& + call dcl_proc(parser,'PM__importvarg(x:any)->(=x)',& op_import_varg,0,line,proc_is_not_inlinable) - call dcl_proc(parser,'_import_scalar(x:any)->invar x',& + call dcl_proc(parser,'_import_scalar(x:any)->(invar x)',& op_import_scalar,0,line,0) call dcl_uproc(parser,'PM__import_val(x) {PM__checkimp(x);return _import_val(x)}',line) call dcl_uproc(parser,'PM__impscalar(x) {PM__checkimp(x);return _import_scalar(x)}',line) @@ -5041,18 +5123,18 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'subtile(schedule:schedule)=schedule._subtile',line) ! Over statements - call dcl_uproc(parser,'PM__over%(schedule:null,x:invar,block:invar)<>='//& + call dcl_uproc(parser,'PM__over%(schedule:null,x:invar,block:invar) shared <>='//& 'new schedule{_subregion=x,_subtile=overlap(region._tile,x),_blocking=_blocking(block,region)}',line) - call dcl_uproc(parser,'PM__over%(x:invar,block:invar)<>='//& + call dcl_uproc(parser,'PM__over%(x:invar,block:invar) shared <>='//& 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& 'where s=intersect(x,schedule._subregion)',line) call dcl_uproc(parser,'PM__make_over%(schedule:null,'//& - 'x:invar tuple(subs_dim except stretch_dim),block:invar)<>='//& + 'x:invar tuple(subs_dim except stretch_dim),block:invar) shared <>='//& 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& 'check "Value"++s++" in ""over"" out of bounds: "++region._extent=>region._extent inc s '//& 'where s=fill_in(region._extent,x,null)',line) call dcl_uproc(parser,'PM__make_over%(x:invar tuple(subs_dim except stretch_dim)'//& - ',block:invar)<>='//& + ',block:invar) shared <>='//& 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& 'where s=intersect(map($norm,fill_in(region._extent,x,''true)),schedule._subregion)',line) call dcl_uproc(parser,'PM__make_over%(x:invar,block)=x'//& @@ -5073,12 +5155,12 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__do_over%(x:null)=true',line) call dcl_uproc(parser,'PM__do_over%(x:invar schedule(tuple(seq or block_seq)))=here in x._subregion',line) call dcl_uproc(parser,'PM__do_over%(x:invar schedule(grid))=PM__do_over%(schedule._subtile)',line) - call dcl_uproc(parser,'PM__do_over%(x:invar grid) <>'//& + call dcl_uproc(parser,'PM__do_over%(x:invar grid) complete <>'//& '{chan var t=false;'//& - ' _in(x,&^(PM__local(^(&t@))) <>);'//& + ' _in%(x,&^(PM__local(^(&t!))) <>);'//& ' return t}',line) call dcl_uproc(parser,'PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x',line) - call dcl_uproc(parser,'_in(x,&t){forall i in x {sync t[i]=true}}',line) + call dcl_uproc(parser,'_in%(x:invar,&t:invar) shared <>{forall i in x {sync t[i]=true}}',line) else call dcl_uproc(parser,'PM__do_over(x:null,region)=x',line) call dcl_uproc(parser,'PM__do_over(x:schedule,region)='//& @@ -5095,17 +5177,17 @@ subroutine sysdefs(parser) endif ! Parallel processing inquiry - call dcl_proc(parser,'_sys_node()->int',op_sys_node,0,line,0) - call dcl_proc(parser,'sys_nnode()->int',op_sys_nnode,0,line,0) - call dcl_proc(parser,'_this_node()->int',op_this_node,1,line,0) - call dcl_proc(parser,'this_node%(r:any,s:any,h:any)->int',op_this_node,2,line,0) - call dcl_proc(parser,'this_nnode()->int',op_this_nnode,0,line,0) - call dcl_proc(parser,'_shrd_node()->int',op_shared_node,0,line,0) - call dcl_proc(parser,'shrd_nnode()->int',op_shared_nnode,0,line,0) - call dcl_proc(parser,'_root_node()->int',op_root_node,0,line,0) - call dcl_proc(parser,'is_shrd()->bool',op_is_shared,0,line,0) - call dcl_proc(parser,'is_shrd(any)->bool',op_is_shared,0,line,0) - call dcl_proc(parser,'is_par()->bool',op_is_par,0,line,0) + call dcl_proc(parser,'_sys_node()->(int)',op_sys_node,0,line,0) + call dcl_proc(parser,'sys_nnode()->(int)',op_sys_nnode,0,line,0) + call dcl_proc(parser,'_this_node()->(int)',op_this_node,1,line,0) + call dcl_proc(parser,'this_node%(r:any,s:any,h:any)->(int)',op_this_node,2,line,0) + call dcl_proc(parser,'this_nnode()->(int)',op_this_nnode,0,line,0) + call dcl_proc(parser,'_shrd_node()->(int)',op_shared_node,0,line,0) + call dcl_proc(parser,'shrd_nnode()->(int)',op_shared_nnode,0,line,0) + call dcl_proc(parser,'_root_node()->(int)',op_root_node,0,line,0) + call dcl_proc(parser,'is_shrd()->(bool)',op_is_shared,0,line,0) + call dcl_proc(parser,'is_shrd(any)->(bool)',op_is_shared,0,line,0) + call dcl_proc(parser,'is_par()->(bool)',op_is_par,0,line,0) call dcl_uproc(parser,'_head_node()=_shrd_node()==0',line) ! Parallel system nested contexts @@ -5219,32 +5301,32 @@ subroutine sysdefs(parser) 'conform(#work,#d); '//& 'var wk=work;return _wshare(wk,nnode,snode,nsnode) }',line) call dcl_proc(parser,& - '_wshare(int^any,int,int,int)->int',op_wshare,0,line,0) + '_wshare(int^any,int,int,int)->(int)',op_wshare,0,line,0) ! ************************************************************* ! I/O OPERATIONS ! ************************************************************* ! Built-in operators - call dcl_proc(parser,'_open_file(string,bool,bool,bool,bool,bool,bool,bool)->sint,sint',& - op_open_file,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_close_file(sint)->sint',& - op_close_file,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_seek_file(sint,lint)->sint',& - op_seek_file,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_read_file(sint,&any)->sint',& - op_read_file,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_write_file(sint,any)->sint',& - op_write_file,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_read_file_array(sint,&any,int)->sint',& - op_read_file_array,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_write_file_array(sint,any,int)->sint',& - op_write_file_array,0,line,proc_is_impure+proc_is_variant) - call dcl_proc(parser,'_read_file_tile%(any,any,any,sint,&any,int,int)->sint',& - op_read_file_tile,0,line,proc_is_impure+proc_is_dcomm+proc_is_variant) - call dcl_proc(parser,'_write_file_tile%(any,any,any,sint,any,int,int)->sint',& - op_write_file_tile,0,line,proc_is_impure+proc_is_dcomm+proc_is_variant) - call dcl_proc(parser,'_io_error_string(sint)->string',& + call dcl_proc(parser,'_open_file(string,bool,bool,bool,bool,bool,bool,bool)->(sint,sint)',& + op_open_file,0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_close_file(sint)->(sint)',& + op_close_file,0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_seek_file(sint,lint)->(sint)',& + op_seek_file,0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_read_file(sint,&any)->(sint)',& + op_read_file,0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_write_file(sint,any)->(sint)',& + op_write_file,0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_read_file_array(sint,&any,int)->(sint)',& + op_read_file_array,0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_write_file_array(sint,any,int)->(sint)',& + op_write_file_array,0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_read_file_tile%(any,any,any,sint,&any,int,int)->(sint)',& + op_read_file_tile,0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_write_file_tile%(any,any,any,sint,any,int,int)->(sint)',& + op_write_file_tile,0,line,proc_is_impure+proc_is_file) + call dcl_proc(parser,'_io_error_string(sint)->(string)',& op_io_error_string,0,line,proc_is_impure) ! IO/related types @@ -5253,6 +5335,7 @@ subroutine sysdefs(parser) call dcl_type(parser,'file is struct {_f:sint,_tag:PM__distr_tag}',line) call dcl_type(parser,'io_error is rec {_errno:sint,use _iserr:bool}',line) call dcl_uproc(parser,'PM__filesys()=new filesystem{}',line) + ! call dcl_uproc(parser,'PM__filesys()=0',line) ! Basic operations call dcl_uproc(parser,'open(&filesystem:filesystem,name,'//& @@ -5531,15 +5614,16 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_tup(x:tuple)=x',line) call dcl_uproc(parser,'_tup(arg...)=tuple(arg...)',line) call dcl_uproc(parser,'_tup(x:null)=x',line) + call dcl_uproc(parser,'_tup%(x:invar) shared=_tup(x)',line) call dcl_proc(parser,'PM__broadcast(&b:any,a:int)',op_broadcast,& 0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'PM__broadcast(b:any,a:int)->=b',op_broadcast_val,& + call dcl_proc(parser,'PM__broadcast(b:any,a:int)->(=b)',op_broadcast_val,& 0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,& 'get_remote%(r:any,s:any,h:any,a:shared any^dshape,'//& - 'b:int,c:int)->%a',& + 'b:int,c:int)->(%a)',& op_get_remote_distr,& 0,line,proc_is_impure+proc_is_dcomm) @@ -5578,7 +5662,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'max(x:real_num^any,y:real_num)=map_const($max,x,y)',line) call dcl_uproc(parser,'min(x:real_num^any,y:real_num)=map_const($min,x,y)',line) - call dcl_proc(parser,'_pack(v:any,any,any,d:any)->PM__dim v,d',& + call dcl_proc(parser,'_pack(v:any,any,any,d:any)->(PM__dim v,d)',& op_pack,0,line,0) call dcl_uproc(parser,'pack(v:any^mshape,m:bool^mshape) { '//& ' test "arrays do not conform"=>conform(#v,#m); '//& @@ -5619,10 +5703,14 @@ subroutine sysdefs(parser) 'chan yy=y;return init / _reduce%($*,yy,init)}',line) call dcl_uproc(parser,'reduce%(p:invar proc,y:chan,init)='//& - '^(p.(init,_reduce(p,reduce(p,PM__local(y@) <>)<>)),uniform)',line) + '^(p.(init,__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>)),uniform)',line) call dcl_uproc(parser,'_reduce%(p:invar proc,y:chan)='//& - '^(_reduce(p,reduce(p,PM__local(y@) <>)<>),uniform)',line) + '^(__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>),uniform)',line) + + call dcl_uproc(parser,'_reduce_on_node%(p:invar,y:invar) PM__node=reduce(p,y)',line) + call dcl_uproc(parser,'__reduce_on_node%(p:invar,y:invar) PM__node=_reduce(p,y)',line) + call dcl_uproc(parser,'_reduce(p:proc,y) {'//& 'var x=array(y,[0..0]);var z=array(y,[0..0]);'//& 'var n=this_nnode();var i=1;'//& @@ -5642,40 +5730,87 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__getkey(x:any,y:any)=convert(x,y)',line) call dcl_uproc(parser,'PM__getkey(x:null,y:any)=y',line) - ! Select statement - call dcl_uproc(parser,& - 'PM__checkcase(x,y,arg...) { var e=match_switch_case(x,y); '//& - 'if not e { e=PM__checkcase(x,arg...) };return e }',line) + ! Switch statement + call dcl_uproc(parser,'PM__checkcase(x:literal,y:literal)=match_switch_case(x,y)',line) call dcl_uproc(parser,'PM__checkcase(x,y)=match_switch_case(x,y)',line) + call dcl_uproc(parser,'match_switch_case(x:literal,y:literal)=x==y',line) + call dcl_uproc(parser,'match_switch_case(x:fix any,y:fix any)=x==y',line) call dcl_uproc(parser,'match_switch_case(x,y)=x==y',line) call dcl_uproc(parser,& 'match_switch_case(x:real_num,y:range(real_num))=x>=y._lo and x<=y._hi',& line) + call dcl_uproc(parser,& + 'match_switch_case(x:real_num,y:_crange)=x>=y._lo and x<=y._hi',& + line) + call dcl_uproc(parser,& + 'match_switch_case(x:int_literal,y:_crange)=(x>=y._lo and x<=y._hi) as ',& + line) + call dcl_uproc(parser,& + 'match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi',& + line) call dcl_uproc(parser,'match_switch_case(x:,y:)=y inc x',line) + call dcl_type(parser,'_crange is rec{_lo,_hi}',line) + call dcl_uproc(parser,'PM__caserange(x,y)=x..y',line) + call dcl_uproc(parser,'PM__caserange(x:fix(int),y:fix(int))='//& + 'new _crange{_lo=x,_hi=y}',line) ! Conditional operators call dcl_uproc(parser,& - 'PM__if(x,y,z) check "Incompatible types in different ""if""branches"=> '//& + 'PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> '//& 'same_type(y,z) { var r=z; if x { r=y };return r }',& line) +!!$ call dcl_uproc(parser,'PM__if(x:bool_literal,y,z)=PM__do_if(x,y,z)'//& +!!$ 'check "Incompatible types in different ""if"" branches"=> '//& +!!$ 'same_type(y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:int_literal,z:int_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:real_literal,z:real_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:string_literal,z:string_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:bool_literal,z:bool_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:literal,z:literal)=PM__do_if(x,y,z)'//& +!!$ 'check "Incompatible types in different ""if"" branches"=>''false',line) + +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y,z)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y:literal,z:literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y,z:literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y:literal,z)=PM__do_if(x,y,z)',line) + call dcl_uproc(parser,'PM__if(x:''true,y,z)=y',line) call dcl_uproc(parser,'PM__if(x:''false,y,z)=z',line) - call dcl_uproc(parser,'PM__if(x,y,arg...)=PM__if(x,y,PM__if(arg...))',line) + call dcl_uproc(parser,'PM__if(x:''true,y:literal,z)=y',line) + call dcl_uproc(parser,'PM__if(x:''false,y,z:literal)=z',line) +!!$ call dcl_uproc(parser,'PM__if(x,y,arg...)=PM__if(x,y,PM__if(arg...))',line) call dcl_uproc(parser,& 'PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> '//& 'same_type(y,z) { var r=z; if match(w,x) { r=y };return r }',& line) + call dcl_uproc(parser,'PM__switch(w:fix(int),x:fix(int),y,z)=PM__if(w==x,y,z)',line) + + call dcl_uproc(parser,'PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z)',line) + call dcl_uproc(parser,'PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z)',line) + call dcl_uproc(parser,'PM__switch(w,x,y,arg...)=PM__switch(w,x,y,PM__switch(w,arg...))',line) ! Assignment - call dcl_uproc(parser,'PM__assign_var(&a,b) {PM__assign(&a,b)}',line) call dcl_uproc(parser,& - 'PM__assign(&a:any,b:any) {check_assign_types(a,b);_assign(&a,b)}',line) - call dcl_type(parser,'assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,...',line) + 'PM__assign_or_init(a,b)<>=a {PM__assign_var(&^(a),b)}',line) + call dcl_uproc(parser,& + 'PM__assign_or_init(a:,b)=PM__dup(b as a)',line) + call dcl_uproc(parser,& + 'PM__assign_var(&a,b) {PM__assign(&a,b)}',line) + call dcl_uproc(parser,& + 'PM__assign(&a:any,b:any) {_assign(&a,c) where c=b as a}',line) + call dcl_type(parser,& + 'assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,...',line) call dcl_uproc(parser,& 'PM__assign(&a:any,b:any,c:assignment_operator) { PM__assign(&a,c.(a,b)) }',line) call dcl_uproc(parser,& - 'PM__assign(&a:any,b:any,c:proc) { test "Not a recognised assignment operator"=>''false }',line) + 'PM__assign(&a:any,b:any,c:proc) { '//& + 'test "Not a recognised assignment operator"=>''false }',line) call dcl_uproc(parser,'check_assign_types(x,y)'//& '{test "Type mismatch in assignment"=>same_type(x,y)}',line) call dcl_uproc(parser,'_assign(&a,b) {_assign_element(&a,b)}',line) @@ -5685,10 +5820,15 @@ subroutine sysdefs(parser) call dcl_proc(parser,'_assign_element(&any,any)',op_assign,0,line,0) ! Other variable operations - call dcl_proc(parser,'PM__clone(x:any)->=x',op_clone,0,line,0) + call dcl_proc(parser,'PM__clone(x:any)->(=x)',op_clone,0,line,0) call dcl_uproc(parser,'PM__dup(PM__dup) <>=PM__clone(PM__dup)',line) - call dcl_proc(parser,'PM__getref(x:any)->=x',op_get_rf,0,line,0) - call dcl_proc(parser,'same_type(x:any,y:any)->==x,y',& + call dcl_proc(parser,'PM__dup(x:fix int)->(int)',op_clone,0,line,0) + call dcl_proc(parser,'PM__dup(x:fix real)->(real)',op_clone,0,line,0) + call dcl_proc(parser,'PM__dup(x:fix string)->(string)',op_clone,0,line,0) + call dcl_proc(parser,'PM__dup(x:fix bool)->(bool)',op_clone,0,line,0) + + call dcl_proc(parser,'PM__getref(x:any)->(=x)',op_get_rf,0,line,0) + call dcl_proc(parser,'same_type(x:any,y:any)->(==x,y)',& op_logical_return,0,line,proc_needs_type) call dcl_uproc(parser,'==(x:any,y:any) {'//& 'test "Cannot apply ""=="" to different types"=> same_type(x,y);'//& @@ -5698,20 +5838,21 @@ subroutine sysdefs(parser) 'var ok=true;_eq(x,y,&ok);return not ok}',line) call dcl_uproc(parser,& '_eq(x:any,y:any,&ok) <> { ok=ok and x==y }',line) - call dcl_proc(parser,'PM__copy_out(x:any)->=x',op_clone,0,line,0) - call dcl_proc(parser,'PM__copy_back(x:any)->=x',op_assign,0,line,0) + call dcl_proc(parser,'PM__copy_out(x:any)->(=x)',op_clone,0,line,0) + call dcl_proc(parser,'PM__copy_back(x:any)->(=x)',op_assign,0,line,0) call dcl_uproc(parser,'next_enum(x:int)=x+convert(1,x)',line) call dcl_uproc(parser,'next_enum(x:int,y:int)=x+convert(y,x)',line) ! Type values - call dcl_proc(parser,'typeof(x:any)->type x',op_make_type_val,0,line,proc_needs_type) + call dcl_proc(parser,'typeof(x:any)->(type x)',op_make_type_val,0,line,proc_needs_type) call dcl_uproc(parser,'is(x,t)=t inc typeof(x)',line) + call dcl_uproc(parser,'isnt(x,t)=not(x is t)',line) call dcl_uproc(parser,'as(x,t:)...=PM__cast(x,t)',line) call dcl_uproc(parser,'as(x,t)=PM__cast(x,typeof(t))',line) - call dcl_proc(parser,'inc(x:,y:)-> inc x,y',op_logical_return,0,line,proc_needs_type) + call dcl_proc(parser,'inc(x:,y:)->( inc x,y)',op_logical_return,0,line,proc_needs_type) call dcl_uproc(parser,'==(x:,y:)=x inc y and y inc x',line) - call dcl_proc(parser,'error_type()->?0',0,0,line,proc_needs_type) + call dcl_proc(parser,'error_type()->(?0)',0,0,line,proc_needs_type) ! Debugging call dcl_proc(parser,'_dump(any,any)',op_new_dump,0,line,proc_is_impure) diff --git a/src/sysdefs_old_nhd.f90 b/src/sysdefs_make.f90 similarity index 63% rename from src/sysdefs_old_nhd.f90 rename to src/sysdefs_make.f90 index 6d0933b..1d4c537 100755 --- a/src/sysdefs_old_nhd.f90 +++ b/src/sysdefs_make.f90 @@ -1,45 +1,10 @@ -! -! PM (Parallel Models) Programming Language -! -! Released under the MIT License (MIT) -! -! Copyright (c) Tim Bellerby, 2023 -! -! Permission is hereby granted, free of charge, to any person obtaining a copy -! of this software and associated documentation files (the "Software"), to deal -! in the Software without restriction, including without limitation the rights -! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -! copies of the Software, and to permit persons to whom the Software is -! furnished to do so, subject to the following conditions: -! -! The above copyright notice and this permission notice shall be included in -! all copies or substantial portions of the Software. -! -! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -! THE SOFTWARE. - -! System module code (intrinsic types and procedures) -! Note: this is *not* written in canonical PM -! some rules are suspended and use is made of internal-only constructs - -module pm_sysdefs - use pm_kinds - use pm_memory - use pm_parser - use pm_hash - use pm_lib - use pm_symbol - use pm_types - use pm_vmdefs - implicit none - - ! Flag values for procs - ! (note values 1=proc_is_comm,... defined in parser) +program make_sysmod + integer,parameter:: proc_is_comm= 1 + integer,parameter:: proc_is_open= 128 + integer,parameter:: proc_is_each_proc= 256 + integer,parameter:: proc_is_cond= 512 + integer,parameter:: proc_is_uncond= 1024 + integer,parameter:: proc_is_abstract= 2048 integer,parameter:: proc_is_thru_each = 2**12 integer,parameter:: proc_is_empty_each = 2**13 integer,parameter:: proc_is_dup_each = 2**14 @@ -47,514 +12,578 @@ module pm_sysdefs integer,parameter:: proc_is_generator = 2**16 integer,parameter:: proc_needs_type = 2**17 integer,parameter:: proc_is_recursive = 2**18 - integer,parameter:: proc_unfinished = 2**19 integer,parameter:: proc_is_impure = 2**20 integer,parameter:: proc_is_not_inlinable = 2**21 integer,parameter:: proc_has_for = 2**22 integer,parameter:: proc_is_not_pure_each = 2**23 integer,parameter:: proc_has_vkeys = 2**24 integer,parameter:: proc_is_dcomm = 2**25 - integer,parameter:: proc_is_variant = 2**26 - integer,parameter:: proc_needs_par = 2**27 - - integer,parameter:: proc_taints = proc_is_impure & - + proc_is_not_inlinable + proc_has_for & - + proc_is_not_pure_each + proc_is_variant & - + proc_needs_par - -contains - - subroutine sysdefs(parser) - type(parse_state):: parser - integer:: line - line=1 - - call dcl_module(parser,'PM__system') - parser%sysmodl=parser%modl - - ! ************************************** - ! BASIC TYPES - ! ************************************** - - ! String type - call dcl_proc(parser,'print(string)',op_print,0,line,proc_is_impure) + integer,parameter:: proc_is_file = 2**26 + + logical,parameter:: pm_is_compiling=.false. + + integer parser,line + + call dcl_type(parser,'literal is ^^^any',line) + call dcl_type(parser,'int_literal is ^^^int',line) + call dcl_type(parser,'real_literal is ^^^real',line) + call dcl_type(parser,'bool_literal is ^^^bool',line) + call dcl_type(parser,'string_literal is ^^^string',line) + + call dcl_proc(parser,'mod(int_literal,int_literal)->int_literal',"mod_fold",0,line,0) + call dcl_proc(parser,'==(int_literal,int_literal)->bool_literal',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(int_literal,int_literal)->bool_literal',"ne_fold",0,line,0) + call dcl_proc(parser,'>=(int_literal,int_literal)->bool_literal',"ge_fold",0,line,0) + call dcl_proc(parser,'>(int_literal,int_literal)->bool_literal',"gt_fold",0,line,0) + call dcl_proc(parser,'+(int_literal,int_literal)->int_literal',"add_fold",0,line,0) + call dcl_proc(parser,'-(int_literal,int_literal)->int_literal',"sub_fold",0,line,0) + call dcl_proc(parser,'*(int_literal,int_literal)->int_literal',"mult_fold",0,line,0) + call dcl_proc(parser,'/(int_literal,int_literal)->int_literal',"divide_fold",0,line,0) + call dcl_proc(parser,'**(int_literal,int_literal)->int_literal',"pow_fold",0,line,0) + call dcl_proc(parser,'max(int_literal,int_literal)->int_literal',"max_fold",0,line,0) + call dcl_proc(parser,'min(int_literal,int_literal)->int_literal',"min_fold",0,line,0) + call dcl_proc(parser,'-(int_literal)->int_literal',"uminus_fold",0,line,0) + call dcl_proc(parser,'string(int_literal)->string',"string_fold",0,line,0) + call dcl_proc(parser,'abs(int_literal)->int_literal',"abs_fold",0,line,0) + call dcl_proc(parser,'~(int_literal)->int_literal',"bnot_fold",0,line,0) + call dcl_proc(parser,'&(int_literal,int_literal)->int_literal',"band_fold",0,line,0) + call dcl_proc(parser,'|(int_literal,int_literal)->int_literal',"bor_fold",0,line,0) + call dcl_proc(parser,'xor(int_literal,int_literal)->int_literal',"bxor_fold",0,line,0) + call dcl_proc(parser,'shift(int_literal,int_literal)->int_literal',& + "bshift_fold",0,line,0) + call dcl_proc(parser,'pdiff(int_literal,int_literal)->int_literal',"pdiff_fold",0,line,0) + call dcl_proc(parser,'sign(int_literal,int_literal)->int_literal',"sign_fold",0,line,0) + call dcl_proc(parser,'rem(int_literal,int_literal)->int_literal',"modulo_fold",0,line,0) + call dcl_proc(parser,'and(bool_literal,bool_literal)->bool_literal',"and_fold",0,line,0) + call dcl_proc(parser,'or(bool_literal,bool_literal)->bool_literal',"or_fold",0,line,0) + call dcl_proc(parser,'except(bool_literal,bool_literal)->bool_literal',"except_fold",0,line,0) + call dcl_proc(parser,'==(bool_literal,bool_literal)->bool_literal',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(bool_literal,bool_literal)->bool_literal',"ne_fold",0,line,0) + call dcl_proc(parser,'==(string_literal,string_literal)->bool_literal',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(string_literal,string_literal)->bool_literal',"ne_fold",0,line,0) + call dcl_proc(parser,'==(real_literal,real_literal)->bool_literal',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(real_literal,real_literal)->bool_literal',"ne_fold",0,line,0) + call dcl_proc(parser,'++(string_literal,string_literal)->string_literal',"concat_fold",0,line,0) + + call dcl_proc(parser,'mod(fix int,fix int)->fix int',"mod_fold",0,line,0) + call dcl_proc(parser,'==(fix int,fix int)->fix bool',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(fix int,fix int)->fix bool',"ne_fold",0,line,0) + call dcl_proc(parser,'>=(fix int,fix int)->fix bool',"ge_fold",0,line,0) + call dcl_proc(parser,'>(fix int,fix int)->fix bool',"gt_fold",0,line,0) + call dcl_proc(parser,'+(fix int,fix int)->fix int',"add_fold",0,line,0) + call dcl_proc(parser,'-(fix int,fix int)->fix int',"sub_fold",0,line,0) + call dcl_proc(parser,'*(fix int,fix int)->fix int',"mult_fold",0,line,0) + call dcl_proc(parser,'/(fix int,fix int)->fix int',"divide_fold",0,line,0) + call dcl_proc(parser,'**(fix int,fix int)->fix int',"pow_fold",0,line,0) + call dcl_proc(parser,'max(fix int,fix int)->fix int',"max_fold",0,line,0) + call dcl_proc(parser,'min(fix int,fix int)->fix int',"min_fold",0,line,0) + call dcl_proc(parser,'-(fix int)->fix int',"uminus_fold",0,line,0) + call dcl_proc(parser,'string(fix int)->string',"string_fold",0,line,0) + call dcl_proc(parser,'abs(fix int)->fix int',"abs_fold",0,line,0) + call dcl_proc(parser,'~(fix int)->fix int',"bnot_fold",0,line,0) + call dcl_proc(parser,'&(fix int,fix int)->fix int',"band_fold",0,line,0) + call dcl_proc(parser,'|(fix int,fix int)->fix int',"bor_fold",0,line,0) + call dcl_proc(parser,'xor(fix int,fix int)->fix int',"bxor_fold",0,line,0) + call dcl_proc(parser,'shift(fix int,fix int)->fix int',& + "bshift_fold",0,line,0) + call dcl_proc(parser,'pdiff(fix int,fix int)->fix int',"pdiff_fold",0,line,0) + call dcl_proc(parser,'sign(fix int,fix int)->fix int',"sign_fold",0,line,0) + call dcl_proc(parser,'rem(fix int,fix int)->fix int',"modulo_fold",0,line,0) + call dcl_proc(parser,'and(fix bool,fix bool)->fix bool',"and_fold",0,line,0) + call dcl_proc(parser,'or(fix bool,fix bool)->fix bool',"or_fold",0,line,0) + call dcl_proc(parser,'except(fix bool,fix bool)->fix bool',"except_fold",0,line,0) + call dcl_proc(parser,'==(fix bool,fix bool)->fix bool',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(fix bool,fix bool)->fix bool',"ne_fold",0,line,0) + call dcl_proc(parser,'==(fix string,fix string)->fix bool',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(fix string,fix string)->fix bool',"ne_fold",0,line,0) + call dcl_proc(parser,'==(fix real,fix real)->fix bool',"eq_fold",0,line,0) + call dcl_proc(parser,'/=(fix real,fix real)->fix bool',"ne_fold",0,line,0) + call dcl_proc(parser,'++(fix string,fix string)->fix string',"concat_fold",0,line,0) + +write(*,'(a)') '// **************************************' +WRITE(*,'(A)') '// BASIC TYPES' +write(*,'(a)') '// **************************************' + +write(*,'(a)') '// String type' + call dcl_proc(parser,'print(string)',"print",0,line,proc_is_impure) call dcl_uproc(parser,'print(x) { print(string(x)) }',line) - call dcl_proc(parser,'print_all(string)',op_print,1,line,proc_is_impure) + call dcl_proc(parser,'print_all(string)',"print",1,line,proc_is_impure) call dcl_uproc(parser,'print_all(x) { print_all(string(x)) }',line) - call dcl_proc(parser,'++(string,string)->string',op_concat,0,line,0) + call dcl_proc(parser,'++(string,string)->string',"concat",0,line,0) call dcl_uproc(parser,'++(x:string,y)=$++.(x,string(y))',line) call dcl_uproc(parser,'++(x,y)=$++.(string(x),string(y))',line) call dcl_uproc(parser,'string(x:string)=x',line) call dcl_uproc(parser,'string(x:null)="null"',line) + call dcl_uproc(parser,'fmt(x,y)=x:test """fmt"" operator not yet implmented"=>''false',line) - ! sint type +write(*,'(a)') '// sint type' call dcl_proc(parser,'PM__assign_var(&sint,sint)',& - op_assign_i,0,line,0) - call dcl_proc(parser,'mod(sint,sint)->sint',op_mod_i,0,line,0) - call dcl_proc(parser,'==(sint,sint)->bool',op_eq_i,0,line,0) - call dcl_proc(parser,'/=(sint,sint)->bool',op_ne_i,0,line,0) - call dcl_proc(parser,'>=(sint,sint)->bool',op_ge_i,0,line,0) - call dcl_proc(parser,'>(sint,sint)->bool',op_gt_i,0,line,0) - call dcl_proc(parser,'+(sint,sint)->sint',op_add_i,0,line,0) - call dcl_proc(parser,'-(sint,sint)->sint',op_sub_i,0,line,0) - call dcl_proc(parser,'*(sint,sint)->sint',op_mult_i,0,line,0) - call dcl_proc(parser,'/(sint,sint)->sint',op_divide_i,0,line,0) - call dcl_proc(parser,'**(sint,sint)->sint',op_pow_i,0,line,0) - call dcl_proc(parser,'max(sint,sint)->sint',op_max_i,0,line,0) - call dcl_proc(parser,'min(sint,sint)->sint',op_min_i,0,line,0) - call dcl_proc(parser,'-(sint)->sint',op_uminus_i,0,line,0) - call dcl_proc(parser,'string(sint)->string',op_string_i,0,line,0) - call dcl_proc(parser,'int(sint)->int',op_long_i,0,line,0) - call dcl_proc(parser,'sreal(sint)->sreal',op_real_i,0,line,0) - call dcl_proc(parser,'real(sint)->real',op_double_i,0,line,0) + "assign_i",0,line,0) + call dcl_proc(parser,'mod(sint,sint)->sint',"mod_i",0,line,0) + call dcl_proc(parser,'==(sint,sint)->bool',"eq_i",0,line,0) + call dcl_proc(parser,'/=(sint,sint)->bool',"ne_i",0,line,0) + call dcl_proc(parser,'>=(sint,sint)->bool',"ge_i",0,line,0) + call dcl_proc(parser,'>(sint,sint)->bool',"gt_i",0,line,0) + call dcl_proc(parser,'+(sint,sint)->sint',"add_i",0,line,0) + call dcl_proc(parser,'-(sint,sint)->sint',"sub_i",0,line,0) + call dcl_proc(parser,'*(sint,sint)->sint',"mult_i",0,line,0) + call dcl_proc(parser,'/(sint,sint)->sint',"divide_i",0,line,0) + call dcl_proc(parser,'**(sint,sint)->sint',"pow_i",0,line,0) + call dcl_proc(parser,'max(sint,sint)->sint',"max_i",0,line,0) + call dcl_proc(parser,'min(sint,sint)->sint',"min_i",0,line,0) + call dcl_proc(parser,'-(sint)->sint',"uminus_i",0,line,0) + call dcl_proc(parser,'string(sint)->string',"string_i",0,line,0) + call dcl_proc(parser,'int(sint)->int',"long_i",0,line,0) + call dcl_proc(parser,'sreal(sint)->sreal',"real_i",0,line,0) + call dcl_proc(parser,'real(sint)->real',"double_i",0,line,0) call dcl_uproc(parser,'sint(x:sint)=x',line) - call dcl_proc(parser,'abs(sint)->sint',op_abs_i,0,line,0) - call dcl_proc(parser,'bit_not(sint)->sint',op_bnot_i,0,line,0) - call dcl_proc(parser,'&(sint,sint)->sint',op_band_i,0,line,0) - call dcl_proc(parser,'|(sint,sint)->sint',op_bor_i,0,line,0) - call dcl_proc(parser,'xor(sint,sint)->sint',op_bxor_i,0,line,0) - call dcl_proc(parser,'shift(sint,sint)->sint',op_bshift_i,0,line,0) - call dcl_proc(parser,'pdiff(sint,sint)->sint',op_pdiff_i,0,line,0) - call dcl_proc(parser,'sign(sint,sint)->sint',op_sign_i,0,line,0) - call dcl_proc(parser,'rem(sint,sint)->sint',op_modulo_i,0,line,0) - call dcl_proc(parser,'int8(sint)->int8',op_i8_i,0,line,0) - call dcl_proc(parser,'int16(sint)->int16',op_i16_i,0,line,0) - call dcl_proc(parser,'int32(sint)->int32',op_i32_i,0,line,0) - call dcl_proc(parser,'int64(sint)->int64',op_i64_i,0,line,0) - call dcl_proc(parser,'lint(sint)->lint',op_offset_i,0,line,0) - - ! int type + call dcl_proc(parser,'abs(sint)->sint',"abs_i",0,line,0) + call dcl_proc(parser,'bit_not(sint)->sint',"bnot_i",0,line,0) + call dcl_proc(parser,'&(sint,sint)->sint',"band_i",0,line,0) + call dcl_proc(parser,'|(sint,sint)->sint',"bor_i",0,line,0) + call dcl_proc(parser,'xor(sint,sint)->sint',"bxor_i",0,line,0) + call dcl_proc(parser,'shift(sint,sint)->sint',"bshift_i",0,line,0) + call dcl_proc(parser,'pdiff(sint,sint)->sint',"pdiff_i",0,line,0) + call dcl_proc(parser,'sign(sint,sint)->sint',"sign_i",0,line,0) + call dcl_proc(parser,'rem(sint,sint)->sint',"modulo_i",0,line,0) + call dcl_proc(parser,'int8(sint)->int8',"i8_i",0,line,0) + call dcl_proc(parser,'int16(sint)->int16',"i16_i",0,line,0) + call dcl_proc(parser,'int32(sint)->int32',"i32_i",0,line,0) + call dcl_proc(parser,'int64(sint)->int64',"i64_i",0,line,0) + call dcl_proc(parser,'lint(sint)->lint',"offset_i",0,line,0) + +write(*,'(a)') '// int type' call dcl_proc(parser,'PM__assign_var(&int,int)',& - op_assign_ln,0,line,0) - call dcl_proc(parser,'mod(int,int)->''int',op_mod_ln,0,line,0) - call dcl_proc(parser,'==(int,int)->''bool',op_eq_ln,0,line,0) - call dcl_proc(parser,'/=(int,int)->''bool',op_ne_ln,0,line,0) - call dcl_proc(parser,'>=(int,int)->''bool',op_ge_ln,0,line,0) - call dcl_proc(parser,'>(int,int)->''bool',op_gt_ln,0,line,0) - call dcl_proc(parser,'+(int,int)->''int',op_add_ln,0,line,0) - call dcl_uproc(parser,'+(x:int,y:''0)=x',line) - call dcl_uproc(parser,'+(x:''0,y:int)=y',line) - call dcl_proc(parser,'-(int,int)->''int',op_sub_ln,0,line,0) - call dcl_uproc(parser,'-(x:int,y:''0)=x',line) - call dcl_proc(parser,'*(int,int)->''int',op_mult_ln,0,line,0) + "assign_ln",0,line,0) + call dcl_proc(parser,'mod(int,int)->int',"mod_ln",0,line,0) + call dcl_proc(parser,'==(int,int)->bool',"eq_ln",0,line,0) + call dcl_proc(parser,'/=(int,int)->bool',"ne_ln",0,line,0) + call dcl_proc(parser,'>=(int,int)->bool',"ge_ln",0,line,0) + call dcl_proc(parser,'>(int,int)->bool',"gt_ln",0,line,0) + call dcl_proc(parser,'+(int,int)->int',"add_ln",0,line,0) +!!$ call dcl_uproc(parser,'+(x:int,y:''0)=x',line) +!!$ call dcl_uproc(parser,'+(x:''0,y:int)=y',line) + call dcl_proc(parser,'-(int,int)->int',"sub_ln",0,line,0) +!!$ call dcl_uproc(parser,'-(x:int,y:''0)=x',line) + call dcl_proc(parser,'*(int,int)->int',"mult_ln",0,line,0) call dcl_uproc(parser,'*(x:int,y:''1)=x',line) - call dcl_uproc(parser,'*(x:''1,y:int)=y',line) - call dcl_proc(parser,'/(int,int)->''int',op_divide_ln,0,line,0) +!!$ call dcl_uproc(parser,'*(x:''1,y:int)=y',line) + call dcl_proc(parser,'/(int,int)->int',"divide_ln",0,line,0) call dcl_uproc(parser,'/(x:int,y:''1)=x',line) - call dcl_proc(parser,'**(int,int)->''int',op_pow_ln,0,line,0) - call dcl_uproc(parser,'**(x:int,y:''0)=1',line) - call dcl_uproc(parser,'**(x:int,y:''1)=x',line) - call dcl_uproc(parser,'**(x:int,y:''2)=x*x',line) - call dcl_proc(parser,'max(int,int)->''int',op_max_ln,0,line,0) - call dcl_proc(parser,'min(int,int)->''int',op_min_ln,0,line,0) - call dcl_proc(parser,'-(int)->''int',op_uminus_ln,0,line,0) - call dcl_proc(parser,'string(int)->string',op_string_ln,0,line,0) - call dcl_proc(parser,'sint(int)->sint',op_int_ln,0,line,0) - call dcl_proc(parser,'sreal(int)->sreal',op_real_ln,0,line,0) - call dcl_proc(parser,'real(int)->real',op_double_ln,0,line,0) + call dcl_proc(parser,'**(int,int)->int',"pow_ln",0,line,0) +!!$ call dcl_uproc(parser,'**(x:int,y:''0)=1',line) +!!$ call dcl_uproc(parser,'**(x:int,y:''1)=x',line) +!!$ call dcl_uproc(parser,'**(x:int,y:''2)=x*x',line) + call dcl_proc(parser,'max(int,int)->int',"max_ln",0,line,0) + call dcl_proc(parser,'min(int,int)->int',"min_ln",0,line,0) + call dcl_proc(parser,'-(int)->int',"uminus_ln",0,line,0) + call dcl_proc(parser,'string(int)->string',"string_ln",0,line,0) + call dcl_proc(parser,'sint(int)->sint',"int_ln",0,line,0) + call dcl_proc(parser,'sreal(int)->sreal',"real_ln",0,line,0) + call dcl_proc(parser,'real(int)->real',"double_ln",0,line,0) call dcl_uproc(parser,'int(x:int)=x',line) - call dcl_proc(parser,'abs(int)->int',op_abs_ln,0,line,0) - call dcl_proc(parser,'!(int)->int',op_bnot_ln,0,line,0) - call dcl_proc(parser,'&(int,int)->int',op_band_ln,0,line,0) - call dcl_proc(parser,'|(int,int)->int',op_bor_ln,0,line,0) - call dcl_proc(parser,'xor(int,int)->int',op_bxor_ln,0,line,0) + call dcl_proc(parser,'abs(int)->int',"abs_ln",0,line,0) + call dcl_proc(parser,'~(int)->int',"bnot_ln",0,line,0) + call dcl_proc(parser,'&(int,int)->int',"band_ln",0,line,0) + call dcl_proc(parser,'|(int,int)->int',"bor_ln",0,line,0) + call dcl_proc(parser,'xor(int,int)->int',"bxor_ln",0,line,0) call dcl_proc(parser,'shift(int,int)->int',& - op_bshift_ln,0,line,0) - call dcl_proc(parser,'pdiff(int,int)->''int',op_pdiff_ln,0,line,0) - call dcl_proc(parser,'sign(int,int)->''int',op_sign_ln,0,line,0) - call dcl_proc(parser,'rem(int,int)->''int',op_modulo_ln,0,line,0) - call dcl_proc(parser,'int8(int)->int8',op_i8_ln,0,line,0) - call dcl_proc(parser,'int16(int)->int16',op_i16_ln,0,line,0) - call dcl_proc(parser,'int32(int)->int32',op_i32_ln,0,line,0) - call dcl_proc(parser,'int64(int)->int64',op_i64_ln,0,line,0) - call dcl_proc(parser,'lint(int)->lint',op_offset_ln,0,line,0) - - ! lint type + "bshift_ln",0,line,0) + call dcl_proc(parser,'pdiff(int,int)->int',"pdiff_ln",0,line,0) + call dcl_proc(parser,'sign(int,int)->int',"sign_ln",0,line,0) + call dcl_proc(parser,'rem(int,int)->int',"modulo_ln",0,line,0) + call dcl_proc(parser,'int8(int)->int8',"i8_ln",0,line,0) + call dcl_proc(parser,'int16(int)->int16',"i16_ln",0,line,0) + call dcl_proc(parser,'int32(int)->int32',"i32_ln",0,line,0) + call dcl_proc(parser,'int64(int)->int64',"i64_ln",0,line,0) + call dcl_proc(parser,'lint(int)->lint',"offset_ln",0,line,0) + +write(*,'(a)') '// lint type' call dcl_proc(parser,'PM__assign_var(&lint,lint)',& - op_assign_offset,0,line,0) - call dcl_proc(parser,'mod(lint,lint)->lint',op_mod_offset,0,line,0) - call dcl_proc(parser,'==(lint,lint)->bool',op_eq_offset,0,line,0) - call dcl_proc(parser,'/=(lint,lint)->bool',op_ne_offset,0,line,0) - call dcl_proc(parser,'>=(lint,lint)->bool',op_ge_offset,0,line,0) - call dcl_proc(parser,'>(lint,lint)->bool',op_gt_offset,0,line,0) - call dcl_proc(parser,'+(lint,lint)->lint',op_add_offset,0,line,0) + "assign_offset",0,line,0) + call dcl_proc(parser,'mod(lint,lint)->lint',"mod_offset",0,line,0) + call dcl_proc(parser,'==(lint,lint)->bool',"eq_offset",0,line,0) + call dcl_proc(parser,'/=(lint,lint)->bool',"ne_offset",0,line,0) + call dcl_proc(parser,'>=(lint,lint)->bool',"ge_offset",0,line,0) + call dcl_proc(parser,'>(lint,lint)->bool',"gt_offset",0,line,0) + call dcl_proc(parser,'+(lint,lint)->lint',"add_offset",0,line,0) call dcl_uproc(parser,'+(x:lint,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:lint)=y',line) - call dcl_proc(parser,'-(lint,lint)->lint',op_sub_offset,0,line,0) + call dcl_proc(parser,'-(lint,lint)->lint',"sub_offset",0,line,0) call dcl_uproc(parser,'-(x:lint,y:''0)=x',line) - call dcl_proc(parser,'*(lint,lint)->lint',op_mult_offset,0,line,0) + call dcl_proc(parser,'*(lint,lint)->lint',"mult_offset",0,line,0) call dcl_uproc(parser,'*(x:lint,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:lint)=y',line) - call dcl_proc(parser,'/(lint,lint)->lint',op_divide_offset,0,line,0) + call dcl_proc(parser,'/(lint,lint)->lint',"divide_offset",0,line,0) call dcl_uproc(parser,'/(x:lint,y:''1)=x',line) - call dcl_proc(parser,'**(lint,lint)->lint',op_pow_offset,0,line,0) + call dcl_proc(parser,'**(lint,lint)->lint',"pow_offset",0,line,0) call dcl_uproc(parser,'**(x:lint,y:''0)=1',line) call dcl_uproc(parser,'**(x:lint,y:''1)=x',line) call dcl_uproc(parser,'**(x:lint,y:''2)=x*x',line) - call dcl_proc(parser,'max(lint,lint)->lint',op_max_offset,0,line,0) - call dcl_proc(parser,'min(lint,lint)->lint',op_min_offset,0,line,0) - call dcl_proc(parser,'-(lint)->lint',op_uminus_offset,0,line,0) - call dcl_proc(parser,'string(lint)->string',op_string_offset,0,line,0) - call dcl_proc(parser,'sint(lint)->sint',op_int_offset,0,line,0) - call dcl_proc(parser,'sreal(lint)->sreal',op_real_offset,0,line,0) - call dcl_proc(parser,'real(lint)->real',op_double_offset,0,line,0) + call dcl_proc(parser,'max(lint,lint)->lint',"max_offset",0,line,0) + call dcl_proc(parser,'min(lint,lint)->lint',"min_offset",0,line,0) + call dcl_proc(parser,'-(lint)->lint',"uminus_offset",0,line,0) + call dcl_proc(parser,'string(lint)->string',"string_offset",0,line,0) + call dcl_proc(parser,'sint(lint)->sint',"int_offset",0,line,0) + call dcl_proc(parser,'sreal(lint)->sreal',"real_offset",0,line,0) + call dcl_proc(parser,'real(lint)->real',"double_offset",0,line,0) call dcl_uproc(parser,'lint(x:lint)=x',line) - call dcl_proc(parser,'abs(lint)->lint',op_abs_offset,0,line,0) - call dcl_proc(parser,'!(lint)->lint',op_bnot_offset,0,line,0) - call dcl_proc(parser,'&(lint,lint)->lint',op_band_offset,0,line,0) - call dcl_proc(parser,'|(lint,lint)->lint',op_bor_offset,0,line,0) - call dcl_proc(parser,'xor(lint,lint)->lint',op_bxor_offset,0,line,0) + call dcl_proc(parser,'abs(lint)->lint',"abs_offset",0,line,0) + call dcl_proc(parser,'~(lint)->lint',"bnot_offset",0,line,0) + call dcl_proc(parser,'&(lint,lint)->lint',"band_offset",0,line,0) + call dcl_proc(parser,'|(lint,lint)->lint',"bor_offset",0,line,0) + call dcl_proc(parser,'xor(lint,lint)->lint',"bxor_offset",0,line,0) call dcl_proc(parser,'shift(lint,lint)->lint',& - op_bshift_offset,0,line,0) - call dcl_proc(parser,'pdiff(lint,lint)->lint',op_pdiff_offset,0,line,0) - call dcl_proc(parser,'sign(lint,lint)->lint',op_sign_offset,0,line,0) - call dcl_proc(parser,'rem(lint,lint)->lint',op_modulo_offset,0,line,0) - call dcl_proc(parser,'int8(lint)->int8',op_i8_offset,0,line,0) - call dcl_proc(parser,'int16(lint)->int16',op_i16_offset,0,line,0) - call dcl_proc(parser,'int32(lint)->int32',op_i32_offset,0,line,0) - call dcl_proc(parser,'int64(lint)->int64',op_i64_offset,0,line,0) - call dcl_proc(parser,'int(lint)->int',op_long_offset,0,line,0) - - ! int8 type + "bshift_offset",0,line,0) + call dcl_proc(parser,'pdiff(lint,lint)->lint',"pdiff_offset",0,line,0) + call dcl_proc(parser,'sign(lint,lint)->lint',"sign_offset",0,line,0) + call dcl_proc(parser,'rem(lint,lint)->lint',"modulo_offset",0,line,0) + call dcl_proc(parser,'int8(lint)->int8',"i8_offset",0,line,0) + call dcl_proc(parser,'int16(lint)->int16',"i16_offset",0,line,0) + call dcl_proc(parser,'int32(lint)->int32',"i32_offset",0,line,0) + call dcl_proc(parser,'int64(lint)->int64',"i64_offset",0,line,0) + call dcl_proc(parser,'int(lint)->int',"long_offset",0,line,0) + +write(*,'(a)') '// int8 type' call dcl_proc(parser,'PM__assign_var(&int8,int8)',& - op_assign_i8,0,line,0) - call dcl_proc(parser,'mod(int8,int8)->int8',op_mod_i8,0,line,0) - call dcl_proc(parser,'==(int8,int8)->bool',op_eq_i8,0,line,0) - call dcl_proc(parser,'/=(int8,int8)->bool',op_ne_i8,0,line,0) - call dcl_proc(parser,'>=(int8,int8)->bool',op_ge_i8,0,line,0) - call dcl_proc(parser,'>(int8,int8)->bool',op_gt_i8,0,line,0) - call dcl_proc(parser,'+(int8,int8)->int8',op_add_i8,0,line,0) + "assign_i8",0,line,0) + call dcl_proc(parser,'mod(int8,int8)->int8',"mod_i8",0,line,0) + call dcl_proc(parser,'==(int8,int8)->bool',"eq_i8",0,line,0) + call dcl_proc(parser,'/=(int8,int8)->bool',"ne_i8",0,line,0) + call dcl_proc(parser,'>=(int8,int8)->bool',"ge_i8",0,line,0) + call dcl_proc(parser,'>(int8,int8)->bool',"gt_i8",0,line,0) + call dcl_proc(parser,'+(int8,int8)->int8',"add_i8",0,line,0) call dcl_uproc(parser,'+(x:int8,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:int8)=y',line) - call dcl_proc(parser,'-(int8,int8)->int8',op_sub_i8,0,line,0) + call dcl_proc(parser,'-(int8,int8)->int8',"sub_i8",0,line,0) call dcl_uproc(parser,'-(x:int8,y:''0)=x',line) - call dcl_proc(parser,'*(int8,int8)->int8',op_mult_i8,0,line,0) + call dcl_proc(parser,'*(int8,int8)->int8',"mult_i8",0,line,0) call dcl_uproc(parser,'*(x:int8,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:int8)=y',line) - call dcl_proc(parser,'/(int8,int8)->int8',op_divide_i8,0,line,0) + call dcl_proc(parser,'/(int8,int8)->int8',"divide_i8",0,line,0) call dcl_uproc(parser,'/(x:int8,y:''1)=x',line) - call dcl_proc(parser,'**(int8,int8)->int8',op_pow_i8,0,line,0) + call dcl_proc(parser,'**(int8,int8)->int8',"pow_i8",0,line,0) call dcl_uproc(parser,'**(x:int8,y:''0)=1',line) call dcl_uproc(parser,'**(x:int8,y:''1)=x',line) call dcl_uproc(parser,'**(x:int8,y:''2)=x*x',line) - call dcl_proc(parser,'max(int8,int8)->int8',op_max_i8,0,line,0) - call dcl_proc(parser,'min(int8,int8)->int8',op_min_i8,0,line,0) - call dcl_proc(parser,'-(int8)->int8',op_uminus_i8,0,line,0) - call dcl_proc(parser,'sint(int8)->sint',op_int_i8,0,line,0) - call dcl_proc(parser,'sreal(int8)->sreal',op_real_i8,0,line,0) - call dcl_proc(parser,'real(int8)->real',op_double_i8,0,line,0) + call dcl_proc(parser,'max(int8,int8)->int8',"max_i8",0,line,0) + call dcl_proc(parser,'min(int8,int8)->int8',"min_i8",0,line,0) + call dcl_proc(parser,'-(int8)->int8',"uminus_i8",0,line,0) + call dcl_proc(parser,'sint(int8)->sint',"int_i8",0,line,0) + call dcl_proc(parser,'sreal(int8)->sreal',"real_i8",0,line,0) + call dcl_proc(parser,'real(int8)->real',"double_i8",0,line,0) call dcl_uproc(parser,'int8(x:int8)=x',line) - call dcl_proc(parser,'abs(int8)->int8',op_abs_i8,0,line,0) - call dcl_proc(parser,'!(int8)->int8',op_bnot_i8,0,line,0) - call dcl_proc(parser,'&(int8,int8)->int8',op_band_i8,0,line,0) - call dcl_proc(parser,'|(int8,int8)->int8',op_bor_i8,0,line,0) - call dcl_proc(parser,'xor(int8,int8)->int8',op_bxor_i8,0,line,0) + call dcl_proc(parser,'abs(int8)->int8',"abs_i8",0,line,0) + call dcl_proc(parser,'~(int8)->int8',"bnot_i8",0,line,0) + call dcl_proc(parser,'&(int8,int8)->int8',"band_i8",0,line,0) + call dcl_proc(parser,'|(int8,int8)->int8',"bor_i8",0,line,0) + call dcl_proc(parser,'xor(int8,int8)->int8',"bxor_i8",0,line,0) call dcl_proc(parser,'shift(int8,int8)->int8',& - op_bshift_i8,0,line,0) - call dcl_proc(parser,'pdiff(int8,int8)->int8',op_pdiff_i8,0,line,0) - call dcl_proc(parser,'sign(int8,int8)->int8',op_sign_i8,0,line,0) - call dcl_proc(parser,'rem(int8,int8)->int8',op_modulo_i8,0,line,0) - call dcl_proc(parser,'int16(int8)->int16',op_i16_i8,0,line,0) - call dcl_proc(parser,'int32(int8)->int32',op_i32_i8,0,line,0) - call dcl_proc(parser,'int64(int8)->int64',op_i64_i8,0,line,0) - call dcl_proc(parser,'int(int8)->int',op_long_i8,0,line,0) - call dcl_proc(parser,'lint(int8)->lint',op_offset_i8,0,line,0) - - ! int16 type + "bshift_i8",0,line,0) + call dcl_proc(parser,'pdiff(int8,int8)->int8',"pdiff_i8",0,line,0) + call dcl_proc(parser,'sign(int8,int8)->int8',"sign_i8",0,line,0) + call dcl_proc(parser,'rem(int8,int8)->int8',"modulo_i8",0,line,0) + call dcl_proc(parser,'int16(int8)->int16',"i16_i8",0,line,0) + call dcl_proc(parser,'int32(int8)->int32',"i32_i8",0,line,0) + call dcl_proc(parser,'int64(int8)->int64',"i64_i8",0,line,0) + call dcl_proc(parser,'int(int8)->int',"long_i8",0,line,0) + call dcl_proc(parser,'lint(int8)->lint',"offset_i8",0,line,0) + +write(*,'(a)') '// int16 type' call dcl_proc(parser,'PM__assign_var(&int16,int16)',& - op_assign_i16,0,line,0) - call dcl_proc(parser,'mod(int16,int16)->int16',op_mod_i16,0,line,0) - call dcl_proc(parser,'==(int16,int16)->bool',op_eq_i16,0,line,0) - call dcl_proc(parser,'/=(int16,int16)->bool',op_ne_i16,0,line,0) - call dcl_proc(parser,'>=(int16,int16)->bool',op_ge_i16,0,line,0) - call dcl_proc(parser,'>(int16,int16)->bool',op_gt_i16,0,line,0) - call dcl_proc(parser,'+(int16,int16)->int16',op_add_i16,0,line,0) + "assign_i16",0,line,0) + call dcl_proc(parser,'mod(int16,int16)->int16',"mod_i16",0,line,0) + call dcl_proc(parser,'==(int16,int16)->bool',"eq_i16",0,line,0) + call dcl_proc(parser,'/=(int16,int16)->bool',"ne_i16",0,line,0) + call dcl_proc(parser,'>=(int16,int16)->bool',"ge_i16",0,line,0) + call dcl_proc(parser,'>(int16,int16)->bool',"gt_i16",0,line,0) + call dcl_proc(parser,'+(int16,int16)->int16',"add_i16",0,line,0) call dcl_uproc(parser,'+(x:int16,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:int16)=y',line) - call dcl_proc(parser,'-(int16,int16)->int16',op_sub_i16,0,line,0) + call dcl_proc(parser,'-(int16,int16)->int16',"sub_i16",0,line,0) call dcl_uproc(parser,'-(x:int16,y:''0)=x',line) - call dcl_proc(parser,'*(int16,int16)->int16',op_mult_i16,0,line,0) + call dcl_proc(parser,'*(int16,int16)->int16',"mult_i16",0,line,0) call dcl_uproc(parser,'*(x:int16,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:int16)=y',line) - call dcl_proc(parser,'/(int16,int16)->int16',op_divide_i16,0,line,0) + call dcl_proc(parser,'/(int16,int16)->int16',"divide_i16",0,line,0) call dcl_uproc(parser,'/(x:int16,y:''1)=x',line) - call dcl_proc(parser,'**(int16,int16)->int16',op_pow_i16,0,line,0) + call dcl_proc(parser,'**(int16,int16)->int16',"pow_i16",0,line,0) call dcl_uproc(parser,'**(x:int16,y:''0)=1',line) call dcl_uproc(parser,'**(x:int16,y:''1)=x',line) call dcl_uproc(parser,'**(x:int16,y:''2)=x*x',line) - call dcl_proc(parser,'max(int16,int16)->int16',op_max_i16,0,line,0) - call dcl_proc(parser,'min(int16,int16)->int16',op_min_i16,0,line,0) - call dcl_proc(parser,'-(int16)->int16',op_uminus_i16,0,line,0) - call dcl_proc(parser,'sint(int16)->sint',op_int_i16,0,line,0) - call dcl_proc(parser,'sreal(int16)->sreal',op_real_i16,0,line,0) - call dcl_proc(parser,'real(int16)->real',op_double_i16,0,line,0) + call dcl_proc(parser,'max(int16,int16)->int16',"max_i16",0,line,0) + call dcl_proc(parser,'min(int16,int16)->int16',"min_i16",0,line,0) + call dcl_proc(parser,'-(int16)->int16',"uminus_i16",0,line,0) + call dcl_proc(parser,'sint(int16)->sint',"int_i16",0,line,0) + call dcl_proc(parser,'sreal(int16)->sreal',"real_i16",0,line,0) + call dcl_proc(parser,'real(int16)->real',"double_i16",0,line,0) call dcl_uproc(parser,'int16(x:int16)=x',line) - call dcl_proc(parser,'abs(int16)->int16',op_abs_i16,0,line,0) - call dcl_proc(parser,'!(int16)->int16',op_bnot_i16,0,line,0) - call dcl_proc(parser,'&(int16,int16)->int16',op_band_i16,0,line,0) - call dcl_proc(parser,'|(int16,int16)->int16',op_bor_i16,0,line,0) - call dcl_proc(parser,'xor(int16,int16)->int16',op_bxor_i16,0,line,0) + call dcl_proc(parser,'abs(int16)->int16',"abs_i16",0,line,0) + call dcl_proc(parser,'~(int16)->int16',"bnot_i16",0,line,0) + call dcl_proc(parser,'&(int16,int16)->int16',"band_i16",0,line,0) + call dcl_proc(parser,'|(int16,int16)->int16',"bor_i16",0,line,0) + call dcl_proc(parser,'xor(int16,int16)->int16',"bxor_i16",0,line,0) call dcl_proc(parser,'shift(int16,int16)->int16',& - op_bshift_i16,0,line,0) - call dcl_proc(parser,'pdiff(int16,int16)->int16',op_pdiff_i16,0,line,0) - call dcl_proc(parser,'sign(int16,int16)->int16',op_sign_i16,0,line,0) - call dcl_proc(parser,'rem(int16,int16)->int16',op_modulo_i16,0,line,0) - call dcl_proc(parser,'int8(int16)->int16',op_i8_i16,0,line,0) - call dcl_proc(parser,'int32(int16)->int32',op_i32_i16,0,line,0) - call dcl_proc(parser,'int64(int16)->int64',op_i64_i16,0,line,0) - call dcl_proc(parser,'int(int16)->int',op_long_i16,0,line,0) - call dcl_proc(parser,'lint(int16)->lint',op_offset_i16,0,line,0) - - ! int32 type + "bshift_i16",0,line,0) + call dcl_proc(parser,'pdiff(int16,int16)->int16',"pdiff_i16",0,line,0) + call dcl_proc(parser,'sign(int16,int16)->int16',"sign_i16",0,line,0) + call dcl_proc(parser,'rem(int16,int16)->int16',"modulo_i16",0,line,0) + call dcl_proc(parser,'int8(int16)->int16',"i8_i16",0,line,0) + call dcl_proc(parser,'int32(int16)->int32',"i32_i16",0,line,0) + call dcl_proc(parser,'int64(int16)->int64',"i64_i16",0,line,0) + call dcl_proc(parser,'int(int16)->int',"long_i16",0,line,0) + call dcl_proc(parser,'lint(int16)->lint',"offset_i16",0,line,0) + +write(*,'(a)') '// int32 type' call dcl_proc(parser,'PM__assign_var(&int32,int32)',& - op_assign_i32,0,line,0) - call dcl_proc(parser,'mod(int32,int32)->int32',op_mod_i32,0,line,0) - call dcl_proc(parser,'==(int32,int32)->bool',op_eq_i32,0,line,0) - call dcl_proc(parser,'/=(int32,int32)->bool',op_ne_i32,0,line,0) - call dcl_proc(parser,'>=(int32,int32)->bool',op_ge_i32,0,line,0) - call dcl_proc(parser,'>(int32,int32)->bool',op_gt_i32,0,line,0) - call dcl_proc(parser,'+(int32,int32)->int32',op_add_i32,0,line,0) + "assign_i32",0,line,0) + call dcl_proc(parser,'mod(int32,int32)->int32',"mod_i32",0,line,0) + call dcl_proc(parser,'==(int32,int32)->bool',"eq_i32",0,line,0) + call dcl_proc(parser,'/=(int32,int32)->bool',"ne_i32",0,line,0) + call dcl_proc(parser,'>=(int32,int32)->bool',"ge_i32",0,line,0) + call dcl_proc(parser,'>(int32,int32)->bool',"gt_i32",0,line,0) + call dcl_proc(parser,'+(int32,int32)->int32',"add_i32",0,line,0) call dcl_uproc(parser,'+(x:int32,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:int32)=y',line) - call dcl_proc(parser,'-(int32,int32)->int32',op_sub_i32,0,line,0) + call dcl_proc(parser,'-(int32,int32)->int32',"sub_i32",0,line,0) call dcl_uproc(parser,'-(x:int32,y:''0)=x',line) - call dcl_proc(parser,'*(int32,int32)->int32',op_mult_i32,0,line,0) + call dcl_proc(parser,'*(int32,int32)->int32',"mult_i32",0,line,0) call dcl_uproc(parser,'*(x:int32,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:int32)=y',line) - call dcl_proc(parser,'/(int32,int32)->int32',op_divide_i32,0,line,0) + call dcl_proc(parser,'/(int32,int32)->int32',"divide_i32",0,line,0) call dcl_uproc(parser,'/(x:int32,y:''1)=x',line) - call dcl_proc(parser,'**(int32,int32)->int32',op_pow_i32,0,line,0) + call dcl_proc(parser,'**(int32,int32)->int32',"pow_i32",0,line,0) call dcl_uproc(parser,'**(x:int32,y:''0)=1',line) call dcl_uproc(parser,'**(x:int32,y:''1)=x',line) call dcl_uproc(parser,'**(x:int32,y:''2)=x*x',line) - call dcl_proc(parser,'max(int32,int32)->int32',op_max_i32,0,line,0) - call dcl_proc(parser,'min(int32,int32)->int32',op_min_i32,0,line,0) - call dcl_proc(parser,'-(int32)->int32',op_uminus_i32,0,line,0) - call dcl_proc(parser,'sint(int32)->sint',op_int_i32,0,line,0) - call dcl_proc(parser,'sreal(int32)->sreal',op_real_i32,0,line,0) - call dcl_proc(parser,'real(int32)->real',op_double_i32,0,line,0) + call dcl_proc(parser,'max(int32,int32)->int32',"max_i32",0,line,0) + call dcl_proc(parser,'min(int32,int32)->int32',"min_i32",0,line,0) + call dcl_proc(parser,'-(int32)->int32',"uminus_i32",0,line,0) + call dcl_proc(parser,'sint(int32)->sint',"int_i32",0,line,0) + call dcl_proc(parser,'sreal(int32)->sreal',"real_i32",0,line,0) + call dcl_proc(parser,'real(int32)->real',"double_i32",0,line,0) call dcl_uproc(parser,'int32(x:int32)=x',line) - call dcl_proc(parser,'abs(int32)->int32',op_abs_i32,0,line,0) - call dcl_proc(parser,'!(int32)->int32',op_bnot_i32,0,line,0) - call dcl_proc(parser,'&(int32,int32)->int32',op_band_i32,0,line,0) - call dcl_proc(parser,'|(int32,int32)->int32',op_bor_i32,0,line,0) - call dcl_proc(parser,'xor(int32,int32)->int32',op_bxor_i32,0,line,0) + call dcl_proc(parser,'abs(int32)->int32',"abs_i32",0,line,0) + call dcl_proc(parser,'~(int32)->int32',"bnot_i32",0,line,0) + call dcl_proc(parser,'&(int32,int32)->int32',"band_i32",0,line,0) + call dcl_proc(parser,'|(int32,int32)->int32',"bor_i32",0,line,0) + call dcl_proc(parser,'xor(int32,int32)->int32',"bxor_i32",0,line,0) call dcl_proc(parser,'shift(int32,int32)->int32',& - op_bshift_i32,0,line,0) - call dcl_proc(parser,'pdiff(int32,int32)->int32',op_pdiff_i32,0,line,0) - call dcl_proc(parser,'sign(int32,int32)->int32',op_sign_i32,0,line,0) - call dcl_proc(parser,'rem(int32,int32)->int32',op_modulo_i32,0,line,0) - call dcl_proc(parser,'int8(int32)->int32',op_i8_i32,0,line,0) - call dcl_proc(parser,'int16(int32)->int32',op_i16_i32,0,line,0) - call dcl_proc(parser,'int64(int32)->int64',op_i64_i32,0,line,0) - call dcl_proc(parser,'int(int32)->int',op_long_i32,0,line,0) - call dcl_proc(parser,'lint(int32)->lint',op_offset_i32,0,line,0) - - ! int64 type + "bshift_i32",0,line,0) + call dcl_proc(parser,'pdiff(int32,int32)->int32',"pdiff_i32",0,line,0) + call dcl_proc(parser,'sign(int32,int32)->int32',"sign_i32",0,line,0) + call dcl_proc(parser,'rem(int32,int32)->int32',"modulo_i32",0,line,0) + call dcl_proc(parser,'int8(int32)->int32',"i8_i32",0,line,0) + call dcl_proc(parser,'int16(int32)->int32',"i16_i32",0,line,0) + call dcl_proc(parser,'int64(int32)->int64',"i64_i32",0,line,0) + call dcl_proc(parser,'int(int32)->int',"long_i32",0,line,0) + call dcl_proc(parser,'lint(int32)->lint',"offset_i32",0,line,0) + +write(*,'(a)') '// int64 type' call dcl_proc(parser,'PM__assign_var(&int64,int64)',& - op_assign_i64,0,line,0) - call dcl_proc(parser,'mod(int64,int64)->int64',op_mod_i64,0,line,0) - call dcl_proc(parser,'==(int64,int64)->bool',op_eq_i64,0,line,0) - call dcl_proc(parser,'/=(int64,int64)->bool',op_ne_i64,0,line,0) - call dcl_proc(parser,'>=(int64,int64)->bool',op_ge_i64,0,line,0) - call dcl_proc(parser,'>(int64,int64)->bool',op_gt_i64,0,line,0) - call dcl_proc(parser,'+(int64,int64)->int64',op_add_i64,0,line,0) + "assign_i64",0,line,0) + call dcl_proc(parser,'mod(int64,int64)->int64',"mod_i64",0,line,0) + call dcl_proc(parser,'==(int64,int64)->bool',"eq_i64",0,line,0) + call dcl_proc(parser,'/=(int64,int64)->bool',"ne_i64",0,line,0) + call dcl_proc(parser,'>=(int64,int64)->bool',"ge_i64",0,line,0) + call dcl_proc(parser,'>(int64,int64)->bool',"gt_i64",0,line,0) + call dcl_proc(parser,'+(int64,int64)->int64',"add_i64",0,line,0) call dcl_uproc(parser,'+(x:int64,y:''0)=x',line) call dcl_uproc(parser,'+(x:''0,y:int64)=y',line) - call dcl_proc(parser,'-(int64,int64)->int64',op_sub_i64,0,line,0) + call dcl_proc(parser,'-(int64,int64)->int64',"sub_i64",0,line,0) call dcl_uproc(parser,'-(x:int64,y:''0)=x',line) - call dcl_proc(parser,'*(int64,int64)->int64',op_mult_i64,0,line,0) + call dcl_proc(parser,'*(int64,int64)->int64',"mult_i64",0,line,0) call dcl_uproc(parser,'*(x:int64,y:''1)=x',line) call dcl_uproc(parser,'*(x:''1,y:int64)=y',line) - call dcl_proc(parser,'/(int64,int64)->int64',op_divide_i64,0,line,0) + call dcl_proc(parser,'/(int64,int64)->int64',"divide_i64",0,line,0) call dcl_uproc(parser,'/(x:int64,y:''1)=x',line) - call dcl_proc(parser,'**(int64,int64)->int64',op_pow_i64,0,line,0) + call dcl_proc(parser,'**(int64,int64)->int64',"pow_i64",0,line,0) call dcl_uproc(parser,'**(x:int64,y:''0)=1',line) call dcl_uproc(parser,'**(x:int64,y:''1)=x',line) call dcl_uproc(parser,'**(x:int64,y:''2)=x*x',line) - call dcl_proc(parser,'max(int64,int64)->int64',op_max_i64,0,line,0) - call dcl_proc(parser,'min(int64,int64)->int64',op_min_i64,0,line,0) - call dcl_proc(parser,'-(int64)->int64',op_uminus_i64,0,line,0) - call dcl_proc(parser,'string(int64)->string',op_string_i64,0,line,0) - call dcl_proc(parser,'sint(int64)->sint',op_int_i64,0,line,0) - call dcl_proc(parser,'sreal(int64)->sreal',op_real_i64,0,line,0) - call dcl_proc(parser,'real(int64)->real',op_double_i64,0,line,0) + call dcl_proc(parser,'max(int64,int64)->int64',"max_i64",0,line,0) + call dcl_proc(parser,'min(int64,int64)->int64',"min_i64",0,line,0) + call dcl_proc(parser,'-(int64)->int64',"uminus_i64",0,line,0) + call dcl_proc(parser,'string(int64)->string',"string_i64",0,line,0) + call dcl_proc(parser,'sint(int64)->sint',"int_i64",0,line,0) + call dcl_proc(parser,'sreal(int64)->sreal',"real_i64",0,line,0) + call dcl_proc(parser,'real(int64)->real',"double_i64",0,line,0) call dcl_uproc(parser,'int64(x:int64)=x',line) - call dcl_proc(parser,'abs(int64)->int64',op_abs_i64,0,line,0) - call dcl_proc(parser,'!(int64)->int64',op_bnot_i64,0,line,0) - call dcl_proc(parser,'&(int64,int64)->int64',op_band_i64,0,line,0) - call dcl_proc(parser,'|(int64,int64)->int64',op_bor_i64,0,line,0) - call dcl_proc(parser,'xor(int64,int64)->int64',op_bxor_i64,0,line,0) + call dcl_proc(parser,'abs(int64)->int64',"abs_i64",0,line,0) + call dcl_proc(parser,'~(int64)->int64',"bnot_i64",0,line,0) + call dcl_proc(parser,'&(int64,int64)->int64',"band_i64",0,line,0) + call dcl_proc(parser,'|(int64,int64)->int64',"bor_i64",0,line,0) + call dcl_proc(parser,'xor(int64,int64)->int64',"bxor_i64",0,line,0) call dcl_proc(parser,'shift(int64,int64)->int64',& - op_bshift_i64,0,line,0) - call dcl_proc(parser,'pdiff(int64,int64)->int64',op_pdiff_i64,0,line,0) - call dcl_proc(parser,'sign(int64,int64)->int64',op_sign_i64,0,line,0) - call dcl_proc(parser,'rem(int64,int64)->int64',op_modulo_i64,0,line,0) - call dcl_proc(parser,'int8(int64)->int64',op_i8_i64,0,line,0) - call dcl_proc(parser,'int16(int64)->int64',op_i16_i64,0,line,0) - call dcl_proc(parser,'int32(int64)->int64',op_i32_i64,0,line,0) - call dcl_proc(parser,'int(int64)->int',op_long_i64,0,line,0) - call dcl_proc(parser,'lint(int64)->lint',op_offset_i64,0,line,0) - - ! sreal type + "bshift_i64",0,line,0) + call dcl_proc(parser,'pdiff(int64,int64)->int64',"pdiff_i64",0,line,0) + call dcl_proc(parser,'sign(int64,int64)->int64',"sign_i64",0,line,0) + call dcl_proc(parser,'rem(int64,int64)->int64',"modulo_i64",0,line,0) + call dcl_proc(parser,'int8(int64)->int64',"i8_i64",0,line,0) + call dcl_proc(parser,'int16(int64)->int64',"i16_i64",0,line,0) + call dcl_proc(parser,'int32(int64)->int64',"i32_i64",0,line,0) + call dcl_proc(parser,'int(int64)->int',"long_i64",0,line,0) + call dcl_proc(parser,'lint(int64)->lint',"offset_i64",0,line,0) + +write(*,'(a)') '// sreal type' call dcl_proc(parser,'PM__assign_var(&sreal,sreal)',& - op_assign_r,0,line,0) - call dcl_proc(parser,'mod(sreal,sreal)->sreal',op_mod_r,0,line,0) - call dcl_proc(parser,'==(sreal,sreal)->bool',op_eq_r,0,line,0) - call dcl_proc(parser,'/=(sreal,sreal)->bool',op_ne_r,0,line,0) - call dcl_proc(parser,'>=(sreal,sreal)->bool',op_ge_r,0,line,0) - call dcl_proc(parser,'>(sreal,sreal)->bool',op_gt_r,0,line,0) - call dcl_proc(parser,'+(sreal,sreal)->sreal',op_add_r,0,line,0) - call dcl_proc(parser,'-(sreal,sreal)->sreal',op_sub_r,0,line,0) - call dcl_proc(parser,'*(sreal,sreal)->sreal',op_mult_r,0,line,0) - call dcl_proc(parser,'/(sreal,sreal)->sreal',op_divide_r,0,line,0) - call dcl_proc(parser,'**(sreal,sreal)->sreal',op_pow_r,0,line,0) - call dcl_proc(parser,'max(sreal,sreal)->sreal',op_max_r,0,line,0) - call dcl_proc(parser,'min(sreal,sreal)->sreal',op_min_r,0,line,0) - call dcl_proc(parser,'-(sreal)->sreal',op_uminus_r,0,line,0) - call dcl_proc(parser,'string(sreal)->string',op_string_r,0,line,0) - call dcl_proc(parser,'strunc(sreal)->sint',op_int_r,0,line,0) - call dcl_proc(parser,'trunc(sreal)->int',op_long_r,0,line,0) - call dcl_proc(parser,'ltrunc(sreal)->lint',op_offset_r,0,line,0) - call dcl_proc(parser,'real(sreal)->real',op_double_r,0,line,0) + "assign_r",0,line,0) + call dcl_proc(parser,'mod(sreal,sreal)->sreal',"mod_r",0,line,0) + call dcl_proc(parser,'==(sreal,sreal)->bool',"eq_r",0,line,0) + call dcl_proc(parser,'/=(sreal,sreal)->bool',"ne_r",0,line,0) + call dcl_proc(parser,'>=(sreal,sreal)->bool',"ge_r",0,line,0) + call dcl_proc(parser,'>(sreal,sreal)->bool',"gt_r",0,line,0) + call dcl_proc(parser,'+(sreal,sreal)->sreal',"add_r",0,line,0) + call dcl_proc(parser,'-(sreal,sreal)->sreal',"sub_r",0,line,0) + call dcl_proc(parser,'*(sreal,sreal)->sreal',"mult_r",0,line,0) + call dcl_proc(parser,'/(sreal,sreal)->sreal',"divide_r",0,line,0) + call dcl_proc(parser,'**(sreal,sreal)->sreal',"pow_r",0,line,0) + call dcl_proc(parser,'max(sreal,sreal)->sreal',"max_r",0,line,0) + call dcl_proc(parser,'min(sreal,sreal)->sreal',"min_r",0,line,0) + call dcl_proc(parser,'-(sreal)->sreal',"uminus_r",0,line,0) + call dcl_proc(parser,'string(sreal)->string',"string_r",0,line,0) + call dcl_proc(parser,'strunc(sreal)->sint',"int_r",0,line,0) + call dcl_proc(parser,'trunc(sreal)->int',"long_r",0,line,0) + call dcl_proc(parser,'ltrunc(sreal)->lint',"offset_r",0,line,0) + call dcl_proc(parser,'real(sreal)->real',"double_r",0,line,0) call dcl_uproc(parser,'sreal(x:sreal)=x',line) - call dcl_proc(parser,'abs(sreal)->sreal',op_abs_r,0,line,0) - call dcl_proc(parser,'acos(sreal)->sreal',op_acos_r,0,line,0) - call dcl_proc(parser,'asin(sreal)->sreal',op_asin_r,0,line,0) - call dcl_proc(parser,'atan(sreal)->sreal',op_atan_r,0,line,0) - call dcl_proc(parser,'atan2(sreal,sreal)->sreal',op_atan2_r,0,line,0) - call dcl_proc(parser,'cos(sreal)->sreal',op_cos_r,0,line,0) - call dcl_proc(parser,'cosh(sreal)->sreal',op_cosh_r,0,line,0) - call dcl_proc(parser,'exp(sreal)->sreal',op_exp_r,0,line,0) - call dcl_proc(parser,'log(sreal)->sreal',op_log_r,0,line,0) - call dcl_proc(parser,'log10(sreal)->sreal',op_log10_r,0,line,0) - call dcl_proc(parser,'sin(sreal)->sreal',op_sin_r,0,line,0) - call dcl_proc(parser,'sinh(sreal)->sreal',op_sinh_r,0,line,0) - call dcl_proc(parser,'sqrt(sreal)->sreal',op_sqrt_r,0,line,0) - call dcl_proc(parser,'tan(sreal)->sreal',op_tan_r,0,line,0) - call dcl_proc(parser,'tanh(sreal)->sreal',op_tanh_r,0,line,0) - call dcl_proc(parser,'floor(sreal)->sreal',op_floor_r,0,line,0) - call dcl_proc(parser,'ceil(sreal)->sreal',op_ceil_r,0,line,0) - call dcl_proc(parser,'rem(sreal,sreal)->sreal',op_modulo_r,0,line,0) - call dcl_proc(parser,'sign(sreal,sreal)->sreal',op_sign_r,0,line,0) - call dcl_proc(parser,'pdiff(sreal,sreal)->sreal',op_pdiff_r,0,line,0) - call dcl_proc(parser,'lint(sreal)->lint',op_offset_r,0,line,0) - call dcl_proc(parser,'scpx(sreal)->scpx',op_complex_r,0,line,0) - call dcl_proc(parser,'_scpx2(sreal,sreal)->scpx',op_complex2_r,0,line,0) + call dcl_proc(parser,'abs(sreal)->sreal',"abs_r",0,line,0) + call dcl_proc(parser,'acos(sreal)->sreal',"acos_r",0,line,0) + call dcl_proc(parser,'asin(sreal)->sreal',"asin_r",0,line,0) + call dcl_proc(parser,'atan(sreal)->sreal',"atan_r",0,line,0) + call dcl_proc(parser,'atan2(sreal,sreal)->sreal',"atan2_r",0,line,0) + call dcl_proc(parser,'cos(sreal)->sreal',"cos_r",0,line,0) + call dcl_proc(parser,'cosh(sreal)->sreal',"cosh_r",0,line,0) + call dcl_proc(parser,'exp(sreal)->sreal',"exp_r",0,line,0) + call dcl_proc(parser,'log(sreal)->sreal',"log_r",0,line,0) + call dcl_proc(parser,'log10(sreal)->sreal',"log10_r",0,line,0) + call dcl_proc(parser,'sin(sreal)->sreal',"sin_r",0,line,0) + call dcl_proc(parser,'sinh(sreal)->sreal',"sinh_r",0,line,0) + call dcl_proc(parser,'sqrt(sreal)->sreal',"sqrt_r",0,line,0) + call dcl_proc(parser,'tan(sreal)->sreal',"tan_r",0,line,0) + call dcl_proc(parser,'tanh(sreal)->sreal',"tanh_r",0,line,0) + call dcl_proc(parser,'floor(sreal)->sreal',"floor_r",0,line,0) + call dcl_proc(parser,'ceil(sreal)->sreal',"ceil_r",0,line,0) + call dcl_proc(parser,'rem(sreal,sreal)->sreal',"modulo_r",0,line,0) + call dcl_proc(parser,'sign(sreal,sreal)->sreal',"sign_r",0,line,0) + call dcl_proc(parser,'pdiff(sreal,sreal)->sreal',"pdiff_r",0,line,0) + call dcl_proc(parser,'lint(sreal)->lint',"offset_r",0,line,0) + call dcl_proc(parser,'scpx(sreal)->scpx',"complex_r",0,line,0) + call dcl_proc(parser,'_scpx2(sreal,sreal)->scpx',"complex2_r",0,line,0) call dcl_uproc(parser,'scpx(x:any_real,y:any_real)=_scpx2(sreal(x),sreal(y))',line) - ! real type +write(*,'(a)') '// real type' call dcl_proc(parser,'PM__assign_var(&real,real)',& - op_assign_d,0,line,0) - call dcl_proc(parser,'mod(real,real)->real',op_mod_d,0,line,0) - call dcl_proc(parser,'==(real,real)->bool',op_eq_d,0,line,0) - call dcl_proc(parser,'/=(real,real)->bool',op_ne_d,0,line,0) - call dcl_proc(parser,'>=(real,real)->bool',op_ge_d,0,line,0) - call dcl_proc(parser,'>(real,real)->bool',op_gt_d,0,line,0) - call dcl_proc(parser,'+(real,real)->real',op_add_d,0,line,0) - call dcl_proc(parser,'-(real,real)->real',op_sub_d,0,line,0) - call dcl_proc(parser,'*(real,real)->real',op_mult_d,0,line,0) - call dcl_proc(parser,'/(real,real)->real',op_divide_d,0,line,0) - call dcl_proc(parser,'**(real,real)->real',op_pow_d,0,line,0) - call dcl_proc(parser,'max(real,real)->real',op_max_d,0,line,0) - call dcl_proc(parser,'min(real,real)->real',op_min_d,0,line,0) - call dcl_proc(parser,'-(real)->real',op_uminus_d,0,line,0) - call dcl_proc(parser,'string(real)->string',op_string_d,0,line,0) - call dcl_proc(parser,'strunc(real)->sint',op_int_d,0,line,0) - call dcl_proc(parser,'trunc(real)->int',op_long_d,0,line,0) - call dcl_proc(parser,'ltrunc(real)->lint',op_offset_d,0,line,0) - call dcl_proc(parser,'sreal(real)->sreal',op_real_d,0,line,0) + "assign_d",0,line,0) + call dcl_proc(parser,'mod(real,real)->real',"mod_d",0,line,0) + call dcl_proc(parser,'==(real,real)->bool',"eq_d",0,line,0) + call dcl_proc(parser,'/=(real,real)->bool',"ne_d",0,line,0) + call dcl_proc(parser,'>=(real,real)->bool',"ge_d",0,line,0) + call dcl_proc(parser,'>(real,real)->bool',"gt_d",0,line,0) + call dcl_proc(parser,'+(real,real)->real',"add_d",0,line,0) + call dcl_proc(parser,'-(real,real)->real',"sub_d",0,line,0) + call dcl_proc(parser,'*(real,real)->real',"mult_d",0,line,0) + call dcl_proc(parser,'/(real,real)->real',"divide_d",0,line,0) + call dcl_proc(parser,'**(real,real)->real',"pow_d",0,line,0) + call dcl_proc(parser,'max(real,real)->real',"max_d",0,line,0) + call dcl_proc(parser,'min(real,real)->real',"min_d",0,line,0) + call dcl_proc(parser,'-(real)->real',"uminus_d",0,line,0) + call dcl_proc(parser,'string(real)->string',"string_d",0,line,0) + call dcl_proc(parser,'strunc(real)->sint',"int_d",0,line,0) + call dcl_proc(parser,'trunc(real)->int',"long_d",0,line,0) + call dcl_proc(parser,'ltrunc(real)->lint',"offset_d",0,line,0) + call dcl_proc(parser,'sreal(real)->sreal',"real_d",0,line,0) call dcl_uproc(parser,'real(x:real)=x',line) - call dcl_proc(parser,'abs(real)->real',op_abs_d,0,line,0) - call dcl_proc(parser,'acos(real)->real',op_acos_d,0,line,0) - call dcl_proc(parser,'asin(real)->real',op_asin_d,0,line,0) - call dcl_proc(parser,'atan(real)->real',op_atan_d,0,line,0) + call dcl_proc(parser,'abs(real)->real',"abs_d",0,line,0) + call dcl_proc(parser,'acos(real)->real',"acos_d",0,line,0) + call dcl_proc(parser,'asin(real)->real',"asin_d",0,line,0) + call dcl_proc(parser,'atan(real)->real',"atan_d",0,line,0) call dcl_proc(parser,'atan2(real,real)->real',& - op_atan2_d,0,line,0) - call dcl_proc(parser,'cos(real)->real',op_cos_d,0,line,0) - call dcl_proc(parser,'cosh(real)->real',op_cosh_d,0,line,0) - call dcl_proc(parser,'exp(real)->real',op_exp_d,0,line,0) - call dcl_proc(parser,'log(real)->real',op_log_d,0,line,0) - call dcl_proc(parser,'log10(real)->real',op_log10_d,0,line,0) - call dcl_proc(parser,'sin(real)->real',op_sin_d,0,line,0) - call dcl_proc(parser,'sinh(real)->real',op_sinh_d,0,line,0) - call dcl_proc(parser,'sqrt(real)->real',op_sqrt_d,0,line,0) - call dcl_proc(parser,'tan(real)->real',op_tan_d,0,line,0) - call dcl_proc(parser,'tanh(real)->real',op_tanh_d,0,line,0) - call dcl_proc(parser,'floor(real)->real',op_floor_d,0,line,0) - call dcl_proc(parser,'ceil(real)->real',op_ceil_d,0,line,0) - call dcl_proc(parser,'rem(real,real)->real',op_modulo_d,0,line,0) - call dcl_proc(parser,'sign(real,real)->real',op_sign_d,0,line,0) - call dcl_proc(parser,'pdiff(real,real)->real',op_pdiff_d,0,line,0) - call dcl_proc(parser,'lint(real)->lint',op_offset_d,0,line,0) - call dcl_proc(parser,'cpx(real)->cpx',op_complex_d,0,line,0) - call dcl_proc(parser,'_cpx2(real,real)->cpx',op_complex2_d,0,line,0) + "atan2_d",0,line,0) + call dcl_proc(parser,'cos(real)->real',"cos_d",0,line,0) + call dcl_proc(parser,'cosh(real)->real',"cosh_d",0,line,0) + call dcl_proc(parser,'exp(real)->real',"exp_d",0,line,0) + call dcl_proc(parser,'log(real)->real',"log_d",0,line,0) + call dcl_proc(parser,'log10(real)->real',"log10_d",0,line,0) + call dcl_proc(parser,'sin(real)->real',"sin_d",0,line,0) + call dcl_proc(parser,'sinh(real)->real',"sinh_d",0,line,0) + call dcl_proc(parser,'sqrt(real)->real',"sqrt_d",0,line,0) + call dcl_proc(parser,'tan(real)->real',"tan_d",0,line,0) + call dcl_proc(parser,'tanh(real)->real',"tanh_d",0,line,0) + call dcl_proc(parser,'floor(real)->real',"floor_d",0,line,0) + call dcl_proc(parser,'ceil(real)->real',"ceil_d",0,line,0) + call dcl_proc(parser,'rem(real,real)->real',"modulo_d",0,line,0) + call dcl_proc(parser,'sign(real,real)->real',"sign_d",0,line,0) + call dcl_proc(parser,'pdiff(real,real)->real',"pdiff_d",0,line,0) + call dcl_proc(parser,'lint(real)->lint',"offset_d",0,line,0) + call dcl_proc(parser,'cpx(real)->cpx',"complex_d",0,line,0) + call dcl_proc(parser,'_cpx2(real,real)->cpx',"complex2_d",0,line,0) call dcl_uproc(parser,'cpx(x:real_num,y:real_num)=_cpx2(real(x),real(y))',line) - ! scpx type +write(*,'(a)') '// scpx type' call dcl_proc(parser,'PM__assign_var(&scpx,scpx)',& - op_assign_c,0,line,0) - call dcl_proc(parser,'+(scpx,scpx)->scpx',op_add_c,0,line,0) - call dcl_proc(parser,'-(scpx,scpx)->scpx',op_sub_c,0,line,0) - call dcl_proc(parser,'*(scpx,scpx)->scpx',op_mult_c,0,line,0) - call dcl_proc(parser,'/(scpx,scpx)->scpx',op_divide_c,0,line,0) - call dcl_proc(parser,'**(scpx,sreal)->scpx',op_rpow_c,0,line,0) - call dcl_proc(parser,'**(scpx,scpx)->scpx',op_pow_c,0,line,0) - call dcl_proc(parser,'-(scpx)->scpx',op_uminus_c,0,line,0) - call dcl_proc(parser,'==(scpx,scpx)->bool',op_eq_c,0,line,0) - call dcl_proc(parser,'/=(scpx,scpx)->bool',op_ne_c,0,line,0) - call dcl_proc(parser,'re(scpx)->sreal',op_real_c,0,line,0) - call dcl_proc(parser,'abs(scpx)->scpx',op_abs_c,0,line,0) - call dcl_proc(parser,'acos(scpx)->scpx',op_acos_c,0,line,0) - call dcl_proc(parser,'asin(scpx)->scpx',op_asin_c,0,line,0) - call dcl_proc(parser,'atan(scpx)->scpx',op_atan_c,0,line,0) + "assign_c",0,line,0) + call dcl_proc(parser,'+(scpx,scpx)->scpx',"add_c",0,line,0) + call dcl_proc(parser,'-(scpx,scpx)->scpx',"sub_c",0,line,0) + call dcl_proc(parser,'*(scpx,scpx)->scpx',"mult_c",0,line,0) + call dcl_proc(parser,'/(scpx,scpx)->scpx',"divide_c",0,line,0) + call dcl_proc(parser,'**(scpx,sreal)->scpx',"rpow_c",0,line,0) + call dcl_proc(parser,'**(scpx,scpx)->scpx',"pow_c",0,line,0) + call dcl_proc(parser,'-(scpx)->scpx',"uminus_c",0,line,0) + call dcl_proc(parser,'==(scpx,scpx)->bool',"eq_c",0,line,0) + call dcl_proc(parser,'/=(scpx,scpx)->bool',"ne_c",0,line,0) + call dcl_proc(parser,'re(scpx)->sreal',"real_c",0,line,0) + call dcl_proc(parser,'abs(scpx)->scpx',"abs_c",0,line,0) + call dcl_proc(parser,'acos(scpx)->scpx',"acos_c",0,line,0) + call dcl_proc(parser,'asin(scpx)->scpx',"asin_c",0,line,0) + call dcl_proc(parser,'atan(scpx)->scpx',"atan_c",0,line,0) call dcl_proc(parser,'atan2(scpx,scpx)->scpx',& - op_atan2_c,0,line,0) - call dcl_proc(parser,'cos(scpx)->scpx',op_cos_c,0,line,0) - call dcl_proc(parser,'cosh(scpx)->scpx',op_cosh_c,0,line,0) - call dcl_proc(parser,'exp(scpx)->scpx',op_exp_c,0,line,0) - call dcl_proc(parser,'log(scpx)->scpx',op_log_c,0,line,0) - call dcl_proc(parser,'sin(scpx)->scpx',op_sin_c,0,line,0) - call dcl_proc(parser,'sinh(scpx)->scpx',op_sinh_c,0,line,0) - call dcl_proc(parser,'sqrt(scpx)->scpx',op_sqrt_c,0,line,0) - call dcl_proc(parser,'tan(scpx)->scpx',op_tan_c,0,line,0) - call dcl_proc(parser,'tanh(scpx)->scpx',op_tanh_c,0,line,0) - call dcl_proc(parser,'im(scpx)->sreal',op_imag_c,0,line,0) - call dcl_proc(parser,'conj(scpx)->scpx',op_conj_c,0,line,0) - - ! cpx type + "atan2_c",0,line,0) + call dcl_proc(parser,'cos(scpx)->scpx',"cos_c",0,line,0) + call dcl_proc(parser,'cosh(scpx)->scpx',"cosh_c",0,line,0) + call dcl_proc(parser,'exp(scpx)->scpx',"exp_c",0,line,0) + call dcl_proc(parser,'log(scpx)->scpx',"log_c",0,line,0) + call dcl_proc(parser,'sin(scpx)->scpx',"sin_c",0,line,0) + call dcl_proc(parser,'sinh(scpx)->scpx',"sinh_c",0,line,0) + call dcl_proc(parser,'sqrt(scpx)->scpx',"sqrt_c",0,line,0) + call dcl_proc(parser,'tan(scpx)->scpx',"tan_c",0,line,0) + call dcl_proc(parser,'tanh(scpx)->scpx',"tanh_c",0,line,0) + call dcl_proc(parser,'im(scpx)->sreal',"imag_c",0,line,0) + call dcl_proc(parser,'conj(scpx)->scpx',"conj_c",0,line,0) + +write(*,'(a)') '// cpx type' call dcl_proc(parser,'PM__assign_var(&cpx,cpx)',& - op_assign_dc,0,line,0) - call dcl_proc(parser,'+(cpx,cpx)->cpx',op_add_dc,0,line,0) - call dcl_proc(parser,'-(cpx,cpx)->cpx',op_sub_dc,0,line,0) - call dcl_proc(parser,'*(cpx,cpx)->cpx',op_mult_dc,0,line,0) - call dcl_proc(parser,'/(cpx,cpx)->cpx',op_divide_dc,0,line,0) - call dcl_proc(parser,'**(cpx,real)->cpx',op_dpow_dc,0,line,0) + "assign_dc",0,line,0) + call dcl_proc(parser,'+(cpx,cpx)->cpx',"add_dc",0,line,0) + call dcl_proc(parser,'-(cpx,cpx)->cpx',"sub_dc",0,line,0) + call dcl_proc(parser,'*(cpx,cpx)->cpx',"mult_dc",0,line,0) + call dcl_proc(parser,'/(cpx,cpx)->cpx',"divide_dc",0,line,0) + call dcl_proc(parser,'**(cpx,real)->cpx',"dpow_dc",0,line,0) call dcl_uproc(parser,'**(x:cpx,y:sreal)=x**real(y)',line) - call dcl_proc(parser,'**(cpx,cpx)->cpx',op_pow_dc,0,line,0) - call dcl_proc(parser,'-(cpx)->cpx',op_uminus_dc,0,line,0) - call dcl_proc(parser,'==(cpx,cpx)->bool',op_eq_dc,0,line,0) - call dcl_proc(parser,'/=(cpx,cpx)->bool',op_ne_dc,0,line,0) - call dcl_proc(parser,'re(cpx)->real',op_real_dc,0,line,0) - call dcl_proc(parser,'abs(cpx)->cpx',op_abs_dc,0,line,0) - call dcl_proc(parser,'acos(cpx)->cpx',op_acos_dc,0,line,0) - call dcl_proc(parser,'asin(cpx)->cpx',op_asin_dc,0,line,0) - call dcl_proc(parser,'atan(cpx)->cpx',op_atan_dc,0,line,0) + call dcl_proc(parser,'**(cpx,cpx)->cpx',"pow_dc",0,line,0) + call dcl_proc(parser,'-(cpx)->cpx',"uminus_dc",0,line,0) + call dcl_proc(parser,'==(cpx,cpx)->bool',"eq_dc",0,line,0) + call dcl_proc(parser,'/=(cpx,cpx)->bool',"ne_dc",0,line,0) + call dcl_proc(parser,'re(cpx)->real',"real_dc",0,line,0) + call dcl_proc(parser,'abs(cpx)->cpx',"abs_dc",0,line,0) + call dcl_proc(parser,'acos(cpx)->cpx',"acos_dc",0,line,0) + call dcl_proc(parser,'asin(cpx)->cpx',"asin_dc",0,line,0) + call dcl_proc(parser,'atan(cpx)->cpx',"atan_dc",0,line,0) call dcl_proc(parser,'atan2(cpx,cpx)->cpx',& - op_atan2_dc,0,line,0) - call dcl_proc(parser,'cos(cpx)->cpx',op_cos_dc,0,line,0) - call dcl_proc(parser,'cosh(cpx)->cpx',op_cosh_dc,0,line,0) - call dcl_proc(parser,'exp(cpx)->cpx',op_exp_dc,0,line,0) - call dcl_proc(parser,'log(cpx)->cpx',op_log_dc,0,line,0) - call dcl_proc(parser,'sin(cpx)->cpx',op_sin_dc,0,line,0) - call dcl_proc(parser,'sinh(cpx)->cpx',op_sinh_dc,0,line,0) - call dcl_proc(parser,'sqrt(cpx)->cpx',op_sqrt_dc,0,line,0) - call dcl_proc(parser,'tan(cpx)->cpx',op_tan_dc,0,line,0) - call dcl_proc(parser,'tanh(cpx)->cpx',op_tanh_dc,0,line,0) - call dcl_proc(parser,'im(cpx)->real',op_imag_dc,0,line,0) - call dcl_proc(parser,'conj(cpx)->cpx',op_conj_dc,0,line,0) - - ! Cannot convert real to int (must use nint or trunc) + "atan2_dc",0,line,0) + call dcl_proc(parser,'cos(cpx)->cpx',"cos_dc",0,line,0) + call dcl_proc(parser,'cosh(cpx)->cpx',"cosh_dc",0,line,0) + call dcl_proc(parser,'exp(cpx)->cpx',"exp_dc",0,line,0) + call dcl_proc(parser,'log(cpx)->cpx',"log_dc",0,line,0) + call dcl_proc(parser,'sin(cpx)->cpx',"sin_dc",0,line,0) + call dcl_proc(parser,'sinh(cpx)->cpx',"sinh_dc",0,line,0) + call dcl_proc(parser,'sqrt(cpx)->cpx',"sqrt_dc",0,line,0) + call dcl_proc(parser,'tan(cpx)->cpx',"tan_dc",0,line,0) + call dcl_proc(parser,'tanh(cpx)->cpx',"tanh_dc",0,line,0) + call dcl_proc(parser,'im(cpx)->real',"imag_dc",0,line,0) + call dcl_proc(parser,'conj(cpx)->cpx',"conj_dc",0,line,0) + +write(*,'(a)') '// Cannot convert real to int (must use nint or trunc)' call dcl_uproc(parser,& 'sint(x:any_real)=sint(0) :test "Cannot convert real to integer" => ''false',line) call dcl_uproc(parser,& @@ -562,15 +591,16 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& 'lint(x:any_real)=lint(0) :test "Cannot convert real to integer" => ''false',line) - ! Some numeric conversions not hard-coded +write(*,'(a)') '// Some numeric conversions not hard-coded' call dcl_uproc(parser,'cpx(x:real_num)=cpx(real(x))',line) call dcl_uproc(parser,'scpx(x:real_num)=cpx(sreal(x))',line) call dcl_uproc(parser,'string(x:any_int)=string(int64(x))',line) call dcl_uproc(parser,& - 'string(x:any_cpx)=string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x)',line) + 'string(x:any_cpx)='//& + ' string(re(x))++if(im>=0=>"+"++string(im),"-"++string(-im))++"i" where im=im(x)',line) call dcl_uproc(parser,'int(x:fix int)=x',line) - ! Abstract numeric types +write(*,'(a)') '// Abstract numeric types' call dcl_type(parser,'any_int is sint,int,lint,int8,int16,int32,int64',& line) call dcl_type(parser,'any_real is sreal,real',line) @@ -580,7 +610,7 @@ subroutine sysdefs(parser) call dcl_type(parser,'cpx_num is real_num,any_cpx',line) call dcl_type(parser,'num is cpx_num',line) - ! Numeric type conversion +write(*,'(a)') '// Numeric type conversion' call dcl_uproc(parser,'convert(x,y)=x',line) call dcl_uproc(parser,'convert(x:int_num,y:sint)=sint(x)',line) call dcl_uproc(parser,'convert(x:int_num,y:int)=int(x)',line) @@ -606,11 +636,11 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'as(x:real_num,y:)=scpx(x)',line) call dcl_uproc(parser,'as(x:real_num,y:)=cpx(x)',line) - ! Auto-conversion on assignment +write(*,'(a)') '// Auto-conversion on assignment' call dcl_uproc(parser,'PM__assign(&x:num,y:num) {_assign_element(&x,convert(y,x))}',line) call dcl_uproc(parser,'PM__assign_var(&x:num,y:num) {PM__assign(&x,convert(y,x))}',line) - ! Mixed arithmatic +write(*,'(a)') '// Mixed arithmatic' call dcl_type(parser,'_to_sint is int',line) call dcl_type(parser,'_to_lint is sint,int',line) call dcl_type(parser,'_to_int8 is sint,int,lint',line) @@ -656,6 +686,13 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'balance(x:_to_scpx,y:scpx)=scpx(x),y',line) call dcl_uproc(parser,'balance(x:_to_cpx,y:cpx)=cpx(x),y',line) + call dcl_uproc(parser,& + 'div(x:any_int,y:any_int)=if(sz=>r,-1-r)'//& + 'where r=if(sz=>x,abs(x)-1)/if(sz=>y,abs(y))'//& + 'where sz=sign(x,y)==x',line) + call dcl_uproc(parser,& + '_divz(x:any_int,y:any_int)=z '//& + '{var z,_=balance(x,y);if(sign(x,y)==x):z=x/y else: z=-1-(abs(x)-1)/abs(y)}',line) call dcl_uproc(parser,& 'mod(x:real_num,y:real_num)=xx mod yy where xx,yy=balance(x,y)',line) call dcl_uproc(parser,& @@ -676,54 +713,62 @@ subroutine sysdefs(parser) '/(x:num,y:num)=xx/yy where xx,yy=balance(x,y)',line) call dcl_uproc(parser,& '**(x:num,y:num)=xx**yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '&(x:num,y:num)=xx&yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + '|(x:num,y:num)=xx|yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + 'xor(x:num,y:num)=xx xor yy where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,& + 'shift(x:num,y:num)=xx shift yy where xx,yy=balance(x,y)',line) call dcl_uproc(parser,& 'max(x:num,y:num)=max(xx,yy) where xx,yy=balance(x,y)',line) call dcl_uproc(parser,& 'min(x:num,y:num)=min(xx,yy) where xx,yy=balance(x,y)',line) - ! bool type +write(*,'(a)') '// bool type' call dcl_proc(parser,'PM__assign_var(&bool,bool)',& - op_assign_l,0,line,0) - call dcl_proc(parser,'string(bool)->string',op_string_l,0,line,0) - call dcl_proc(parser,'and(bool,bool)->bool',op_and,0,line,0) - call dcl_proc(parser,'or(bool,bool)->bool',op_or,0,line,0) - call dcl_proc(parser,'not(bool)->bool',op_not,0,line,0) - call dcl_proc(parser,'==(bool,bool)->bool',op_eq_l,0,line,0) - call dcl_proc(parser,'/=(bool,bool)->bool',op_ne_l,0,line,0) - - ! Compile time bool values - call dcl_uproc(parser,'and(x:''false,y:''false)=''false',line) - call dcl_uproc(parser,'and(x:''true,y:''false)=''false',line) - call dcl_uproc(parser,'and(x:''false,y:''true)=''false',line) - call dcl_uproc(parser,'and(x:''true,y:''true)=''true',line) - call dcl_uproc(parser,'and(x:''true,y:bool)=y',line) - call dcl_uproc(parser,'and(x:''false,y:bool)=''false',line) - call dcl_uproc(parser,'and(x:bool,y:''true)=x',line) - call dcl_uproc(parser,'and(x:bool,y:''false)=''false',line) - call dcl_uproc(parser,'or(x:''false,y:''false)=''false',line) - call dcl_uproc(parser,'or(x:''true,y:''false)=''true',line) - call dcl_uproc(parser,'or(x:''false,y:''true)=''true',line) - call dcl_uproc(parser,'or(x:''true,y:''true)=''true',line) - call dcl_uproc(parser,'or(x:''true,y:bool)=''true',line) - call dcl_uproc(parser,'or(x:''false,y:bool)=y',line) - call dcl_uproc(parser,'or(x:bool,y:''true)=''true',line) - call dcl_uproc(parser,'or(x:bool,y:''false)=x',line) - call dcl_uproc(parser,'not(x:''true)=''false',line) - call dcl_uproc(parser,'not(x:''false)=''true',line) - call dcl_uproc(parser,'==(x:''false,y:''false)=''true',line) - call dcl_uproc(parser,'==(x:''true,y:''false)=''false',line) - call dcl_uproc(parser,'==(x:''false,y:''true)=''false',line) - call dcl_uproc(parser,'==(x:''true,y:''true)=''true',line) - call dcl_uproc(parser,'==(x:bool,y:''true)=x',line) - call dcl_uproc(parser,'==(x:''true,y:bool)=y',line) - call dcl_uproc(parser,'/=(x:''false,y:''false)=''false',line) - call dcl_uproc(parser,'/=(x:''true,y:''false)=''true',line) - call dcl_uproc(parser,'/=(x:''false,y:''true)=''true',line) - call dcl_uproc(parser,'/=(x:''true,y:''true)=''false',line) - call dcl_uproc(parser,'/=(x:bool,y:''false)=x',line) - call dcl_uproc(parser,'/=(x:''false,y:bool)=y',line) - - ! Masked types + "assign_l",0,line,0) + call dcl_proc(parser,'string(bool)->string',"string_l",0,line,0) + call dcl_proc(parser,'and(bool,bool)->bool',"and",0,line,0) + call dcl_proc(parser,'or(bool,bool)->bool',"or",0,line,0) + call dcl_proc(parser,'not(bool)->bool',"not",0,line,0) + call dcl_proc(parser,'==(bool,bool)->bool',"eq_l",0,line,0) + call dcl_proc(parser,'/=(bool,bool)->bool',"ne_l",0,line,0) + +!!$ ! Compile time bool values +!!$ call dcl_uproc(parser,'and(x:''false,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'and(x:''true,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'and(x:''false,y:''true)=''false',line) +!!$ call dcl_uproc(parser,'and(x:''true,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'and(x:''true,y:bool)=y',line) +!!$ call dcl_uproc(parser,'and(x:''false,y:bool)=''false',line) +!!$ call dcl_uproc(parser,'and(x:bool,y:''true)=x',line) +!!$ call dcl_uproc(parser,'and(x:bool,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'or(x:''false,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'or(x:''true,y:''false)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''false,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''true,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''true,y:bool)=''true',line) +!!$ call dcl_uproc(parser,'or(x:''false,y:bool)=y',line) +!!$ call dcl_uproc(parser,'or(x:bool,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'or(x:bool,y:''false)=x',line) +!!$ call dcl_uproc(parser,'not(x:''true)=''false',line) +!!$ call dcl_uproc(parser,'not(x:''false)=''true',line) +!!$ call dcl_uproc(parser,'==(x:''false,y:''false)=''true',line) +!!$ call dcl_uproc(parser,'==(x:''true,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'==(x:''false,y:''true)=''false',line) +!!$ call dcl_uproc(parser,'==(x:''true,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'==(x:bool,y:''true)=x',line) +!!$ call dcl_uproc(parser,'==(x:''true,y:bool)=y',line) +!!$ call dcl_uproc(parser,'/=(x:''false,y:''false)=''false',line) +!!$ call dcl_uproc(parser,'/=(x:''true,y:''false)=''true',line) +!!$ call dcl_uproc(parser,'/=(x:''false,y:''true)=''true',line) +!!$ call dcl_uproc(parser,'/=(x:''true,y:''true)=''false',line) +!!$ call dcl_uproc(parser,'/=(x:bool,y:''false)=x',line) +!!$ call dcl_uproc(parser,'/=(x:''false,y:bool)=y',line) + +write(*,'(a)') '// Masked types' call dcl_type(parser,'masked(x) is '//& 'rec {_val:x,_there:bool}',line) call dcl_uproc(parser,'|(x:masked,y)=if(x._there=>x._val,y)'//& @@ -737,24 +782,24 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& 'get(&x,y:masked(x)) {if y._there{x=y._val};return y._there}',line) - ! Polymorphic types - call dcl_proc(parser,'get(x:*any,y:any)->=y',op_as,0,line,0) - call dcl_proc(parser,'get(&x:any,y:*any)',op_get_poly,0,line,& +write(*,'(a)') '// Polymorphic types' + call dcl_proc(parser,'get(x:*any,y:any)->=y',"as",0,line,0) + call dcl_proc(parser,'get(&x:any,y:*any)',"get_poly",0,line,& proc_needs_type) - call dcl_proc(parser,'get(&x:any,y:*any)->bool',op_get_poly2,0,line,& + call dcl_proc(parser,'get(&x:any,y:*any)->bool',"get_poly2",0,line,& proc_needs_type) - call dcl_proc(parser,'|(x:*any,y:any)->=y',op_get_poly_or,0,line,& + call dcl_proc(parser,'|(x:*any,y:any)->=y',"get_poly_or",0,line,& proc_needs_type) - ! val function having null effect +write(*,'(a)') '// val function having null effect' call dcl_uproc(parser,'val(x)=x',line) - ! ******************************************** - ! TUPLES - ! ******************************************** +write(*,'(a)') '// ********************************************' +WRITE(*,'(A)') '// TUPLES' +write(*,'(a)') '// ********************************************' - ! Tuple types +write(*,'(a)') '// Tuple types' call dcl_type(parser,& 'tuple1d(t1) is rec {PM__d1:t1}',line) call dcl_type(parser,& @@ -841,13 +886,13 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'indices(x:tuple6d)=[''1,''2,''3,''4,''5,''6]',line) call dcl_uproc(parser,'indices(x:tuple7d)=[''1,''2,''3,''4,''5,''6,''7]',line) - call dcl_uproc(parser,'full_rank(x:tuple1d)=''1',line) - call dcl_uproc(parser,'full_rank(x:tuple2d)=''2',line) - call dcl_uproc(parser,'full_rank(x:tuple3d)=''3',line) - call dcl_uproc(parser,'full_rank(x:tuple4d)=''4',line) - call dcl_uproc(parser,'full_rank(x:tuple5d)=''5',line) - call dcl_uproc(parser,'full_rank(x:tuple6d)=''6',line) - call dcl_uproc(parser,'full_rank(x:tuple7d)=''7',line) + call dcl_uproc(parser,'full_rank(x:tuple1d)=1',line) + call dcl_uproc(parser,'full_rank(x:tuple2d)=2',line) + call dcl_uproc(parser,'full_rank(x:tuple3d)=3',line) + call dcl_uproc(parser,'full_rank(x:tuple4d)=4',line) + call dcl_uproc(parser,'full_rank(x:tuple5d)=5',line) + call dcl_uproc(parser,'full_rank(x:tuple6d)=6',line) + call dcl_uproc(parser,'full_rank(x:tuple7d)=7',line) call dcl_uproc(parser,'rank(x:tuple)=full_rank(x)',line) @@ -923,6 +968,28 @@ subroutine sysdefs(parser) 'p.(x.4,y.4,z.4),p.(x.5,y.5,z.5),p.(x.6,y.6,z.6),'//& 'p.(x.7,y.7,z.7)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple,x:tuple,y:tuple,z:tuple)=error_type()'//& + ' :test "Number of dimensions does not match" => ''false',line) + call dcl_uproc(parser,'map(p:proc,w:tuple1d,x:tuple1d,y:tuple1d,z:tuple1d)='//& + '[p.(w.1,x.1,y.1,z.1)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple2d,x:tuple2d,y:tuple2d,z:tuple2d)='//& + '[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple3d,x:tuple3d,y:tuple3d,z:tuple3d)='//& + '[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple4d,x:tuple4d,y:tuple4d,z:tuple4d)='//& + '[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),'//& + 'p.(w.4,x.4,y.4,z.4)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple5d,x:tuple5d,y:tuple5d,z:tuple5d)='//& + '[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),'//& + 'p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple6d,x:tuple6d,y:tuple6d,z:tuple6d)='//& + '[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),'//& + 'p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6)]',line) + call dcl_uproc(parser,'map(p:proc,w:tuple7d,x:tuple7d,y:tuple7d,z:tuple7d)='//& + '[p.(w.1,x.1,y.1,z.1),p.(w.2,x.2,y.2,z.2),p.(w.3,x.3,y.3,z.3),'//& + 'p.(w.4,x.4,y.4,z.4),p.(w.5,x.5,y.5,z.5),p.(w.6,x.6,y.6,z.6),'//& + 'p.(w.7,x.7,y.7,z.7)]',line) + call dcl_uproc(parser,'map(p:proc,x:tuple1d,y:tuple1d)=[u1],[v1]'//& 'where u1,v1=p.(x.1,y.1)',line) call dcl_uproc(parser,'map(p:proc,x:tuple2d,y:tuple2d)=[u1,u2],[v1,v2]'//& @@ -1238,18 +1305,24 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'string(x:tuple7d)="[ "++x.1++", "++x.2++", "++x.3++", "++x.4++", "++x.5++'//& '", "++x.6++", "++x.7++" ]"',line) - ! ***************************************************** - ! RANGES AND SEQUENCES - ! ***************************************************** +write(*,'(a)') '// *****************************************************' +WRITE(*,'(A)') '// RANGES AND SEQUENCES' +write(*,'(a)') '// *****************************************************' + +write(*,'(a)') '// Not in operator' + call dcl_uproc(parser,'notin(x,y)=not(x in y)',line) - ! Treat null as empty sequence in some cases +write(*,'(a)') '// not inc operator' + call dcl_uproc(parser,'notinc(x,y)=not(x inc y)',line) + +write(*,'(a)') '// Treat null as empty sequence in some cases' call dcl_uproc(parser,'in(x,y:null)=''false',line) call dcl_uproc(parser,'in(x:null,y:null)=''true',line) - ! Range base type (might later expand to interface) +write(*,'(a)') '// Range base type (might later expand to interface)' call dcl_type(parser,'range_base is real_num',line) - ! Single point sequence +write(*,'(a)') '// Single point sequence' call dcl_type(parser,'single_point(t:range_base) is rec {_t:t}',line) call dcl_uproc(parser,'single_point(x)=new single_point {_t=x}',line) call dcl_uproc(parser,'low(x:single_point)=x._t',line) @@ -1263,11 +1336,10 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'size(x:single_point)=''1',line) call dcl_uproc(parser,'+(x:single_point,y:range_base)=new single_point {_t=x._t+y}',line) call dcl_uproc(parser,'-(x:single_point,y:range_base)=new single_point {_t=x._t-y}',line) - call dcl_uproc(parser,'*(x:single_point,y:range_base)=new single_point {_t=x._t*y}',line) call dcl_uproc(parser,'_arb(x:single_point)=x._t',line) call dcl_uproc(parser,'in(x:range_base,y:single_point)=x==y._t',line) call dcl_uproc(parser,' inc(x:single_point,y:seq)=low(y)==x._t and high(y)==x._t',line) - !call dcl_uproc(parser,' inc(x:seq,y:single_point)=y._t in x',line) +!write(*,'(a)') '// call dcl_uproc(parser,' inc(x:seq,y:single_point)=y._t in x',line)' call dcl_uproc(parser,'convert(x:single_point,y:range_base)=single_point(convert(x._t,y))',line) call dcl_uproc(parser,'sint(x:single_point)=single_point(sint(x._t))',line) call dcl_uproc(parser,'int(x:single_point)=single_point(int(x._t))',line) @@ -1276,38 +1348,40 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'#(x:single_point,y:index)=''0',line) call dcl_uproc(parser,'#(x:single_point,y:grid_slice_dim)=''0..''0',line) call dcl_uproc(parser,'#(x:single_point,y:single_point)=''0..''0',line) - call dcl_uproc(parser,'#(x:grid_slice_dim,y:single_point)=xx..xx where xx=x#y._t',line) + call dcl_uproc(parser,'#(x:grid_slice_dim,y:single_point)=single_point(xx) where xx=x#y._t',line) call dcl_uproc(parser,'overlap(x:single_point(any_int),y:single_point(any_int))=0..if(x._t==y._t=>0,-1)',line) call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:single_point(any_int))=if(y._t in x=>x#y._t..x#y._t,0..-1)',line) call dcl_uproc(parser,'overlap(x:single_point(any_int),y:grid_slice_dim)=0..if(x._t in y=>0,-1)',line) + call dcl_uproc(parser,'overlap(x:single_point(any_int),y:single_point(any_int))=overlap(x,y),overlap(y,x)',line) + call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:single_point(any_int))=overlap(x,y),overlap(y,x)',line) + call dcl_uproc(parser,'overlap(x:single_point(any_int),y:grid_slice_dim)=overlap(x,y),overlap(y,x)',line) call dcl_uproc(parser,'intersect(x:single_point(any_int),y:grid_slice_dim)=x._t..if(x._t in y=>x._t,x._t-1)',line) call dcl_uproc(parser,'intersect(y:grid_slice_dim,x:single_point(any_int))=x._t..if(x._t in y=>x._t,x._t-1)',line) call dcl_uproc(parser,'intersect(x:single_point(any_int),y:single_point(any_int))='//& 'x._t..if(x._t==y._t=>x._t,x._t-1)',line) - call dcl_uproc(parser,'_get_elem(x:single_point,y:index)=x._t',line) - call dcl_uproc(parser,'_get_elem(x:single_point,y:subs)=x._t..x._t',line) - call dcl_uproc(parser,'string(x:single_point)=string(x._t)',line) + call dcl_uproc(parser,'element(x:single_point,y:index)=x._t',line) + call dcl_uproc(parser,'element(x:single_point,y:subs)=x._t..x._t',line) + call dcl_uproc(parser,'element(x,y:single_point)=element(x,y._t)',line) + call dcl_uproc(parser,'string(x:single_point)=string("single "++x._t)',line) - ! Range types +write(*,'(a)') '// Range types' call dcl_type(parser,'range(t:range_base) is rec {_lo:t,_hi:t,_n:t}',line) call dcl_uproc(parser,'..(x:range_base,y:range_base)='//& 'new range {_lo=xx,_hi=yy,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y)',line) - call dcl_uproc(parser,'..(x:fix int,y:fix int)='//& - 'new range {_lo=x,_hi=y,_n=max(''0,y-x+''1)}',line) +!!$ call dcl_uproc(parser,'..(x:fix int,y:fix int)='//& +!!$ 'new range {_lo=x,_hi=y,_n=max(''0,y-x+''1)}',line) call dcl_uproc(parser,'low(x:range)=x._lo',line) call dcl_uproc(parser,'high(x:range)=x._hi',line) call dcl_uproc(parser,'step(x:range)=convert(1,x._lo)',line) call dcl_uproc(parser,'width(x:range)=''1',line) call dcl_uproc(parser,'norm(x:range)=x',line) call dcl_uproc(parser,'#(x:range(int))=shape([0..x._n-1])',line) - call dcl_uproc(parser,'_shp(x:range(int))=0..x._n-1',line) call dcl_uproc(parser,'dims(x:range(int))=[x._n]',line) call dcl_uproc(parser,& 'size(x:range(int))=x._n',line) call dcl_uproc(parser,'+(x:range,y:range_base)=new range {_lo=x._lo+y,_hi=x._hi+y,_n=x._n}',line) call dcl_uproc(parser,'-(x:range,y:range_base)=new range {_lo=x._lo-y,_hi=x._hi-y,_n=x._n}',line) -!!$ call dcl_uproc(parser,'*(x:range,y:range_base)=new range {_lo=x._lo*y,_hi=x._hi*y,_n=x._n}',line) call dcl_uproc(parser,& '_arb(x:range)=low(x)',line) call dcl_uproc(parser,& @@ -1326,70 +1400,68 @@ subroutine sysdefs(parser) ' inc(x:range,y:seq())='//& ' low(y)>=x._lo and high(y)<=x._hi',line) call dcl_uproc(parser,& - '_get_elem(x:range,y:int)=x._lo+convert(y,x._lo)',line) - call dcl_uproc(parser,& - '_get_elem(x:range(int),y:range(int))='//& - '_get_elem(x,y._lo).._get_elem(x,y._hi)',line) - call dcl_uproc(parser,& - '_get_elem(x:range(int),y:seq(int))='//& - '_get_elem(x,y._lo).._get_elem(x,y._hi) by y._st',line) - call dcl_uproc(parser,& - '_get_elem(x:range(int),y:range_above(int))='//& - '_get_elem(x,y._t)..x._hi',line) - call dcl_uproc(parser,& - '_get_elem(x:range(int),y:range_below(int))='//& - 'x._lo.._get_elem(x,y._t)',line) + 'element(x:range(any_int),y:int)=x._lo+convert(y,x._lo)',line) call dcl_uproc(parser,& - '_get_elem(x:range(int),y:strided_range_above(int))='//& - '_get_elem(x,y._t)..x._hi by y._st',line) + 'element(x:range(any_int),y:range(int))='//& + 'element(x,y._lo)..element(x,y._hi)',line) call dcl_uproc(parser,& - '_get_elem(x:range(int),y:strided_range_below(int))='//& - 'x._lo .. _get_elem(x,y._t) by y._st',line) + 'element(x:range(any_int),y:seq(int))='//& + 'element(x,y._lo)..element(x,y._hi) by y._st',line) call dcl_uproc(parser,& - '_get_elem(x:range(int),y:stride(int))=x by y._st',line) + 'element(x:range(any_int),y:null)=x',line) call dcl_uproc(parser,& - '_get_elem(x:range,y:null)=x',line) + 'element(x:range(any_int),y:grid_dim)=y+x._lo',line) call dcl_uproc(parser,& - '#(y:range(int),x:int)=int(x-y._lo)',line) - call dcl_uproc(parser,'#(y:range(int),x:range(int))='//& + '#(y:range(any_int),x:int)=int(x-y._lo)',line) + call dcl_uproc(parser,'#(y:range(any_int),x:range(int))='//& 'int(x._lo-y._lo)..int(x._hi-y._lo)',line) - call dcl_uproc(parser,'#(y:range(int),x:seq(int))='//& + call dcl_uproc(parser,'#(y:range(any_int),x:seq(int))='//& '_intseq(int(x._lo-y._lo),int(x._hi-y._lo), x._st)',line) call dcl_uproc(parser,& - '#(y:range(int),x:range_below(int))='//& + '#(y:range(any_int),x:range_below(int))='//& '0..int(x._t-y._lo)',line) call dcl_uproc(parser,& - '#(y:range(int),x:range_above(int))='//& + '#(y:range(any_int),x:range_above(int))='//& 'int(x._t-y._lo)..size(y)-1',line) - call dcl_uproc(parser,'#(y:range(int),x:strided_range_below(int))='//& + call dcl_uproc(parser,'#(y:range(any_int),x:strided_range_below(int))='//& '_intseq(0,int(x._t-y._lo),x._st)',line) - call dcl_uproc(parser,'#(y:range(int),x:strided_range_above(int))='//& + call dcl_uproc(parser,'#(y:range(any_int),x:strided_range_above(int))='//& '_intseq(int(x._t-y._lo),size(y)-1,int(x._st))',line) - call dcl_uproc(parser,'#(y:range(int),x:stride(int))='//& + call dcl_uproc(parser,'#(y:range(any_int),x:stride(int))='//& '_intseq(0,size(y),int(x._st))',line) - call dcl_uproc(parser,'#(y:range(int),x:null)=0..size(y)',line) - call dcl_uproc(parser,'intersect(x:range(int),y:range(int))='//& + call dcl_uproc(parser,'#(y:range(any_int),x:null)=0..size(y)',line) + call dcl_uproc(parser,'intersect(x:range(any_int),y:range(any_int))='//& 'max(y._lo,x._lo)..min(y._hi,x._hi)',line) - call dcl_uproc(parser,'overlap(x:range(int),y:range(int))='//& + call dcl_uproc(parser,'overlap(x:range(any_int),y:range(any_int))='//& 'max(y._lo,x._lo)-x._lo..min(y._hi,x._hi)-x._lo',line) - call dcl_uproc(parser,'expand(x:range(),y:range())='//& + call dcl_uproc(parser,'expand(x:range,y:range)='//& 'x._lo+y._lo..x._hi+y._hi',line) - call dcl_uproc(parser,'contract(x:range(),y:range())='//& + call dcl_uproc(parser,'contract(x:range,y:range)='//& 'x._lo-y._lo..x._hi-y._hi',line) call dcl_uproc(parser,'empty(x:range)=new range {_lo=x._hi,_hi=x._lo,_n=0}',line) call dcl_uproc(parser,'string(x:range)=string(x._lo)++".."++(x._hi)',line) - - ! Strided range types + +write(*,'(a)') '// Cyclic range types (limited functionality and not part of grid)' + call dcl_type(parser,'cyclic_range is rec {_lo:int,_hi:int,_w:int,_n:int}',line) + call dcl_uproc(parser,'cyclic_range(x:int,y:int,w:int)='//& + 'new cyclic_range {_lo=xx,_hi=yy,_w=w,_n=max(0,int(yy-xx)+1)} where xx,yy=balance(x,y)',line) + call dcl_uproc(parser,'low(x:cyclic_range)=x._lo',line) + call dcl_uproc(parser,'high(x:cyclic_range)=x._hi',line) + call dcl_uproc(parser,'size(x:cyclic_range)=x._n',line) + call dcl_uproc(parser,'element(x:cyclic_range,y:int)=(x._lo + y) mod x._w',line) + call dcl_uproc(parser,'string(x:cyclic_range)="cycle("++x._lo++".."++x._hi++","++x._w++")"',line) + +write(*,'(a)') '// Strided range types' call dcl_type(parser,& - 'strided_range(t) is rec {_lo:t,_hi:t,_st:t,_n:int}',line) + 'strided_range(t:range_base) is rec {_lo:t,_hi:t,_st:t,_n:int}',line) call dcl_type(parser,& - '_any_seq(t:range_base):indexable is strided_range(t), ... ',line) + '_any_seq(t:range_base):iterable is strided_range(t), ... ',line) call dcl_type(parser,& - '_any_seq(t:any_int) is ..., range(t),single_point(t)',line) + '_any_seq(t:any_int) is ..., range(t)',line) call dcl_type(parser,'seq(t:range_base) is _any_seq(t)',line) - call dcl_uproc(parser,'_seq(lo,hi,st)=new strided_range {_lo=lo,_hi=lo+n*st,_st=st,_n=n}'//& - 'where n=max(0,int((hi-lo)/st))',line) + call dcl_uproc(parser,'_seq(lo,hi,st)=new strided_range {_lo=lo,_hi=lo+(n-1)*st,_st=st,_n=n}'//& + 'check "Zero step size in strided range"=>st/=0 where n=max(0,1+_rdiv(int((hi-lo)),int(st)))',line) call dcl_uproc(parser,'by(x:range(int),y:range_base)=_seq(lo,hi,st)'//& ' where hi=convert(x._hi,lo) where lo,st=balance(x._lo,y)',line) call dcl_uproc(parser,'by(x:seq,y:range_base)=_seq(lo,hi,st) where'//& @@ -1407,14 +1479,11 @@ subroutine sysdefs(parser) 'where hi=lo+(x._n-1)*x._st where lo=x._lo',line) call dcl_uproc(parser,'align(x:seq)=''0',line) call dcl_uproc(parser,'#(x:strided_range)=shape([0..x._n-1])',line) - call dcl_uproc(parser,'_shp(x:strided_range)=0..x._n-1',line) call dcl_uproc(parser,'dims(x:strided_range)=[x._n]',line) call dcl_uproc(parser,'+(x:strided_range,y:range_base)='//& 'new strided_range {_lo=x._lo+y,_hi=x._hi+y,_st=x._st,_n=x._n}',line) call dcl_uproc(parser,'-(x:strided_range,y:range_base)='//& 'new strided_range {_lo=x._lo-y,_hi=x._hi-y,_st=x._st,_n=x._n}',line) -!!$ call dcl_uproc(parser,'*(x:strided_range,y:range_base)='//& -!!$ 'new strided_range {_lo=x._lo*y,_hi=x._hi*y,_st=x._st*y,_n=x._n}',line) call dcl_uproc(parser,'_arb(x:seq)=x._lo',line) call dcl_uproc(parser,'convert(x:strided_range,y:range_base)='//& 'new strided_range {_lo=convert(x._lo,y),_hi=convert(x._hi,y),'//& @@ -1441,7 +1510,7 @@ subroutine sysdefs(parser) 'inc(x:strided_range(int),y:range(int) or single_point(int))='//& 'x inc low(y)..high(y) by 1',line) call dcl_uproc(parser,& - '#(y:seq,x:range_base)=int((x-y._lo+y._a)/y._st)',line) + '#(y:seq,x:range_base)=int((x-y._lo)/y._st)',line) call dcl_uproc(parser,& '#(y:seq,x:range)=y#x._lo..y#x._hi',line) call dcl_uproc(parser,& @@ -1464,30 +1533,16 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'string(x:strided_range)=x._lo++".."++x._hi++" by "++x._st',line) call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:int)=x._lo+convert(y,x._lo)*x._st',line) + 'element(x:strided_range,y:int)=x._lo+convert(y,x._lo)*x._st',line) call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:range(int))='//& - '_seq(_get_elem(x,y._lo),_get_elem(x,y._hi),x._st)',line) + 'element(x:strided_range,y:range(int))='//& + '_seq(element(x,y._lo),element(x,y._hi),x._st)',line) call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:seq(int))='//& - '_seq(_get_elem(x,y._lo),_get_elem(x,y._hi),'//& + 'element(x:strided_range,y:strided_range(int))='//& + '_seq(element(x,y._lo),element(x,y._hi),'//& 'convert(st*y._st,st)) where st=x._st',line) call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:range_above(int))='//& - '_seq(_get_elem(x,y._t),x._hi,x._st)',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:range_below(int))='//& - '_seq(x._lo,_get_elem(x,y._t),x._st)',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:strided_range_above(int))='//& - '_seq(_get_elem(x,y._t),x._hi,convert(st*y._st,st)) where st=x._st',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:strided_range_below(int))='//& - '_seq(x._lo,_get_elem(x,y._t),convert(st*y._st,st)) where st=x._st',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:stride(int))=x by y',line) - call dcl_uproc(parser,& - '_get_elem(x:strided_range,y:null)=x',line) + 'element(x:strided_range,y:null)=x',line) call dcl_uproc(parser,& 'overlap(x:strided_range(any_int),y:range(any_int))='//& @@ -1504,20 +1559,20 @@ subroutine sysdefs(parser) call dcl_proc(parser,& '_intersect_seq(int,int,int,int,int,int,int,int)->int,int,int,int',& - op_intersect_seq,0,line,0) + "intersect_seq",0,line,0) call dcl_uproc(parser,'intersect(x:strided_range(any_int),y:strided_range(any_int))='//& 'new strided_range {_lo=lo,_hi=hi,_st=st,_n=n}'//& 'where lo,hi,st,n='//& '_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),'//& 'int(y._lo),int(y._hi),int(y._st),int(y._n))',line) call dcl_uproc(parser,'overlap(x:strided_range(any_int),y:strided_range(any_int))='//& - 'new strided_range {_lo=(lo-x._lo)/x._st,_hi=(hi-x._lo)/x._st,_st=st/x._st,_n=n}'//& - ' where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),'//& + 'new strided_range {_lo=(lo-x._lo)/x._st,_hi=(hi-x._lo)/x._st,_st=if(sst/=0=>sst,1),_n=n}'//& + ' where sst=st/x._st where lo,hi,st,n=_intersect_seq(int(x._lo),int(x._hi),int(x._st),int(x._n),'//& ' int(y._lo),int(y._hi),int(y._st),int(y._n))',line) call dcl_uproc(parser,'empty(x:strided_range(any_int))='//& 'new strided_range {_lo=x._hi,_hi=x._lo,_st=x._st,_n=0}',line) - ! Block sequence +write(*,'(a)') '// Block sequence' call dcl_type(parser,& 'block_seq is rec { _lo:int,_hi:int,_st:int,_b:int,_n:int,_align:int}',line) call dcl_uproc(parser,'block_seq(lo:int,hi:int,st:int,b:int,align:int){'//& @@ -1543,15 +1598,12 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'norm(x:block_seq)=x',line) call dcl_uproc(parser,'align(x:block_seq)=x._align',line) call dcl_uproc(parser,'#(x:block_seq)=shape([0..x._n-1])',line) - call dcl_uproc(parser,'_shp(x:block_seq)=0..x._n-1',line) call dcl_uproc(parser,'dims(x:block_seq)=x._n',line) call dcl_uproc(parser,'size(x:block_seq)=x._n',line) call dcl_uproc(parser,'+(x:block_seq,y:int)='//& 'new block_seq {_lo=x._lo+y,_hi=x._hi+y,_st=x._st,_b=x._b,_n=x._n,_align=x._align}',line) call dcl_uproc(parser,'-(x:block_seq,y:int)='//& 'new block_seq {_lo=x._lo-y,_hi=x._hi-y,_st=x._st,_b=x._b,_n=x._n,_align=x._align}',line) -!!$ call dcl_uproc(parser,'*(x:block_seq,y:int)='//& !!! Not sure this is right definition !! -!!$ 'new block_seq {_lo=x._lo*y,_hi=x._hi*y,_st=x._st*y,_b=x._b*y,_n=x._n,_align=x._align*y}',line) call dcl_uproc(parser,'_arb(x:block_seq)=x._lo',line) call dcl_uproc(parser,'in(x:int,y:block_seq)='//& 'x>=y._lo and x<=y._hi and (x-y._lo+y._align) mod y._st=x._b:lo:=nblo+x._st;'//& - ' if hi-nbhi>=x._b:hi:=nbhi+x._b-1;'//& + ' if lo-nblo>=x._b:lo=nblo+x._st;'//& + ' if hi-nbhi>=x._b:hi=nbhi+x._b-1;'//& ' align=base-(base/x._st)*x._st '//& ' where base=lo-oldbase;'//& ' return block_seq(lo,hi,x._st,x._b,align)'//& @@ -1586,53 +1640,51 @@ subroutine sysdefs(parser) 'return start..start+size(z)-1,'//& ' block_seq(z._lo-x._lo,z._hi-x._lo,z._st,z._b,z._align)'//& ' where start=z#z._lo}',line) - call dcl_uproc(parser,'overlap(x:range(any_int),y:block_seq)=yy,xx'//& - ' where xx,yy=overlap(x,y)',line) + call dcl_uproc(parser,'overlap(x:range(any_int),y:block_seq)=xx,yy'//& + ' where yy,xx=overlap(y,x)',line) call dcl_uproc(parser,'empty(x:block_seq)=block_seq(1,0,1,1,0)',line) - ! Mapped sequence +write(*,'(a)') '// Mapped sequence' call dcl_type(parser,'map_seq(t:array(int)) is rec {array:t}',line) - call dcl_uproc(parser,'map_seq(x:grid_dim){var a=array(0,#x);for i in a,j in x <>:i:=j;'//& + call dcl_uproc(parser,'map_seq(x:grid_dim){var a=array(0,#x);forall i in a,j in x:i=j;'//& 'return new map_seq{array=a}}',line) call dcl_uproc(parser,'map_seq(x:array(int,mshape1d))=new map_seq {array=x} '//& 'check "Array for ""map_seq"" must be strictly increasing or stricly decreasing"=>_mono(x)',line) call dcl_uproc(parser,'_mono(x) {xs=#x;var ok=true;'//& - 'if x[low(xs.1)]x[i-1]:sync ok:=false};return ok}' ,line) + 'if x[low(xs.1)]x[i-1]:sync ok=false};return ok}' ,line) call dcl_uproc(parser,'map_seq(x:map_seq)=x',line) call dcl_uproc(parser,'#(x:map_seq)=#(x.array)',line) - call dcl_uproc(parser,'_shp(x:map_seq)=0..size(x.array)-1',line) call dcl_uproc(parser,'dims(x:map_seq)=size(x.array)',line) call dcl_uproc(parser,'size(x:map_seq)=size(x.array)',line) call dcl_uproc(parser,'+(x:map_seq,y:range_base)=new map_seq{array=x.array+y}',line) call dcl_uproc(parser,'-(x:map_seq,y:range_base)=new map_seq{array=x.array-y}',line) - call dcl_uproc(parser,'*(x:map_seq,y:range_base)=new map_seq{array=x.array*y}',line) call dcl_uproc(parser,'_arb(x:map_seq)=_arb(x.array)',line) - call dcl_uproc(parser,'_get_elem(x:map_seq,y:int)=_get_elem(x.array,y)',line) + call dcl_uproc(parser,'element(x:map_seq,y:int)=element(x.array,y)',line) call dcl_proc(parser,'_intersect_aseq(&any,any,any,any,any,&any)',& - op_intersect_aseq,0,line,0) + "intersect_aseq",0,line,0) call dcl_proc(parser,'_overlap_aseq(&any,any,any,any,any,&any)',& - op_intersect_aseq,1,line,0) + "intersect_aseq",1,line,0) call dcl_proc(parser,'_overlap_aseq2(&any,any,any,any,any,&any,&any)',& - op_intersect_aseq,2,line,0) + "intersect_aseq",2,line,0) call dcl_proc(parser,'_expand_aseq(&any,any,any,&any,any,any)',& - op_expand_aseq,0,line,0) + "expand_aseq",0,line,0) call dcl_proc(parser,'_intersect_bseq(&any,any,any,any,any,any,any,any,any,any,any,any)',& - op_intersect_bseq,0,line,0) + "intersect_bseq",0,line,0) call dcl_proc(parser,'_overlap_bseq(&any,any,any,any,any,any,any,any,any,any,any,any)',& - op_intersect_bseq,1,line,0) + "intersect_bseq",1,line,0) call dcl_proc(parser,'_overlap_bseq2(&any,any,any,any,any,any,any,any,any,any,any,any,any)',& - op_intersect_bseq,2,line,0) + "intersect_bseq",2,line,0) call dcl_proc(parser,'_includes_aseq(any,any,any,any)->bool',& - op_includes_aseq,0,line,0) + "includes_aseq",0,line,0) call dcl_proc(parser,'_index_aseq(any,any,any)->int',& - op_index_aseq,0,line,0) + "index_aseq",0,line,0) call dcl_proc(parser,'_in_aseq(any,any,any)->bool',& - op_in_aseq,0,line,0) + "in_aseq",0,line,0) !!$ call dcl_uproc(parser,'intersect(x:block_seq,y:block_seq) {'//& !!$ 'var a=array(0,[0..min(x._n,y._n)-1]);'//& @@ -1673,7 +1725,7 @@ subroutine sysdefs(parser) 'var a=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]);'//& 'var b=array(0,[0..max(0,min(size(x.array),size(y.array))-1)]);'//& 'var n=0;_overlap_aseq2(&n,x.array,size(x.array),y.array,size(y.array),&a,&b);'//& - 'ns=shape([0..n-1]);'//& + 'ns=[0..n-1];'//& 'v=new map_seq {array=a[ns]};w=new map_seq {array=b[ns]};return v,w}',line) call dcl_uproc(parser,'overlap(x:seq,y:seq)=overlap(x,y),overlap(y,x)',line) @@ -1684,7 +1736,8 @@ subroutine sysdefs(parser) '_expand_aseq(&m,t.array,size(t.array),&a,low(i),high(i));'//& 'v=new map_seq {array=a[0..m-1]};return v}',line) - call dcl_uproc(parser,'inc(x:map_seq,y:map_seq)=_includes_aseq(x.array,size(x.array),y.array,size(y.array))',line) + call dcl_uproc(parser,& + 'inc(x:map_seq,y:map_seq)=_includes_aseq(x.array,size(x.array),y.array,size(y.array))',line) call dcl_uproc(parser,'inc(x:map_seq,y:seq or block_seq)=x inc map_seq(y)',line) call dcl_uproc(parser,'inc(x:block_seq,y:block_seq)=map_seq(x) inc map_seq(y)',line) call dcl_uproc(parser,'inc(x:seq or block_seq,y:map_seq)=map_seq(x) inc y',line) @@ -1693,75 +1746,101 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'empty(x:map_seq) {a=array(0,[1..0]);return new map_seq {array=a}}',line) - ! Grids (tuples of sequences) - call dcl_type(parser,'grid_dim is seq,block_seq,map_seq',line) - call dcl_type(parser,'grid1d(t1:grid_dim) is tuple(t1)',line) - call dcl_type(parser,'grid2d(t1:grid_dim,t2:grid_dim) is tuple(t1,t2)',line) +write(*,'(a)') '// Grids (tuples of sequences)' + call dcl_type(parser,'_grid_dim(t:range_base) is seq(t),...',line) + call dcl_type(parser,'_grid_dim(t:int) is ...,block_seq,map_seq',line) + call dcl_type(parser,'grid_dim(t:range_base) is _grid_dim(t)',line) + call dcl_type(parser,'grid1d(t1:grid_dim) is [t1]',line) + call dcl_type(parser,'grid2d(t1:grid_dim,t2:grid_dim) is [t1,t2]',line) call dcl_type(parser,'grid3d(t1:grid_dim,t2:grid_dim,t3:grid_dim) is'//& - ' tuple(t1,t2,t3)',line) + ' [t1,t2,t3]',line) call dcl_type(parser,'grid4d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim) is'//& - ' tuple(t1,t2,t3,t4)',line) + ' [t1,t2,t3,t4]',line) call dcl_type(parser,'grid5d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,'//& 't5:grid_dim) is'//& - ' tuple(t1,t2,t3,t4,t5)',line) + ' [t1,t2,t3,t4,t5]',line) call dcl_type(parser,'grid6d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,'//& 't5:grid_dim,t6:grid_dim) is'//& - ' tuple(t1,t2,t3,t4,t5,t6)',line) + ' [t1,t2,t3,t4,t5,t6]',line) call dcl_type(parser,'grid7d(t1:grid_dim,t2:grid_dim,t3:grid_dim,t4:grid_dim,'//& 't5:grid_dim,t6:grid_dim,t7:grid_dim) is'//& - ' tuple(t1,t2,t3,t4,t5,t6,t7)',line) - call dcl_type(parser,'grid is tuple(grid_dim)',line) - call dcl_uproc(parser,'_get_elem(x:grid_dim,y:tuple1d)=_get_elem(x,y.1)',line) + ' [t1,t2,t3,t4,t5,t6,t7]',line) + call dcl_type(parser,'grid(t:range_base) is tuple(grid_dim(t))',line) call dcl_uproc(parser,'#(x:grid)=shape(map($_shp,x))',line) + call dcl_uproc(parser,'dims(x:grid)=map($_size,x)',line) call dcl_uproc(parser,'+(x:grid,y:tuple(range_base))=map($+,x,y)',line) + call dcl_uproc(parser,'-(x:grid,y:tuple(range_base))=map($+,x,y)',line) call dcl_uproc(parser,'empty(x:grid)=map($empty,x)',line) + call dcl_uproc(parser,'element(x:grid_dim,y:grid_dim){var a=array(0,#y);'//& + 'forall i in a,j in y:i=x[j];'//& + 'return new map_seq{array=a}}',line) + call dcl_uproc(parser,'element(x:grid,y:grid)=map($element,x,y)',line) + +write(*,'(a)') '// Slices of grids (may have dims that are just an integer and also _ or _() or null)' + call dcl_type(parser,'grid_slice_dim(t:range_base) is grid_dim(t),single_point(t),null',line) + call dcl_type(parser,'grid_slice(t) is grid(t),tuple(grid_slice_dim(t))',line) + +write(*,'(a)') '// Some limited functionality for extended grids (which include cyclic ranges)' + call dcl_type(parser,'iterable_dim is grid_slice_dim,cyclic_range,...',line) + call dcl_type(parser,'iterable_grid is tuple(iterable_dim),grid_slice',line) + call dcl_uproc(parser,'_shp(x:iterable_dim)=0..size(x)-1',line) + call dcl_uproc(parser,'size(x:iterable_dim)->(int)...',line) + call dcl_uproc(parser,'element(x:iterable_dim,y)=error_type()'//& + 'check "Cannot index this type with a non-integer index"=>''false',line) + call dcl_uproc(parser,'element(x:iterable_dim,y:int)->(any)...',line) + call dcl_uproc(parser,'element(x:iterable_dim,y:tuple1d)=element(x,y.1)',line) + - ! Slices of grids (may have dims that are just an integer and also _ or _() or null) call dcl_uproc(parser,'_shp(x:stretch_dim)=null',line) call dcl_uproc(parser,'_shp(x:null)=x',line) call dcl_uproc(parser,'_size(x:stretch_dim or null)=''1',line) call dcl_uproc(parser,'_size(x)=size(x)',line) - call dcl_type(parser,'grid_slice_dim:indexable is grid_dim,single_point,null',line) - call dcl_type(parser,'grid_slice:indexable is extent,tuple(grid_slice_dim)',line) - call dcl_proc(parser,'_act(x:single_point)->PM__tinyint',op_miss_arg,0,line,0) + call dcl_proc(parser,'_act(x:single_point)->PM__tinyint',"miss_arg",0,line,0) call dcl_uproc(parser,'_act(x)=x',line) call dcl_uproc(parser,'_sliceit(arg...)=tuple(arg...)',line) - call dcl_uproc(parser,'active_dims(x:grid_slice)=map_apply($_act,$_sliceit,x)',line) + call dcl_uproc(parser,'active_dims(x:iterable_grid)=map_apply($_act,$_sliceit,x)',line) call dcl_uproc(parser,'active_dims(x:single_point)=null',line) - call dcl_uproc(parser,'_ar(x:single_point)=''0',line) - call dcl_uproc(parser,'_ar(x)=''1',line) - call dcl_uproc(parser,'rank(x:grid_slice)=map_reduce($_ar,$+,x)',line) - - call dcl_uproc(parser,'_get_elem(x:grid_slice,arg...:index)'//& - '{t=_tup(arg...);'//& - 'return _ges(head(x),tail(x),head(t),tail(t),''false) }',line) - call dcl_uproc(parser,'_get_elem(x:grid_slice,arg...:subs)'//& + call dcl_proc(parser,'_act(x:single_point,y:any)->PM__tinyint',"miss_arg",0,line,0) + call dcl_uproc(parser,'_act(x,y)=y',line) + call dcl_uproc(parser,'active_dims(x:iterable_grid,y:tuple)=map_apply($_act,$_sliceit,x,y)',line) + call dcl_uproc(parser,'active_dims(x:single_point,y)=null',line) + call dcl_uproc(parser,'_ar(x:single_point)=0',line) + call dcl_uproc(parser,'_ar(x)=1',line) + call dcl_uproc(parser,'rank(x:iterable_grid)=map_reduce($_ar,$+,x)',line) + call dcl_uproc(parser,'element(x:iterable_grid,y:index)'//& + '{t=_tup(y);return _ges(head(x),tail(x),head(t),tail(t),''false)}',line) + call dcl_uproc(parser,'element(x:grid_slice,arg...:grid_slice)'//& '{t=_tup(arg...);'//& 'return _ges(head(x),tail(x),head(t),tail(t),''true) }',line) - call dcl_uproc(parser,'_get_elem(x:null,y)=null',line) + call dcl_uproc(parser,'element(x:null,y)=null',line) call dcl_uproc(parser,'_spnt(i,y:''true)=i',line) call dcl_uproc(parser,'_spnt(i,y:''false)=i._t',line) + call dcl_uproc(parser,'_spif(i:int,y:''true)=single_point(i)',line) + call dcl_uproc(parser,'_spif(i,y:''true)=i',line) + call dcl_uproc(parser,'_spif(i,y:''false)=i',line) call dcl_uproc(parser,'_ges(i:single_point,x,j,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t))',line) call dcl_uproc(parser,'_ges(i:empty_head,x,j,y,t)=error_type() :test "Rank mismatch in subscript" => ''false',line) - call dcl_uproc(parser,'_ges(i,x,j,y,t)=prepend(_get_elem(i,j),_ges(head(x),tail(x),head(y),tail(y),t))',line) - call dcl_uproc(parser,'_ges(i:null,x,j,y,t:''true)='//& - 'prepend(_get_elem(i,j),_ges(head(x),tail(x),head(y),tail(y),t))',line) - call dcl_uproc(parser,'_ges(i:null,x,j,y,t:''false)=_ges(head(x),tail(x),head(y),tail(y),t)',line) + call dcl_uproc(parser,'_ges(i,x,j,y,t)=prepend(_spif(element(i,j),t),'//& + '_ges(head(x),tail(x),head(y),tail(y),t))',line) + call dcl_uproc(parser,'_ges_null(i,x,j,y,t:''true)='//& + 'prepend(element(i,j),_ges(head(x),tail(x),head(y),tail(y),t))',line) + call dcl_uproc(parser,'_ges_null(i,x,j,y,t:''false)=_ges(head(x),tail(x),head(y),tail(y),t)',line) + call dcl_uproc(parser,'_ges(i:null,x,j,y,t)=_ges_null(i,x,j,y,t)',line) call dcl_uproc(parser,'_ges(i:single_point,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) call dcl_uproc(parser,'_ges(i:empty_head,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) call dcl_uproc(parser,'_ges(i,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) - call dcl_uproc(parser,'_ges(i:null,x,j:stretch_dim,y,t:''true)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) - call dcl_uproc(parser,'_ges(i:null,x,j:stretch_dim,y,t:''false)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) - call dcl_uproc(parser,'_ges(i:single_point,x,j:empty_head,y,t)=prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t))',line) + call dcl_uproc(parser,'_ges(i:null,x,j:stretch_dim,y,t)=prepend(null,_ges(i,x,head(y),tail(y),t))',line) + call dcl_uproc(parser,'_ges(i:single_point,x,j:empty_head,y,t)='//& + 'prepend(_spnt(i,t),_ges(head(x),tail(x),j,y,t))',line) call dcl_uproc(parser,'_ges(i:empty_head,x,j:empty_head,y,t)=null',line) call dcl_uproc(parser,'_ges(i,x,j:empty_head,y,t)=error_type() :test "Rank mismatch" => ''false',line) call dcl_uproc(parser,'_ges(i:null,x,j:empty_head,y,t:''true)=error_type() :test "Rank mismatch" => ''false',line) call dcl_uproc(parser,'_ges(i:null,x,j:empty_head,y,t:''false)=null',line) - call dcl_uproc(parser,'size(x:grid_slice)=map_reduce($_size,$*,x)',line) - call dcl_uproc(parser,'#(x:grid_slice)=shape(map($_shp,active_dims(x)))',line) !!! - call dcl_uproc(parser,'dims(x:grid_slice)=map($_size,active_dims(x))',line) + call dcl_uproc(parser,'size(x:iterable_grid)=map_reduce($_size,$*,x)',line) + call dcl_uproc(parser,'#(x:grid_slice)=shape(map($_shp,active_dims(x)))',line) + call dcl_uproc(parser,'dims(x:iterable_grid)=map($_size,active_dims(x))',line) call dcl_uproc(parser,'_arb(x:grid_slice)=map($_arb,x)',line) call dcl_uproc(parser,'in(x:tuple(range_base),y:grid_slice)='//& 'map_reduce($in,$and,x,y)',line) @@ -1769,7 +1848,7 @@ subroutine sysdefs(parser) 'map_reduce($inc,$and,x,y)',line) call dcl_uproc(parser,'#(x:grid,y:tuple(subs_dim))='//& 'map($#,x,y)',line) - call dcl_proc(parser,'_acthash(x:single_point,y:any)->PM__tinyint',op_miss_arg,0,line,0) + call dcl_proc(parser,'_acthash(x:single_point,y:any)->PM__tinyint',"miss_arg",0,line,0) call dcl_uproc(parser,'_acthash(x,y)=x#y',line) call dcl_uproc(parser,'#(x:grid_slice,y:tuple(subs_dim) or grid_slice)='//& 'map_apply($_acthash,$_sliceit,x,y)',line) @@ -1787,17 +1866,18 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'intersect(x:grid_slice_dim,y:grid_slice_dim)=intersect(map_seq(x),map_seq(y))',line) call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:grid_slice_dim)=overlap(map_seq(x),map_seq(y))',line) call dcl_uproc(parser,'overlap(x:grid_slice_dim,y:grid_slice_dim)=u,v where u,v=overlap(map_seq(x),map_seq(y))',line) - call dcl_uproc(parser,'intersect_aligned(x:grid,y:grid)=map($intersect_aligned,x,y)',line) call dcl_uproc(parser,'expand(x:grid_slice,y:grid)='//& 'map($expand,x,y)',line) call dcl_uproc(parser,'contact(x:grid_slice,y:grid)='//& 'map($contract,x,y)',line) - call dcl_proc(parser,'gcd(x:int,y:int)->int',op_gcd,0,line,0) + call dcl_proc(parser,'gcd(x:int,y:int)->int',"gcd",0,line,0) + + - ! ***************************************************** - ! SHAPES - ! ***************************************************** +write(*,'(a)') '// *****************************************************' +WRITE(*,'(A)') '// SHAPES' +write(*,'(a)') '// *****************************************************' call dcl_type(parser,'extent is tuple(range(int) ),'//& 'extent1d,extent2d,extent3d,extent4d,extent5d,extent6d,extent7d',line) @@ -1820,7 +1900,7 @@ subroutine sysdefs(parser) call dcl_type(parser,'mshape6d is mshape(extent6d)',line) call dcl_type(parser,'mshape7d is mshape(extent7d)',line) - ! Create array, vector and matrix shapes +write(*,'(a)') '// Create array, vector and matrix shapes' call dcl_uproc(parser,'_low(x)=low(x)',line) call dcl_uproc(parser,'_low(x:null)=''0',line) call dcl_uproc(parser,'_off(x)=-index(dims(x),map($_low,x))',line) @@ -1832,7 +1912,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'shape(extent:extent)='//& 'new mshape {_extent=extent,_n=size(extent),_o=_off(extent)}',line) - ! Conforming mshapes +write(*,'(a)') '// Conforming mshapes' call dcl_uproc(parser,'check_conform(x,y) {check_conform(#x,#y)}',line) call dcl_uproc(parser,'check_conform(x:mshape,y:mshape) {'//& ' test "Mshapes "++x++" and "++y++" do not conform"=>'//& @@ -1845,35 +1925,45 @@ subroutine sysdefs(parser) 'map_reduce($_conform,$and,x,y) or size(x)==0 or size(y)==0'//& 'check "Values of different ranks cannot conform"=>rank(x)==rank(y)',line) - ! Local size of a mshape +write(*,'(a)') '// Local size of a mshape' call dcl_uproc(parser,'_local_size(x:mshape)=size(x._extent)',line) - ! Extent of a mshape +write(*,'(a)') '// Convert an extent to have a zero base' + call dcl_uproc(parser,'zero_base(x:range)=0..size(x)-1',line) + call dcl_uproc(parser,'zero_base(x:extent)=map($zero_base,x)',line) + +write(*,'(a)') '// Extent of a mshape' call dcl_uproc(parser,'extent(x:shape)=x._extent',line) - ! Dimensions of a mshape +write(*,'(a)') '// Dimensions of a mshape' call dcl_uproc(parser,'dims(x:mshape)=map($size,x._extent)',line) - ! Size from dimensions +write(*,'(a)') '// Size from dimensions' call dcl_uproc(parser,'size(x:tuple(int))=reduce($*,x)',line) - ! Empty mshape +write(*,'(a)') '// Empty mshape' call dcl_uproc(parser,'_empty(x)=1..0',line) call dcl_uproc(parser,'empty(x:extent)=map($_empty,x)',line) + +write(*,'(a)') '// Slice of mshape' + call dcl_uproc(parser,'[](x:mshape,s:index)=x._extent[s]',line) + call dcl_uproc(parser,'[](x:mshape,s:subs)=shape(#active_dims(fill_in(x,s,''true))):'//& + 'check_contains(x,s)',line) - ! ***************************************************** - ! INDEXING AND SLICING - ! ***************************************************** +write(*,'(a)') '// *****************************************************' +WRITE(*,'(A)') '// INDEXING AND SLICING' +write(*,'(a)') '// *****************************************************' - ! Generic types supporting indexing and mapping - call dcl_type(parser,'indexable is grid_slice,grid,seq,array,...',line) - call dcl_uproc(parser,'[](x:indexable,arg...)'//& - '{y=_tup(arg...);check_contains(#x,y);return _get_elem(x,y)}',line) +write(*,'(a)') '// Generic types supporting indexing and mapping' + call dcl_type(parser,'iterable is iterable_grid,'//& + 'grid_slice,grid,grid_slice_dim,cyclic_range,array,...',line) + call dcl_uproc(parser,'[](x:iterable,arg...)'//& + '{d=#x;y=_tup(arg...);check_contains(d,y);return element(x,fill_in(d,y,''false))}',line) - ! Index type +write(*,'(a)') '// Index type' call dcl_type(parser,'index is any_int,tuple(any_int)',line) - ! Slice and subscript types +write(*,'(a)') '// Slice and subscript types' call dcl_type(parser,'range_below(x) is rec {_t:x}',line) call dcl_type(parser,'range_above(x) is rec {_t:x}',line) call dcl_type(parser,& @@ -1888,11 +1978,11 @@ subroutine sysdefs(parser) line) call dcl_type(parser,'slice is slice_dim,tuple(slice_dim)'& ,line) - call dcl_type(parser,'subs_dim is slice_dim,int',line) + call dcl_type(parser,'subs_dim is slice_dim,any_int',line) call dcl_type(parser,'subs is index,slice,subs_dim,tuple(subs_dim)',line) - ! Partial ranges/sequences mainly used in subscripts +write(*,'(a)') '// Partial ranges/sequences mainly used in subscripts' call dcl_uproc(parser,'..._(x)=new range_below {_t=x}',line) call dcl_uproc(parser,'_...(x)=new range_above {_t=x}',line) call dcl_uproc(parser,'by(x:range_base)=new stride {_st=x}',line) @@ -1914,7 +2004,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'width(x:strided_range_above or strided_range_below or '//& 'range_above or range_below)=''1',line) - ! Stretch dimension in subscript +write(*,'(a)') '// Stretch dimension in subscript' call dcl_type(parser,'stretch_dim is unique{PM__strdim}',line) call dcl_uproc(parser,'string(x:stretch_dim)="_"',line) call dcl_uproc(parser,'size(x:stretch_dim)=''1',line) @@ -1932,7 +2022,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'overlap(x:stretch_dim,y:grid_slice_dim)=''0..''0',line) call dcl_uproc(parser,'overlap(x:stretch_dim,y:stretch_dim)=''0..''0',line) - ! Check subscript is in range +write(*,'(a)') '// Check subscript is in range' call dcl_uproc(parser,'check_contains(a:extent,arg...) '//& '{test "Index "++t++" out of bounds "++a=>contains(a,t) where t=_tup(arg...)}',line) call dcl_uproc(parser,'check_contains(a:mshape,arg...) {check_contains(a._extent,arg...)}',line) @@ -1951,7 +2041,7 @@ subroutine sysdefs(parser) '_contains(x.1,y)',line) call dcl_uproc(parser,'contains(x:extent,y:tuple(subs_dim))='//& 'map_reduce($_contains,$and,x,y)',line) - call dcl_proc(parser,'_rgd(x:stretch_dim)->PM__tinyint',op_miss_arg,0,line,0) + call dcl_proc(parser,'_rgd(x:stretch_dim)->PM__tinyint',"miss_arg",0,line,0) call dcl_uproc(parser,'_rgd(x)=x',line) call dcl_uproc(parser,'_rigid_dims(x:grid_slice or tuple(subs_dim))='//& 'map_apply($_rgd,$_sliceit,x)',line) @@ -1959,36 +2049,42 @@ subroutine sysdefs(parser) ' and contains(stretch_dim))=contains(x,_rigid_dims(y))',line) call dcl_uproc(parser,'contains(x:extent,y,arg...)=contains(x,[y,arg...])',line) - ! Complete a subscript using a base mshape - call dcl_uproc(parser,& - 'fill_in(x:null,y)=y :test "Cannot use incomplete subscript on null dimension" => ''false',line) - call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:any_int)=single_point(int(y))',line) - call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:range(any_int))=int(y)',line) - call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:strided_range(any_int))=int(y)',line) - call dcl_uproc(parser,'fill_in(x:seq(int),y:range_below(any_int))=x._lo..int(y._t)',line) - call dcl_uproc(parser,'fill_in(x:seq(int),y:range_above(any_int))=int(y._t)..x._hi',line) - call dcl_uproc(parser,'fill_in(x:seq(int),y:strided_range_below(any_int))=lo..int(y._t) by y._st'//& +write(*,'(a)') '// Complete a subscript using a base mshape' + call dcl_uproc(parser,& + 'fill_in(x:null,y,t)=y :test "Cannot use incomplete subscript on null dimension" => ''false',line) + call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:any_int,t:''true)=single_point(int(y))',line) + call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:any_int,t:''false)=int(y)',line) + call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:any_int,t:null)=int(y)..int(y)',line) + call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:range(any_int),t)=int(y)',line) + call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:strided_range(any_int),t)=int(y)',line) + call dcl_uproc(parser,'fill_in(x:seq(int),y:range_below(any_int),t)=x._lo..int(y._t)',line) + call dcl_uproc(parser,'fill_in(x:seq(int),y:range_above(any_int),t)=int(y._t)..x._hi',line) + call dcl_uproc(parser,'fill_in(x:seq(int),y:strided_range_below(any_int),t)=lo..int(y._t) by y._st'//& ' where lo=y._t-(y._t-x._lo)/y._st*y._st',line) - call dcl_uproc(parser,'fill_in(x:seq(int),y:strided_range_above(any_int))=int(y._t)..x._hi by y._st',line) - call dcl_uproc(parser,'fill_in(x:seq(int),y:stride(any_int))=x by int(y._st)',line) - call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:null)=x',line) - call dcl_uproc(parser,'fill_in(x:grid,y:tuple(subs_dim))=map($fill_in,x,y)',line) - call dcl_uproc(parser,'fill_in(x:grid,y:tuple(subs_dim) and contains(stretch_dim))='//& - '_fill_in(x,head(y),tail(y))',line) - call dcl_uproc(parser,'_fill_in(x,y,z)=prepend(fill_in(x.1,y),'//& - '_fill_in(tail(x),head(z),tail(z)))',line) - call dcl_uproc(parser,'_fill_in(x,y:stretch_dim,z)='//& - 'prepend(null,_fill_in(x,head(z),tail(z)))',line) - call dcl_uproc(parser,'_fill_in(x:null,y:empty_head,z)=null',line) - call dcl_uproc(parser,& - '_fill_in(x:empty_head,y:stretch_dim,z)=prepend(null,_fill_in(x,head(z),tail(z)))',line) - call dcl_uproc(parser,'_fill_in(x:empty_head,y,z)=error_type() :test "Rank mismatch in slice" => ''false',line) - - ! ******************************************************* - ! SUBSCRIPT INTERSECTION AND ALIASING - ! ******************************************************* - - ! Test for intersection between two subscripts + call dcl_uproc(parser,'fill_in(x:seq(int),y:strided_range_above(any_int),t)=int(y._t)..x._hi by y._st',line) + call dcl_uproc(parser,'fill_in(x:seq(int),y:stride(any_int),t)=x by int(y._st)',line) + call dcl_uproc(parser,'fill_in(x:seq(int) or null,y:null,t)=x',line) + call dcl_uproc(parser,'fill_in(x:grid,y:tuple(any_int),t)=int(y)',line) + call dcl_uproc(parser,'fill_in(x:grid,y:tuple(subs_dim),t)=map($fill_in,x,y,spread(t,x))',line) + call dcl_uproc(parser,'fill_in(x:grid,y:tuple(subs_dim) and contains(stretch_dim),t)='//& + '_fill_in(x,head(y),tail(y),t)',line) + call dcl_uproc(parser,'_fill_in(x,y,z,t)=prepend(fill_in(x.1,y,t),'//& + '_fill_in(tail(x),head(z),tail(z),t))',line) + call dcl_uproc(parser,'_fill_in(x,y:stretch_dim,z,t:''true)='//& + 'prepend(null,_fill_in(x,head(z),tail(z),t))',line) + call dcl_uproc(parser,'_fill_in(x,y:stretch_dim,z,t:''false)='//& + 'prepend(y,_fill_in(x,head(z),tail(z),t))',line) + call dcl_uproc(parser,'_fill_in(x:null,y:empty_head,z,t)=null',line) + call dcl_uproc(parser,& + '_fill_in(x:empty_head,y:stretch_dim,z,t)=prepend(null,_fill_in(x,head(z),tail(z),t))',line) + call dcl_uproc(parser,'_fill_in(x:empty_head,y,z,t)='//& + 'error_type() :test "Rank mismatch in slice" => ''false',line) + +write(*,'(a)') '// *******************************************************' +WRITE(*,'(A)') '// SUBSCRIPT INTERSECTION AND ALIASING' +write(*,'(a)') '// *******************************************************' + +write(*,'(a)') '// Test for intersection between two subscripts' call dcl_uproc(parser,'intersects(x:null,y:subs_dim)=''true',line) call dcl_uproc(parser,'intersects(x:subs_dim,y:null)=''true',line) call dcl_uproc(parser,'intersects(x:null,y:null)=''true',line) @@ -2068,13 +2164,14 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_intersects(x:subs,y:subs)=intersects(x,y)',line) call dcl_uproc(parser,'_intersects(x,y)=''false',line) - ! Alias checking +write(*,'(a)') '// Alias checking' + call dcl_uproc(parser,'PM__check_alias(arg...)=false',line) call dcl_uproc(parser,'PM__check_alias(i,j,x,y) {'//& 'test "Aliasing error between arguments #"++i++" and #"++j=>not _intersects(x,y) }',line) call dcl_uproc(parser,'PM__check_alias(i,j,x,y,arg...) {'//& 'if _intersects(x,y):PM__check_alias(i,j,arg...)}',line) - ! Combining subscripts +write(*,'(a)') '// Combining subscripts' call dcl_uproc(parser,'PM__cmbidx(x,y)=_cmb(x,y)',line) call dcl_uproc(parser,'PM__cmbidx(x,y,arg...)=PM__cmbidx(_cmb(x,y),arg...)',line) call dcl_type(parser,'_cmb_error is unique',line) @@ -2086,13 +2183,13 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_cmb2(x,y,z:''true)=x[y]',line) call dcl_uproc(parser,'_cmb2(x,y,z:''false)=_cmb_error',line) - ! ******************************************************* - ! ITERATION - SEQUENTIAL AND CONCURRENT - ! ******************************************************* +write(*,'(a)') '// *******************************************************' +WRITE(*,'(A)') '// ITERATION - SEQUENTIAL AND CONCURRENT' +write(*,'(a)') '// *******************************************************' - ! Iteration over mshape +write(*,'(a)') '// Iteration over mshape' - ! - first element +write(*,'(a)') '// - first element' call dcl_uproc(parser,'PM__first(d:int)=0,null,d>0',line) call dcl_uproc(parser,'PM__first(d:tuple1d)='//& 'i,s,e where i,s,e=PM__first(d.1)',line) @@ -2130,49 +2227,50 @@ subroutine sysdefs(parser) ' j5,s5,e5=PM__first(d.5),'//& 'j6,s6,e6=PM__first(d.6),j7,s7,e7=PM__first(d.7)',line) - ! - subsequent elements - call dcl_uproc(parser,'PM__next(d:int,g,i)=ii,null,iiint',& - op_do_loop,0,line,& + "do_loop",0,line,& proc_is_generator) call dcl_proc(parser,& '_doloop(int,int)->int,int',& - op_do_loop,0,line,& + "do_loop",0,line,& proc_is_generator) call dcl_proc(parser,& '_doloop(int,int,int)->int,int,int',& - op_do_loop,0,line,& + "do_loop",0,line,& proc_is_generator) call dcl_proc(parser,& '_doloop(int,int,int,int)->int,int,int,int',& - op_do_loop,0,line,& + "do_loop",0,line,& proc_is_generator) call dcl_proc(parser,& '_doloop(int,int,int,int,int)->int,int,int,int,int',& - op_do_loop,0,line,& + "do_loop",0,line,& proc_is_generator) call dcl_proc(parser,& '_doloop(int,int,int,int,int,int)->int,int,int,int,int,int',& - op_do_loop,0,line,& + "do_loop",0,line,& proc_is_generator) call dcl_proc(parser,& '_doloop(int,int,int,int,int,int,int)->'//& 'int,int,int,int,int,int,int',& - op_do_loop,0,line,& + "do_loop",0,line,& proc_is_generator) call dcl_uproc(parser,& '_elts(x:int)=i '//& @@ -2277,32 +2375,32 @@ subroutine sysdefs(parser) call dcl_proc(parser,& '_blockedloop(any)->int',& - op_blocked_loop,0,line,& + "blocked_loop",0,line,& proc_is_generator) call dcl_proc(parser,& '_blockedloop(any)->int,int',& - op_blocked_loop,0,line,& + "blocked_loop",0,line,& proc_is_generator) call dcl_proc(parser,& '_blockedloop(any)->int,int,int',& - op_blocked_loop,0,line,& + "blocked_loop",0,line,& proc_is_generator) call dcl_proc(parser,& '_blockedloop(any)->int,int,int,int',& - op_blocked_loop,0,line,& + "blocked_loop",0,line,& proc_is_generator) call dcl_proc(parser,& '_blockedloop(any)->int,int,int,int,int',& - op_blocked_loop,0,line,& + "blocked_loop",0,line,& proc_is_generator) call dcl_proc(parser,& '_blockedloop(any)->int,int,int,int,int,int',& - op_blocked_loop,0,line,& + "blocked_loop",0,line,& proc_is_generator) call dcl_proc(parser,& '_blockedloop(any)->'//& 'int,int,int,int,int,int,int',& - op_blocked_loop,0,line,& + "blocked_loop",0,line,& proc_is_generator) call dcl_uproc(parser,& '_belts(x,y:shape1d)=[i] where '//& @@ -2325,19 +2423,19 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& '_belts(x,y:shape7d)=[i,j,k,l,m,n,o] where '//& 'i,j,k,l,m,n,o=_blockedloop(PM__do_over(x,y))',line) - else +write(*,'(a)') 'PM__else' call dcl_uproc(parser,'PM__generate(x:dshape,n,s)=_elts(dims(x._tilesz),1,n)',line) call dcl_uproc(parser,'PM__generate(x:mshape,n,s)=_elts(dims(x),1,n)',line) call dcl_proc(parser,& '_iota(siz:int,start:int,finish:int,incr:int,totsiz:int)->int',& - op_iota,0,line,& + "iota",0,line,& proc_is_generator) call dcl_proc(parser,& '_iota(siz:int,start:int,finish:int,incr:int,'//& 'first:int,trunc:int,totsiz:int)->int',& - op_iota,0,line,& + "iota",0,line,& proc_is_generator) call dcl_uproc(parser,'_n(x:int)=x',line) call dcl_uproc(parser,& @@ -2380,16 +2478,16 @@ subroutine sysdefs(parser) 'where s5=s4*_n(x.5) where s4=s3*_n(x.4) '//& 'where s3=s2*_n(x.3) '//& 'where s2=s1*_n(x.2) where s1=siz*_n(x.1)',line) - endif +write(*,'(a)') 'PM__endif' call dcl_proc(parser,& - '_indices(any)->int',op_indices,0,line,0) + '_indices(any)->int',"indices",0,line,0) - ! ************************************** - ! ARRAYS - ! ************************************** +write(*,'(a)') '// **************************************' +WRITE(*,'(A)') '// ARRAYS' +write(*,'(a)') '// **************************************' - ! Array types +write(*,'(a)') '// Array types' call dcl_type(parser,& 'array(e,d:shape) is varray(e,d),farray(e,d)',line) call dcl_type(parser,'varray(e,d:shape) is'//& @@ -2400,48 +2498,52 @@ subroutine sysdefs(parser) 'array_slice(e^const any),array_slice(e^var any),'//& 'array_slice(e^invar any),array_slice(e^fix any)',line) - ! Array operations +write(*,'(a)') '// Array operations' call dcl_uproc(parser,'_arb(x:any^mshape)='//& '_get_aelem(x,0)',line) - call dcl_proc(parser,'size(x:any^mshape)->int',op_get_size,0,line,0) + write(*,'(a)') 'PM__if_compiling' + call dcl_uproc(parser,'size(x:any^mshape)=size(#x)',line) +write(*,'(a)') 'PM__else' + call dcl_proc(parser,'size(x:any^mshape)->int',"get_size",0,line,0) +write(*,'(a)') 'PM__endif' call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false)->PM__dim x,y',& - op_array,0,line,proc_needs_type) + "array",0,line,proc_needs_type) call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''true)->PM__vdim x,y',& - op_var_array,0,line,proc_needs_type) - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''true)->PM__invar_dim x,y',& - op_array,0,line,proc_needs_type) - call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''false)->PM__fix_dim x,y,z',& - merge(op_init_farray,op_array,pm_is_compiling),0,line,proc_needs_type) + "var_array",0,line,proc_needs_type) +!!$ call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''true)->PM__invar_dim x,y',& +!!$ "array",0,line,proc_needs_type) +!!$ call dcl_proc(parser,'_array(x:any,y:any,z:any,v:''false,i:''false)->PM__fix_dim x,y,z',& +!!$ merge("init_farray","array",pm_is_compiling),0,line,proc_needs_type) call dcl_proc(parser,& '_redim(x:any^any,y:any)->over x,y',& - op_redim,0,line,proc_needs_type) + "redim",0,line,proc_needs_type) call dcl_proc(parser,'PM__dim_noinit(x:any,y:any,z:any)->PM__dim x,y',& - op_array_noinit,0,line,proc_needs_type) + "array_noinit",0,line,proc_needs_type) call dcl_uproc(parser,'#%(x:invar any^any)=_array_shape(x <>)',line) call dcl_uproc(parser,'#%(x)=_get_shape(x)',line) call dcl_uproc(parser,'_get_shape(x)=#x',line) call dcl_uproc(parser,'#(x:any^any)=_array_shape(x)',line) - call dcl_proc(parser,'_array_shape(x:any^any)->#x',op_get_dom,0,line,0) + call dcl_proc(parser,'_array_shape(x:any^any)->#x',"get_dom",0,line,0) call dcl_uproc(parser,'dims(x:any^mshape)=dims(#x)',line) call dcl_proc(parser,'PM__extractelm(x:any^any)->%x',& - op_extractelm,0,line,0) + "extractelm",0,line,0) - call dcl_uproc(parser,'_get_elem(a:any^mshape,t:index)='//& + call dcl_uproc(parser,'element(a:any^mshape,t:index)='//& '_get_aelem(a,index(#(a),t))',line) call dcl_uproc(parser,'_set_elem(&a:any^mshape,v,t:index)'//& '{ PM__setaelem(&a,index(#(a),t),v) }',line) call dcl_uproc(parser,'_make_subref(a:any^mshape,t:index)='//& '_make_subref(a,index(#(a),t))',line) call dcl_proc(parser,'_make_subref(a:any^mshape,i:int)->%a',& - op_make_rf,0,line,0) + "make_rf",0,line,0) call dcl_proc(parser,'_get_aelem(x:any^any,y:int)->%x',& - op_array_get_elem,0,line,0) + "array_get_elem",0,line,0) call dcl_proc(parser,'PM__setaelem(&x:any^any,y:int,z:any)',& - op_array_set_elem,0,line,0) + "array_set_elem",0,line,0) - ! Linear index of tuple mshape (zero base,unit stride) +write(*,'(a)') '// Linear index of tuple mshape (zero base,unit stride)' call dcl_uproc(parser,'_indx(g:null,s)=''0',line) call dcl_uproc(parser,'_indx(g:range(int),s)=int(s)',line) call dcl_uproc(parser,'_indx(g:any_int,s)=int(s)',line) @@ -2502,7 +2604,8 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& 'index2point(i:int,s:tuple4d_of(int))='//& '[i1,i2,i3,i4]'//& - ' where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) where i3=j3-i4*_sz(s.3) where i4=j3/_sz(s.3)'//& + ' where i1=i-j2*_sz(s.1) where i2=j2-j3*_sz(s.2) '//& + ' where i3=j3-i4*_sz(s.3) where i4=j3/_sz(s.3)'//& ' where j3=j2/_sz(s.2) where j2=i/_sz(s.1)',line) call dcl_uproc(parser,& 'index2point(i:int,s:tuple5d_of(int))='//& @@ -2525,30 +2628,29 @@ subroutine sysdefs(parser) ' where j6=j5/_sz(s.5) where j5=j4/_sz(s.4) where j4=j3/_sz(s.3)'//& ' where j3=j2/_sz(s.2) where j2=i/_sz(s.1)',line) - ! ***************************************** - ! ARRAY TEMPLATES - ! ***************************************** +write(*,'(a)') '// Numeric array operations' + call dcl_uproc(parser,'-(x:num^any)={-xx:xx in x}',line) + call dcl_uproc(parser,'+(x:num^any,y:num)={xx+y:xx in x}',line) + call dcl_uproc(parser,'-(x:num^any,y:num)={xx-y:xx in x}',line) + call dcl_uproc(parser,'*(x:num^any,y:num)={xx*y:xx in x}',line) + call dcl_uproc(parser,'*(x:num,y:num^any)={x*yy:yy in y}',line) + call dcl_uproc(parser,'/(x:num^any,y:num)={xx/y:xx in x}',line) + +write(*,'(a)') '// *****************************************' +WRITE(*,'(A)') '// ARRAY TEMPLATES' +write(*,'(a)') '// *****************************************' - ! Array templates - call dcl_type(parser,'array_template(a,d:mshape or dshape,v:fix bool,i:fix bool,f:fix bool)'//& - ' is rec {_a:a,_d:d,_s:int,_v:v,_i:i=''false,_f:f=''false}',line) +write(*,'(a)') '// Array templates' + call dcl_type(parser,'array_template(a,d:mshape or dshape,v:fix bool)'//& + ' is rec {_a:a,_d:d,_s:int,_v:v}',line) call dcl_uproc(parser,& 'array(a:any,s:dshape)='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false}',line) + 'new array_template {_a=a,_d=s,_s=s._size,_v=''false}',line) call dcl_uproc(parser,& 'array(a:any,s:mshape(tuple(range(int))))='//& 'new array_template {_a=a,_d=s,_s=size(s),_v=''false}',line) - call dcl_uproc(parser,& - 'array(a:any,s:fix mshape(tuple(range(int))))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false,_f=''true}',line) call dcl_uproc(parser,& 'array(a:any,s:tuple(range(any_int)))=array(a,shape(s))',line) - call dcl_uproc(parser,'dim%(a,d)=array(a,d)',line) - call dcl_uproc(parser,'dim%(a,s:invar mshape(tuple(range(int))))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false,_i=''true}',line) - call dcl_uproc(parser,'dim%(a,sh:invar tuple(range(any_int)))='//& - 'new array_template {_a=a,_d=s,_s=size(s),_v=''false,_i=''true}'//& - 'where s=shape(sh)',line) call dcl_uproc(parser,& 'varray(a:any,s:mshape or dshape)='//& @@ -2559,7 +2661,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& 'varray(a:any,s:tuple(null))=varray(a,shape(map($_zero,s)))',line) - ! Treat a template as if it were an array +write(*,'(a)') '// Treat a template as if it were an array' call dcl_uproc(parser,'_arb(a:array_template)=a._a',line) call dcl_uproc(parser,'#(a:array_template(,mshape,))=a._d',line) call dcl_uproc(parser,'dims(a:array_template(,mshape,))=dims(a._d)',line) @@ -2568,26 +2670,22 @@ subroutine sysdefs(parser) ' new array_template { _a=a,_d=d,_s=size(d),_v=a._v}'//& ' check "New dshape does not have same size in redim"=>'//& ' size(d)==a._s',line) - call dcl_uproc(parser,'_get_elem(a:array_template,arg...:subs)=a._a',line) + call dcl_uproc(parser,'element(a:array_template,arg...:subs)=a._a',line) - ! Array creation from template - call dcl_uproc(parser,'PM__dup(a:array_template(,mshape,))='//& +write(*,'(a)') '// Array creation from template' + call dcl_uproc(parser,'PM__dup(a:array_template(,shape,))='//& '_array(PM__dup(a._a),a._d,int(a._s),a._v)',line) - call dcl_uproc(parser,'PM__dup(a:array_template(,mshape,,,''true))='//& - '_array(PM__dup(a._a),a._d,int(a._s),a._v,''false)',line) - call dcl_uproc(parser,'PM__dup(a:array_template(,mshape,,''true,''false))='//& - '_array(PM__dup(a._a),a._d,int(a._s),a._v,''true)',line) + call dcl_uproc(parser,'PM__dup(a:array_template(,shape,''true))='//& + '_array(PM__dup(a._a),PM__dup(a._d),PM__dup(int(a._s)),a._v)',line) call dcl_uproc(parser,'PM__do_dim(a:any,d:mshape)='//& '_array(a,d,size(d),''false)',& line) - !***************************************** - ! MATRIX AND VECTOR - ! ***************************************** - - +write(*,'(a)') '// *****************************************' +WRITE(*,'(A)') '// MATRIX AND VECTOR' +write(*,'(a)') '// *****************************************' call dcl_type(parser,'matrix_element is num,bool,...',line) call dcl_type(parser,'_matrix(t) is struct{use array:t}',line) @@ -2639,14 +2737,14 @@ subroutine sysdefs(parser) 'check_conform(x.array,y.array);'//& 'test "Cannot add zero size matrices"=>size(x)>0;'//& 'var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array));'//& - 'for xx in x.array, yy in y.array, zz in z.array:zz:=matrix_element_add(xx,yy) '//& + 'for xx in x.array, yy in y.array, zz in z.array:zz=matrix_element_add(xx,yy) '//& 'return z }',line) call dcl_uproc(parser,'-(x:matrix,y:matrix) {'//& 'check_conform(x.array,y.array);'//& 'test "Cannot add zero size matrices"=>size(x)>0;'//& 'var z=matrix(b,#x.array) where b,_=matrix_element_balance(_arb(x.array),_arb(y.array));'//& - 'for xx in x.array, yy in y.array, zz in z.array:zz:=matrix_element_subtract(xx,yy) '//& + 'for xx in x.array, yy in y.array, zz in z.array:zz=matrix_element_subtract(xx,yy) '//& 'return z }',line) call dcl_uproc(parser,'*(x:matrix,y:matrix) {'//& @@ -2656,13 +2754,13 @@ subroutine sysdefs(parser) 'for *i in sz,zz in z.array {'//& 'var s=matrix_element_zero(_arb(z.array));'//& 'foreach invar k in #(sx.1) {'//& - ' s:=matrix_element_add(s,matrix_element_multiply(x.array[i.1,sx.2[k]],y.array[sy.1[k],i.2]))};'//& - 'zz:=s};'//& + ' s=matrix_element_add(s,matrix_element_multiply(x.array[i.1,sx.2[k]],y.array[sy.1[k],i.2]))'//& + '};zz=s};'//& 'return z }',line) - ! ***************************************** - ! DISTRIBUTED SHAPE (DSHAPE) - ! ***************************************** +write(*,'(a)') '// *****************************************' +WRITE(*,'(A)') '// DISTRIBUTED SHAPE (DSHAPE)' +write(*,'(a)') '// *****************************************' call dcl_type(parser,'_distrb(extent:extent,dist:distr or null)',line) call dcl_type(parser,'_distrb(extent:extent,dist:distr) is ...,dshape(extent,dist)',line) @@ -2696,16 +2794,27 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'conform(x:dshape,y:dshape)=conform(x,y) and x.dist==y.dist',line) call dcl_uproc(parser,'_local_size(x:dshape)=size(x._tile)',line) - ! Get an element from a null tile - just pass index through - call dcl_uproc(parser,'_get_elem(x:null,y:tuple(index))=y',line) - call dcl_uproc(parser,'_get_elem(x:null,y:int)=y',line) +write(*,'(a)') '// Get an element from a null tile - just pass index through' + call dcl_uproc(parser,'element(x:null,y:tuple(index))=y',line) + call dcl_uproc(parser,'element(x:null,y:int)=y',line) call dcl_uproc(parser,'size(d:dshape)=d._size',line) - call dcl_uproc(parser,'#(d:dshape)=d',line) - - ! ***************************************** - ! DISTRIBUTED ARRAY AND SHAPE TEMPLATES - ! ***************************************** + call dcl_uproc(parser,'dims(d:dshape)=dims(d._mshape._extent)',line) + call dcl_uproc(parser,'#(d:dshape)=new dshape{_mshape=#d._mshape,'//& + 'dist=d.dist,_tile=d._tile,_tilesz=d._tilesz,_size=d._size,'//& + '_level=d._level,_dtag=d._dtag}',line) + call dcl_uproc(parser,'[](d:dshape,s:index)=d._mshape._extent[s]',line) + call dcl_uproc(parser,'[](d:dshape,s:subs)=_dshape_slice(d,ss)'//& + ' where ss=fill_in(#d._mshape._extent,s,''true){'//& + ' check_contains(#(d._mshape._extent),s)}',line) + call dcl_uproc(parser,'_dshape_slice(d:dshape,ss)=new dshape{_mshape=shape(#active_dims(ss)),'//& + 'dist=dist,_tile=tile,_tilesz=#tile,_size=size(tile),'//& + '_level=d._level,_dtag=d._dtag} where tile=element(dist,_shrd_node())'//& + ' where dist=sliced_distr(d.dist,ss)',line) + +write(*,'(a)') '// *****************************************' +WRITE(*,'(A)') '// DISTRIBUTED ARRAY AND SHAPE TEMPLATES' +write(*,'(a)') '// *****************************************' call dcl_type(parser,'darray_template(e,d,p,t) is '//& 'rec {_e:e,_d:d,_p:p,_t:t,_v}',line) @@ -2734,9 +2843,9 @@ subroutine sysdefs(parser) 'new dshape_template {_d=d,_p=distr,_t=topo}',line) - ! ***************************************** - ! DISTRIBUTED ARRAYS - ! ***************************************** +write(*,'(a)') '// *****************************************' +WRITE(*,'(A)') '// DISTRIBUTED ARRAYS' +write(*,'(a)') '// *****************************************' call dcl_uproc(parser,& 'PM__dup(d:darray_template) { '//& @@ -2748,7 +2857,7 @@ subroutine sysdefs(parser) ' size(#dist)<=shrd_nnode();'//& ' p=_shrd_node();'//& ' var elem=empty(dist);'//& - ' if p> {'//& + '_assign_internal_slice(&xx,x._s)}',line) + call dcl_uproc(parser,'_array_assign(&xx,x,v:''false)'//& '{check_assign_types(_arb(xx),x);_set_array(&xx,x)}',line) call dcl_uproc(parser,'_array_assign(&xx,x,v:''true)'//& '{check_conform(extent(#xx),extent(#x));'//& 'if _copy_array(&xx,x):_sync_messages(xx,x)}',line) + call dcl_uproc(parser,'_array_assign(&xx:array_slice,x:array_slice,v:''true)'//& + '{check_conform(extent(#xx),extent(#x));'//& + 'if _copy_array(&xx,x):_sync_messages(xx,x)}',line) call dcl_uproc(parser,'_array_assign(&xx:varray,x,v:''true) '//& '{_assign_element(&xx,x)}',line) call dcl_uproc(parser,'_array_assign(&xx:varray,x:array_template,v:''true) '//& '{_assign_element(&xx,PM__dup(x))}',line) - - call dcl_uproc(parser,'_set_slice(&x,a,y,b) {x[a]:=y[b]}',line) + + + write(*,'(a)') 'PM__if_compiling' + call dcl_uproc(parser,'_set_slice(&x,a,y,b) {foreach i in a,j in b:x[i]=y[j]}',line) +write(*,'(a)') 'PM__else' + call dcl_uproc(parser,'_set_slice(&x,a,y,b) {'//& + 'if size(a)>0:forall i in a,j in b{sync x[i]=y[j]}}',line) +write(*,'(a)') 'PM__endif' call dcl_type(parser,'_non_d is any^mshape,array_slice(any^mshape,)',line) call dcl_uproc(parser,'_set_array(&x:any^mshape,y)'//& - '{for i in x <>{ _assign(&i,y) } } ',line) + '{forall i in x { _assign(&i,y) } } ',line) call dcl_uproc(parser,'_set_array(&x:any^dshape,y)'//& '{_set_array(&^(PM__local(^(&x))),y)}',line) call dcl_uproc(parser,'_set_array(&x:array_slice(any^mshape,),y)'//& - '{for i in x._s <>{_set_elem(&x._a,y,i <>) }}',line) + '{forall i in x._s {_set_elem(&x._a,y,i <>) }}',line) call dcl_uproc(parser,'_set_array(&x:array_slice(any^dshape,),y){'//& 'tile=(#x._a)._tile;'//& 't=overlap(tile,((#x._a)#x._s));'//& - 'for i in t <>{ '//& + 'forall i in t { '//& ' _set_elem(&x._a,y,i <>) '//& '}}',line) call dcl_uproc(parser,'_copy_array(&a:_non_d,b:_non_d)'//& - '{for i in a, j in b <>{i:=j};return ''false}',line) + '{forall i in a, j in b {i=j};return ''false}',line) call dcl_uproc(parser,'_copy_array(&xx:any^dshape,x:_non_d) {'//& 'tile=(#xx)._tile;'//& - 'for i in tile <>{PM__setaelem(&xx,'//& - 'index(dims(tile),here),x[i] <>)};return ''false }',& + 'forall i in tile {PM__setaelem(&xx,'//& + 'index(dims(tile),here),x[(#x)[i]] <>)};return ''false }',& line) call dcl_uproc(parser,'_copy_array(&xx:array_slice(any^dshape,),x:_non_d) {'//& - 'tile=(#xx._a)._tile;subtile,subarray=overlap(tile,xx._s);'//& - 'for i in subtile,j in subarray <>{'//& - ' PM__setaelem(&xx._a,index(dims(tile),i),x[j] <>) };return ''false }',& + 'tile=(#xx._a)._tile;subtile,subarray=overlap(tile,(#xx._a)._mshape#xx._s);'//& + 'forall i in subtile,j in subarray {'//& + ' PM__setaelem(&xx._a,index(dims(tile),i),x[element(#x,active_dims(xx._s,j))] <>) };return ''false }',& line) call dcl_uproc(parser,'_copy_array(&a:_non_d,x:any^dshape) {'//& ' dist=(#x).dist; '//& ' foreach p in #(dist) {'//& - ' tile=_get_elem(dist,p);'//& + ' tile=element(dist,p);'//& ' i=index(dims(dist),p);'//& - ' if i==_this_node() { '//& - ' for kk in PM__local(x),j in tile <>{ '//& - ' var k=kk;PM__broadcast(&k,i);'//& - ' _set_elem(&a,k,j <>)'//& + ' if i==_shrd_node() { '//& + ' forall kk in PM__local(x),j in tile { '//& + ' var k=kk;_bcast_shared(&k,i);'//& + ' _set_elem(&a,k,(#a)[j] <>)'//& ' }'//& ' } else { '//& - ' for j in tile <>{ '//& + ' forall j in tile { '//& ' var k=_arb(a);'//& - ' PM__broadcast(&k,i);'//& - ' _set_elem(&a,k,j <>);'//& + ' _bcast_shared(&k,i);'//& + ' _set_elem(&a,k,(#a)[j] <>);'//& ' }'//& ' }'//& ' };return ''false}',& @@ -2905,17 +3038,17 @@ subroutine sysdefs(parser) ' foreach pp in overlap(nodes,nodes_for_grid(dist,xs)) {'//& ' p=nodes[pp];utile,elem=overlap(dist[nodes[p]],xs);'//& ' i=index(dims(dist),p);'//& - ' if i==_this_node() {'//& - ' for j in utile, jj in elem <>{ '//& - ' var k=_get_elem(PM__local(x._a),j); '//& - ' PM__broadcast(&k,i);'//& - ' _set_elem(&v,k,jj <>)'//& + ' if i==_shrd_node() {'//& + ' forall j in utile, jj in elem { '//& + ' var k=element(PM__local(x._a),j); '//& + ' _bcast_shared(&k,i);'//& + ' _set_elem(&v,k,element(#v,active_dims(x._s,jj)) <>)'//& ' }'//& ' } else { '//& - ' for j in elem <>{'//& + ' forall j in elem {'//& ' var k=_arb(x._a);'//& - ' PM__broadcast(&k,i);'//& - ' _set_elem(&v,k,j <>)'//& + ' _bcast_shared(&k,i);'//& + ' _set_elem(&v,k,element(#v,active_dims(x._s,j)) <>)'//& ' }'//& ' }'//& ' };return ''false}',& @@ -2928,190 +3061,129 @@ subroutine sysdefs(parser) call dcl_type(parser,'_comp is contains(array or *any or ^*(,,,,))',line) + call dcl_uproc(parser,'_copy_array(&xx:array_slice(any^dshape,),x:array_slice(any^dshape)) {'//& + '_copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s,'//& + ' PM__local(x._a),xd,xd._mshape#x._s,xd._tile)'//& + ' where xxd=#(xx._a),xd=#(x._a);return ''true}',line) + call dcl_uproc(parser,'_copy_array(&xx:any^dshape,x:array_slice(any^dshape)) {'//& + '_copy_darray_slice(&^(PM__local(^(&xx))),xxd,zero_base(xxd._mshape._extent),'//& + ' PM__local(x._a),xd,xd._mshape#x._s,xd._tile)'//& + ' where xxd=#xx,xd=#(x._a);return ''true}',line) + call dcl_uproc(parser,'_copy_array(&xx:array_slice(any^dshape,),x:any^dshape) {'//& + '_copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxd._mshape#xx._s,'//& + ' PM__local(x),xd,zero_base(xd._mshape._extent),xd._tile)'//& + ' where xxd=#(xx._a),xd=#x;return ''true}',line) call dcl_uproc(parser,'_copy_array(&xx:any^dshape,x:any^dshape) {'//& - 'newd=#xx;oldd=#x;'//& - 'foreach pp in nodes_for_grid(oldd.dist,newd._tile) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {tile=_get_elem(oldd.dist,p);'//& - ' _recv_slice(p,&xx,overlap(newd._tile,tile))}'//& - '};'//& - 'foreach pp in nodes_for_grid(newd.dist,oldd._tile) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {tile=_get_elem(newd.dist,p);'//& - ' _send_slice(p,x,overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newd._tile,oldd._tile);'//& - '_set_slice(&^(PM__local(^(&xx))),o,PM__local(x),oo);'//& - 'return ''true}',line) - - call dcl_uproc(parser,'_copy_array(&xx:array_slice(any^dshape,),'//& - 'x:array_slice(any^dshape,)) {'//& - 'newd=#(xx._a);oldd=#(x._a);'//& - 'xs=(#(x._a))._mshape#x._s;xxs=(#(xx._a))._mshape#xx._s;'//& + '_copy_darray_slice(&^(PM__local(^(&xx))),xxd,zero_base(xxd._mshape._extent),'//& + ' PM__local(x),xd,zero_base(xd._mshape._extent),xd._tile)'//& + ' where xxd=#xx,xd=#x;return ''true}',line) + + call dcl_uproc(parser,'_assign_internal_slice(&xx:array_slice(any^mshape),s) {'//& + 'x=new array_slice{_a=xx._a,_s=s};xx=x}',line) + call dcl_uproc(parser,'_assign_internal_slice(&xx:array_slice(any^dshape),s) {'//& + 'xxd=#(xx._a);xxs=xxd._mshape#xx._s;xs=xxd._mshape#s;ltile=intersect(xxd._tile,xs);ls=#ltile;'//& + 'var x=array(_arb(xx),ls);_set_slice(&x,ls,PM__local(xx._a),overlap(xxd._tile,ltile));'//& + '_copy_darray_slice(&^(PM__local(^(&xx._a))),xxd,xxs,'//& + ' x,xxd,xxd._mshape#s,ltile)}',line) + +!!$ call dcl_uproc(parser,'_copy_darray_slice(&xx,newd,xxs,x,oldd,xs,otile) {'//& +!!$ 'print_all(_sys_node()++"copy");_push_node_dist();'//& +!!$ 'oldpart,oldtile=overlap(xs,oldd._tile);'//& +!!$ 'newpart,newtile=overlap(xxs,newd._tile);'//& +!!$ 'print(_sys_node()++"R"++nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))));'//& +!!$ 'if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) {'//& +!!$ ' print("$$$$");'//& +!!$ ' p=index(dims(oldd.dist),pp);'//& +!!$ ' if p/=_this_node() {'//& +!!$ ' tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p))));'//& +!!$ ' ov=overlap(newd._tile,tile);print_all(_sys_node()++"recv"++size(ov)++"$"++p);'//& +!!$ ' if size(ov)>0:_recv_slice(p,&xx,ov)}'//& +!!$ '};'//& +!!$ 'print(_sys_node()++"xx"++xxs++xs);'//& +!!$ 'print(_sys_node()++"send consider"++xxs++element(xxs,active_dims(xs,oldpart))++xs);'//& +!!$ 'print(_sys_node()++"send too"++nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))));'//& +!!$ 'print(_sys_node()++"node"++_shrd_node()++"£"++_this_node());'//& +!!$ 'if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) {'//& +!!$ ' p=index(dims(newd.dist),pp);'//& +!!$ ' if p/=_this_node() {'//& +!!$ ' tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p))));'//& +!!$ ' ov=overlap(otile,tile);print_all(_sys_node()++"send"++size(ov)++"$"++p);if size(ov)>0:_send_slice(p,x,ov);'//& +!!$ 'print(_sys_node()++"sent")}};'//& +!!$ 'if size(newpart)>0 and size(oldpart)>0 {print(_sys_node()++"%"++newpart++oldpart);'//& +!!$ 'oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart));'//& +!!$ '_set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o))'//& +!!$ ';print("sliceset")};PM_pop_node(newd)}',line) + + + call dcl_uproc(parser,'_copy_darray_slice(&xx,newd,xxs,x,oldd,xs,otile) {'//& + '_push_node_dist();'//& 'oldpart,oldtile=overlap(xs,oldd._tile);'//& 'newpart,newtile=overlap(xxs,newd._tile);'//& - 'foreach pp in nodes_for_grid(oldd.dist,_get_elem(xs,newpart)) {'//& + 'if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) {'//& ' p=index(dims(oldd.dist),pp);'//& ' if p/=_this_node() {'//& - ' tile=_get_elem(xxs,overlap(xs,_get_elem(oldd.dist,p)));'//& - ' _recv_slice(p,&^(PM__local(^(&xx._a))),overlap(newd._tile,tile))}'//& + ' tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p))));'//& + ' ov=overlap(newd._tile,tile);'//& + ' if size(ov)>0:_recv_slice(p,&xx,ov)}'//& '};'//& - 'foreach pp in nodes_for_grid(newd.dist,_get_elem(xxs,oldpart)) {'//& + 'if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) {'//& ' p=index(dims(newd.dist),pp);'//& ' if p/=_this_node() {'//& - ' tile=_get_elem(xs,overlap(xxs,_get_elem(newd.dist,p)));'//& - ' _send_slice(p,PM__local(x._a),overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newpart,oldpart);'//& - '_set_slice(&^(PM__local(^(&xx._a))),_get_elem(newtile,o),PM__local(x._a),'//& - ' _get_elem(oldtile,oo));'//& - 'return ''true}',line) - - call dcl_uproc(parser,'_copy_array(&xx:any^dshape,x:array_slice(any^dshape,)) {'//& - 'newd=#(xx);oldd=#(x._a);'//& - 'xs=(#(x._a))._mshape#x._s;'//& - 'oldpart,oldtile=overlap(xs,oldd._tile);'//& - 'foreach pp in nodes_for_grid(oldd.dist,_get_elem(xs,newd._tile)) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=overlap(xs,_get_elem(oldd.dist,p));'//& - ' _recv_slice(p,&^(PM__local(^(&xx))),overlap(newd._tile,tile))}'//& - '};'//& - 'foreach pp in nodes_for_grid(newd.dist,oldpart) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xs,_get_elem(newd.dist,p));'//& - ' _send_slice(p,PM__local(x._a),overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newd._tile,oldpart);'//& - '_set_slice(&^(PM__local(^(&xx))),o,PM__local(x._a),'//& - ' _get_elem(oldtile,oo));'//& - 'return ''true}',line) - - call dcl_uproc(parser,'_copy_array(&xx:array_slice(any^dshape,),x:any^dshape) {'//& - 'newd=#(xx._a);oldd=#x;'//& - 'xxs=(#(xx._a))._mshape#xx._s;'//& - 'newpart,newtile=overlap(xxs,newd._tile);'//& - 'foreach pp in nodes_for_grid(oldd.dist,newpart) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xxs,_get_elem(oldd.dist,p));'//& - ' _recv_slice(p,&^(PM__local(^(&xx._a))),overlap(newd._tile,tile))}'//& - '};'//& - 'foreach pp in nodes_for_grid(newd.dist,_get_elem(xxs,oldd._tile)) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=overlap(xxs,_get_elem(newd.dist,p));'//& - ' _send_slice(p,PM__local(x),overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newpart,oldd._tile);'//& - '_set_slice(&^(PM__local(^(&xx._a))),_get_elem(newtile,o),PM__local(x),'//& - ' oo);'//& - 'return ''true}',line) + ' tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p))));'//& + ' ov=overlap(otile,tile);if size(ov)>0:_send_slice(p,x,ov);'//& + '}};'//& + 'if size(newpart)>0 and size(oldpart)>0 {'//& + 'oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart));'//& + '_set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o))'//& + '};PM_pop_node(newd)}',line) - call dcl_uproc(parser,'_copy_array(&xx:_comp^dshape,x:any^dshape) {'//& - 'newd=#xx;oldd=#x;'//& - 'foreach pp in nodes_for_grid(newd.dist,oldd._tile) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {tile=_get_elem(newd.dist,p);'//& - ' _send_slice(p,PM__local(x),overlap(oldd._tile,tile))}'//& - '};'//& - 'foreach pp in nodes_for_grid(oldd.dist,newd._tile) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {tile=_get_elem(oldd.dist,p);'//& - ' _recv_slice_sync(p,&^(PM__local(^(&xx))),overlap(newd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newd._tile,oldd._tile);'//& - '_set_slice(&^(PM__local(^(&xx))),o,PM__local(x),oo);'//& - 'return ''true}',line) - - call dcl_uproc(parser,'_copy_array(&xx:array_slice(_comp^dshape,),'//& - 'x:array_slice(any^dshape,)) {'//& - 'newd=#(xx._a);oldd=#(x._a);'//& - 'xs=(#(x._a))._mshape#x._s;xxs=(#(xx._a))._mshape#xx._s;'//& + call dcl_uproc(parser,'_copy_darray_slice(&xx:_comp^any,newd,xxs,x,oldd,xs,otile) {'//& + '_push_node_dist();'//& 'oldpart,oldtile=overlap(xs,oldd._tile);'//& 'newpart,newtile=overlap(xxs,newd._tile);'//& - 'foreach pp in nodes_for_grid(newd.dist,_get_elem(xxs,oldpart)) {'//& + 'if size(oldpart)>0:foreach pp in nodes_for_grid(newd.dist,element(xxs,active_dims(xs,oldpart))) {'//& ' p=index(dims(newd.dist),pp);'//& ' if p/=_this_node() {'//& - ' tile=_get_elem(xs,overlap(xxs,_get_elem(newd.dist,p)));'//& - ' _send_slice(p,PM__local(x._a),overlap(oldd._tile,tile))}'//& + ' tile=element(xs,active_dims(xxs,overlap(xxs,element(newd.dist,p))));'//& + ' ov=overlap(otile,tile);if size(ov)>0:_send_slice(p,x,ov)}'//& '};'//& - 'o,oo=overlap(newpart,oldpart);'//& - '_set_slice(&^(PM__local(^(&xx._a))),_get_elem(newtile,o),PM__local(x._a),'//& - ' _get_elem(oldtile,oo));'//& - 'foreach pp in nodes_for_grid(oldd.dist,_get_elem(xs,newpart)) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xxs,overlap(xs,_get_elem(oldd.dist,p)));'//& - ' _recv_slice_sync(p,&xx._a,overlap(newd._tile,tile))}'//& - '};'//& - 'return ''true}',line) - - call dcl_uproc(parser,'_copy_array(&xx:_comp^dshape,x:array_slice(any^dshape,)) {'//& - 'newd=#xx;oldd=#(x._a);'//& - 'xs=(#(x._a))._mshape#x._s;'//& - 'oldpart,oldtile=overlap(xs,oldd._tile);'//& - 'foreach pp in nodes_for_grid(newd.dist,oldpart) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xs,_get_elem(newd.dist,p));'//& - ' _send_slice(p,PM__local(x._a),overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newd._tile,oldpart);'//& - '_set_slice(&^(PM__local(^(&xx))),o,PM__local(x._a),'//& - ' _get_elem(oldtile,oo));'//& - 'foreach pp in nodes_for_grid(oldd.dist,_get_elem(xs,newd._tile)) {'//& + 'if size(newpart)>0 and size(oldpart)>0 {'//& + 'oo,o=overlap(active_dims(xxs,newpart),active_dims(xs,oldpart));'//& + '_set_slice(&xx,element(map($_xp,xxs,newtile),oo),x,element(map($_xp,xs,oldtile),o))};'//& + 'if size(newpart)>0:foreach pp in nodes_for_grid(oldd.dist,element(xs,active_dims(xxs,newpart))) {'//& ' p=index(dims(oldd.dist),pp);'//& ' if p/=_this_node() {'//& - ' tile=overlap(xs,_get_elem(oldd.dist,p));'//& - ' _recv_slice_sync(p,&^(PM__local(^(&xx))),overlap(newd._tile,tile))}'//& + ' tile=element(xxs,active_dims(xs,overlap(xs,element(oldd.dist,p))));'//& + ' ov=overlap(newd._tile,tile);'//& + ' if size(ov)>0:_recv_slice_sync(p,&xx,ov)}'//& '};'//& - 'return ''true}',line) + 'PM_pop_node(newd)}',line) - call dcl_uproc(parser,'_copy_array(&xx:array_slice(_comp^dshape,),x:any^dshape) {'//& - 'newd=#(xx._a);oldd=#x;'//& - 'xxs=(#(xx._a))._mshape#xx._s;'//& - 'newpart,newtile=overlap(xxs,newd._tile);'//& - 'foreach pp in nodes_for_grid(newd.dist,_get_elem(xxs,oldd._tile)) {'//& - ' p=index(dims(newd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=overlap(xxs,_get_elem(newd.dist,p));'//& - ' _send_slice(p,PM__local(x),overlap(oldd._tile,tile))}'//& - '};'//& - 'o,oo=overlap(newpart,oldd._tile);'//& - '_set_slice(&^(PM__local(^(&xx._a))),_get_elem(newtile,o),PM__local(x),'//& - ' oo);'//& - 'foreach pp in nodes_for_grid(oldd.dist,newpart) {'//& - ' p=index(dims(oldd.dist),pp);'//& - ' if p/=_this_node() {'//& - ' tile=_get_elem(xxs,_get_elem(oldd.dist,p));'//& - ' _recv_slice_sync(p,&^(PM__local(^(&xx._a))),overlap(newd._tile,tile))}'//& - '};'//& - 'return ''true}',line) - - !************************************************* - ! REFERENCES (SUBSCRIPTS AND SLICES) - !************************************************* + call dcl_uproc(parser,'_xp(x:single_point,y)=single_point(low(y))',line) + call dcl_uproc(parser,'_xp(x,y)=y',line) + +write(*,'(a)') '// *************************************************' +WRITE(*,'(A)') '// REFERENCES (SUBSCRIPTS AND SLICES)' +write(*,'(a)') '// *************************************************' - ! Reference type for & args +write(*,'(a)') '// Reference type for & args' call dcl_type(parser,'PM__reftype(x) is x,^shared(x,,,,)',line) - ! Support for internal ^(...) reference type - call dcl_proc(parser,'_v1(x:any)->PM__d1 x',op_elem,1,line,0) - call dcl_proc(parser,'_v2(x:any)->PM__d2 x',op_elem,2,line,0) - call dcl_proc(parser,'_v3(x:any)->PM__d3 x',op_elem,3,line,0) - call dcl_proc(parser,'_v4(x:any)->PM__d4 x',op_elem,4,line,0) - call dcl_proc(parser,'_v5(x:any)->PM__d5 x',op_elem,5,line,0) - - call dcl_proc(parser,'_v1%(r:any,s:any,h:any,x:any)->PM__d1% x',op_elem,1,line,0) - call dcl_proc(parser,'_v2%(r:any,s:any,h:any,x:any)->PM__d2% x',op_elem,2,line,0) - call dcl_proc(parser,'_v3%(r:any,s:any,h:any,x:any)->PM__d3% x',op_elem,3,line,0) - call dcl_proc(parser,'_v4%(r:any,s:any,h:any,x:any)->PM__d4% x',op_elem,4,line,0) - call dcl_proc(parser,'_v5%(r:any,s:any,h:any,x:any)->PM__d5% x',op_elem,5,line,0) +write(*,'(a)') '// Support for internal ^(...) reference type' + call dcl_proc(parser,'_v1(x:any)->PM__d1 x',"elem",1,line,0) + call dcl_proc(parser,'_v2(x:any)->PM__d2 x',"elem",2,line,0) + call dcl_proc(parser,'_v3(x:any)->PM__d3 x',"elem",3,line,0) + call dcl_proc(parser,'_v4(x:any)->PM__d4 x',"elem",4,line,0) + call dcl_proc(parser,'_v5(x:any)->PM__d5 x',"elem",5,line,0) + + call dcl_proc(parser,'_v1%(r:any,s:any,h:any,x:any)->PM__d1% x',"elem",1,line,0) + call dcl_proc(parser,'_v2%(r:any,s:any,h:any,x:any)->PM__d2% x',"elem",2,line,0) + call dcl_proc(parser,'_v3%(r:any,s:any,h:any,x:any)->PM__d3% x',"elem",3,line,0) + call dcl_proc(parser,'_v4%(r:any,s:any,h:any,x:any)->PM__d4% x',"elem",4,line,0) + call dcl_proc(parser,'_v5%(r:any,s:any,h:any,x:any)->PM__d5% x',"elem",5,line,0) - ! Right hand side references +write(*,'(a)') '// Right hand side references' call dcl_uproc(parser,'_make_null(x)=null',line) call dcl_uproc(parser,& 'PM__subref(x,t)=error_type() check "Incorrect type in subscript"=>''false',line) @@ -3120,9 +3192,9 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__subref(x,t:null)=PM__subref(x,map($_make_null,#x))',line) call dcl_uproc(parser,'PM__subref(x:^*(,,,,),t:null)='//& 'PM__subref(x,map($_make_null,#_v1(x)))',line) - call dcl_uproc(parser,'_subref(x:any^mshape,t:index)=_get_elem(x,t)',line) - call dcl_uproc(parser,'_subref(x:any^any,t:subs)=new array_slice {_a=x,_s=fill_in(#x,t)}',line) - call dcl_uproc(parser,'_subref(x:array_slice(any^mshape,),t:index)=_get_elem(x._a,x._s[t])',line) + call dcl_uproc(parser,'_subref(x:any^mshape,t:index)=element(x,t)',line) + call dcl_uproc(parser,'_subref(x:any^any,t:subs)=new array_slice {_a=x,_s=fill_in(#x,t,''true)}',line) + call dcl_uproc(parser,'_subref(x:array_slice(any^mshape,),t:index)=element(x._a,x._s[t])',line) call dcl_uproc(parser,'_subref(x:array_slice,t:subs)=new array_slice {_a=x._a,_s=x._s[t]}',line) call dcl_uproc(parser,'_subref(x:any^dshape,t:index)='//& ' PM__ref(_arb(x),x,i,p,_s_ref)'//& @@ -3133,7 +3205,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_subref(a,t)=$[](a,t)',line) call dcl_uproc(parser,'[](a:array,arg...)=PM__getref(PM__subref(a,_tup(arg...)))',line) - ! Left hand side references +write(*,'(a)') '// Left hand side references' call dcl_uproc(parser,& 'PM__sublhsamp(x,t)=error_type() check "Incorrect type in subscript"=>''false',line) call dcl_uproc(parser,'PM__sublhsamp(x,t:subs)'//& @@ -3153,7 +3225,7 @@ subroutine sysdefs(parser) 'PM__sublhs(x,map($_make_null,#_v1(x)))',line) call dcl_uproc(parser,'_sublhs(x:any^mshape,t:index)=_make_subref(x,t)',line) call dcl_uproc(parser,& - '_sublhs(x:any^any,t:subs)=new array_slice {_a=x,_s=fill_in(#x,t)}',line) + '_sublhs(x:any^any,t:subs)=new array_slice {_a=x,_s=fill_in(#x,t,''true)}',line) call dcl_uproc(parser,'_sublhs(x:array_slice(any^mshape,),t:index)='//& '_make_subref(x._a,x._s[t])',line) call dcl_uproc(parser,'_sublhs(x:array_slice,t:subs)='//& @@ -3166,31 +3238,33 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'[](&a:array,v,arg...)'//& '{ PM__assign(&^(PM__sublhs(^(&a),_tup(arg...))),v)}',line) - ! Realise a reference +write(*,'(a)') '// Realise a reference' call dcl_uproc(parser,'PM__valref(x)=x',line) call dcl_uproc(parser,'PM__valref(x:^*(,,,,)) {'//& - ' var v=_v1(x);if _v4(x)==_this_node() { v:=_getref(x,null)};'//& - ' PM__broadcast(&v,_v4(x));return v }',line) - !call dcl_uproc(parser,'PM__getref(x:^!(,,,,))=PM__valref(x)',line) + ' var v=_v1(x);if _v4(x)==_shrd_node() { v=_getref(x,null)};'//& + ' _bcast_shared(&v,_v4(x));return v }',line) +!write(*,'(a)') '// call dcl_uproc(parser,'PM__getref(x:^!(,,,,))=PM__valref(x)',line)' - ! Assign to a reference +write(*,'(a)') '// Assign to a reference' call dcl_uproc(parser,'PM__assign(&x:^*(,,,,),y) {'//& 'check_assign_types(_v1(^(&x)),y);'//& - 'if _v4(^(&x))==_this_node() { PM__assign(&^(_getlhs(^(&x),null)),y) }}',line) - - ! ************************************************************* - ! DISTRIBUTED REFERENCES - ! ************************************************************* - - ! Distributed reference is an internal compiler type - ! ^ ( value or value_example, parent, subscript, node or [indexed_dim,dshape] , mode) - ! mode is: - ! null -- local reference - ! _s_ref -- shrd index on darray, only shrd/indexed otherwise - ! _sp_ref -- shrd index on darray, some priv after (or before) - ! _d_ref -- indexed index on darray, shrd/indexed otherwise - ! _dp_ref -- indexed index on darray, some priv after (or before) - ! _p_ref -- priv index on darray and possibly elsewhere + 'if _v4(^(&x))==_shrd_node() { PM__assign(&^(_getlhs(^(&x),null)),y) }}',line) + call dcl_uproc(parser,'PM__assign(&x:^*(,,,,),y,p:assignment_operator) {'//& + 'if _v4(^(&x))==_shrd_node() { PM__assign(&^(_getlhs(^(&x),null)),p.(PM__valref(x),y)) }}',line) + +write(*,'(a)') '// *************************************************************' +WRITE(*,'(A)') '// DISTRIBUTED REFERENCES' +write(*,'(a)') '// *************************************************************' + +write(*,'(a)') '// Distributed reference is an internal compiler type' +write(*,'(a)') '// ^ ( value or value_example, parent, subscript, node or [indexed_dim,dshape] , mode)' +write(*,'(a)') '// mode is:' +write(*,'(a)') '// null -- local reference' +write(*,'(a)') '// _s_ref -- shrd index on darray, only shrd/indexed otherwise' +write(*,'(a)') '// _sp_ref -- shrd index on darray, some priv after (or before)' +write(*,'(a)') '// _d_ref -- indexed index on darray, shrd/indexed otherwise' +write(*,'(a)') '// _dp_ref -- indexed index on darray, some priv after (or before)' +write(*,'(a)') '// _p_ref -- priv index on darray and possibly elsewhere' call dcl_type(parser,'_s_ref is unique',line) call dcl_type(parser,'_sp_ref is unique',line) @@ -3199,9 +3273,9 @@ subroutine sysdefs(parser) call dcl_type(parser,'_p_ref is unique',line) call dcl_proc(parser,& - '_import_dref%(r:any,s:any,h:any,x:any)->^^x',op_import_dref,0,line,0) + '_import_dref%(r:any,s:any,h:any,x:any)->^^x',"import_dref",0,line,0) - ! Some trivial referencing cases +write(*,'(a)') '// Some trivial referencing cases' call dcl_uproc(parser,'PM__sublhsamp%(x,t:subs)=PM__sublhs%(x,t)',line) call dcl_uproc(parser,'PM__sublhsamp%(x:any^dshape,t:subs)'//& ' {test "Cannot have subscript of a distributed array in ""&"" argument"=>''false;'//& @@ -3220,16 +3294,16 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__sublhs%(region:mshape,x:priv,y)=PM__sublhs(x,y):'//& 'test """sync"" assignment updating a private variable"=>''false',line) call dcl_uproc(parser,'PM__sublhs%(region:mshape,x,y)=PM__sublhs(x,y)',line) - call dcl_uproc(parser,'PM__subref%(region:mshape,x:any^dshape,y)=_arb(x)'//& - ':test "Cannot subscript distributed array in ""for <>""" => ''false',line) - call dcl_uproc(parser,'PM__subref%(region:mshape,x:invar any^dshape,y:invar indexed)='//& - '_arb(x)'//& - ':test "Cannot subscript distributed array in ""for <>""" => ''false',line) +!!$ call dcl_uproc(parser,'PM__subref%(region:mshape,x:any^dshape,y)=_arb(x)'//& +!!$ ':test "Cannot subscript distributed array in ""forall""" => ''false',line) +!!$ call dcl_uproc(parser,'PM__subref%(region:mshape,x:invar any^dshape,y:invar indexed)='//& +!!$ '_arb(x)'//& +!!$ ':test "Cannot subscript distributed array in ""forall""" => ''false',line) call dcl_uproc(parser,'PM__sublhs%(region:mshape,x:any^dshape,y)=PM__subref%(x,y)',line) - call dcl_uproc(parser,'PM__subref%(x,y:indexed_dim)=PM__subref%(x,tuple(y <>))',line) + call dcl_uproc(parser,'PM__subref%(x,y:indexed_dim)=PM__subref%(x,_tup%(y))',line) - ! Reference of non-distributed array with priv or indexed subscript +write(*,'(a)') '// Reference of non-distributed array with priv or indexed subscript' call dcl_uproc(parser,'PM__subref%(x:invar any^mshape,t:index)'//& '{tt=_tup(t);check_contains(#x,tt);i=index(#x,tt);'//& 'return PM__dref(_get_aelem(x,i),x,i,null,null)}',line) @@ -3242,9 +3316,9 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__subref%(x,t)='//& 'PM__dref($[](x,t),x,t,null,null)',line) - ! Subscript or slice of distributed array - call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar index) <>'//& - '{tt=_tup(t <>);check_contains(#(x),tt);'//& +write(*,'(a)') '// Subscript or slice of distributed array' + call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar index) complete <>'//& + '{tt=_tup(t);check_contains(#(x),tt);'//& 'return PM__dref(_arb(x),x,i,p,_s_ref) '//& 'where p,i=node_and_index((#x).dist,(#x)._mshape#tt)}',line) call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:index)'//& @@ -3255,16 +3329,20 @@ subroutine sysdefs(parser) '{tt=_tup(t);check_contains(#(x),tt);var xx=varray(_arb(x),empty(#x));'//& 'return PM__drefs(xx,x,tt,p,_p_ref) '//& 'where p=nodes_for_grid((#x).dist,tt)}',line) - call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar indexed) <> {'//& + call dcl_uproc(parser,'PM__subref%(x:shared any^dshape,t:invar indexed) cond =PM__subref%(x,*t)',line) + call dcl_uproc(parser,& + 'PM__subref%(region:shape(,blocked_distr),x:shared any^dshape(,blocked_distr),t:invar indexed) uncond {'//& 'check_contains(#x,_dmap(t,here));'//& 'return PM__drefi(_arb(x),x,tt,[tt,#x],_d_ref) where tt=_tup(t)}',line) + call dcl_uproc(parser,& + 'PM__subref%(x:shared any^dshape,t:invar indexed) uncond =PM__subref%(x,*t)',line) - ! Subscript or slice of non-distristuted array which is itself result of variant slice +write(*,'(a)') '// Subscript or slice of non-distristuted array which is itself result of variant slice' call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:index)'//& '{tt=_tup(t);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt)'//& 'return PM__dref(_get_aelem(_v1%(x),i),x,i,null,null)}',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar index){'//& - 'tt=_tup(t <>);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt);'//& + 'tt=_tup%(t);check_contains(#_v1%(x),tt);i=index(#(_v1%(x)),tt);'//& 'return PM__drefi(_get_aelem(_v1%(x),i),x,t,null,null)}',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:subs) {'//& 'tt=_tup(t);check_contains(#(_v1%(x)),tt);'//& @@ -3272,7 +3350,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^mshape,,,null,null),t:invar indexed)='//& 'PM__subref%(x,_dmap(t,here))',line) - ! Subscript or slice of darray which is itself the result of a priv subscript +write(*,'(a)') '// Subscript or slice of darray which is itself the result of a priv subscript' call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^dshape,,,null,null),t:index)'//& '{tt=_tup(t);check_contains(#_v1%(x),tt);'//& 'return PM__dref(_arb(_v1%(x)),_v2%(x),i,p,_p_ref) '//& @@ -3284,20 +3362,20 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^dshape,,,null,null),t:invar indexed)='//& 'PM__subref%(x,_dmap(t,here))',line) - ! Subscript of a priv slice +write(*,'(a)') '// Subscript of a priv slice' call dcl_uproc(parser,'PM__subref%(x:priv ^#(,,,null,null),t:subs)='//& 'PM__subref%(_v2%(x),_v3%(x)[_tup(t)])',line) call dcl_uproc(parser,'PM__subref%(x:priv ^#(,,,null,null),t:invar indexed)='//& 'PM__subref%(_v2%(x),_v3%(x)[tt]) where tt=_dmap(t,here)',line) - ! Subscript of distributed reference +write(*,'(a)') '// Subscript of distributed reference' call dcl_uproc(parser,'_arb%(x:partial)=_arb(x)',line) - call dcl_uproc(parser,'_arb%(x:complete)=_arb(x <>)',line) - call dcl_uproc(parser,'_arb%(x:chan)=_arb(x <>)',line) - call dcl_uproc(parser,'_arb%(x:invar)=_arb(x <>)',line) + call dcl_uproc(parser,'_arb%(x:complete) complete <>=_arb(x)',line) + call dcl_uproc(parser,'_arb%(x:chan) complete <>=_arb(x)',line) + call dcl_uproc(parser,'_arb%(x:invar) complete <>=_arb(x)',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:invar subs)='//& - 'PM__drefi(_arb%(_v1%(x)),x,_tup(t <>))',line) + 'PM__drefi(_arb%(_v1%(x)),x,_tup%(t))',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,),t:priv subs)='//& 'PM__dref(_arb%(_v1%(x)),x,_tup(t))',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_s_ref),t:priv subs)='//& @@ -3309,11 +3387,11 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar indexed)='//& 'PM__drefi(_arb%(_v1%(x)),x,_tup(t))',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:invar subs)='//& - 'PM__drefi(_arb%(_v1%(x)),x,_tup(t <>))',line) + 'PM__drefi(_arb%(_v1%(x)),x,_tup%(t))',line) call dcl_uproc(parser,'PM__subref%(x:priv ^*(any^any,,,,_d_ref),t:priv subs)='//& 'PM__dref(_arb%(_v1%(x)),x,_tup(t),_v4%(x),_dp_ref)',line) - ! Node .[] subscript of distributed array +write(*,'(a)') '// Node .[] subscript of distributed array' call dcl_type(parser,'_lcl is unique{_LCL}',line) call dcl_uproc(parser,'PM__nodelhs%(x,y)=PM__noderef%(x,y)',line) call dcl_uproc(parser,'PM__noderef%(region:dshape,x:shared any^dshape,y:invar null)='//& @@ -3351,13 +3429,13 @@ subroutine sysdefs(parser) ' test "Incorrect "".[]"" subscript"=>''false'//& '}}',line) - ! May need to cap off reference with here +write(*,'(a)') '// May need to cap off reference with here' call dcl_type(parser,'_here(t) is rec {here:t}',line) call dcl_uproc(parser,'_cap%(x,h)<>=x',line) call dcl_uproc(parser,'_cap%(x:contains(indexed),h)<>=PM__dref(_v1%(x),x,new _here {here=h})',line) call dcl_uproc(parser,'_capn%(x,h)<>=PM__dref(_v1%(x),x,new _here {here=h})',line) - ! Treat @ variables differently only for limited circumstances in drefs +write(*,'(a)') '// Treat ! variables differently only for limited circumstances in drefs' call dcl_uproc(parser,'_drat(at,tile,t)=''false',line) call dcl_uproc(parser,'_drat(at:''true,tile:tuple(range or block_seq),t:indexed and _dr)=''true',line) call dcl_type(parser,'_di(n) is indexed_dim(''1,''1,,n) or int',line) @@ -3367,7 +3445,7 @@ subroutine sysdefs(parser) '[_di(''1),_di(''2),_di(''3),_di(''4),_di(''5),_di(''6)],'//& '[_di(''1),_di(''2),_di(''3),_di(''4),_di(''5),_di(''6),_di(''7)]',line) - ! Resolve a distributed reference +write(*,'(a)') '// Resolve a distributed reference' call dcl_uproc(parser,'PM__getref%(x,at)=x',line) call dcl_uproc(parser,'PM__getref%(x:priv ^*(,,,null,null),at)=_v1%(x)',line) call dcl_uproc(parser,'PM__getref%(x:priv ^*(,,,int,_p_ref),at) {'//& @@ -3379,40 +3457,40 @@ subroutine sysdefs(parser) ' d=#region._mshape;a={_getref(_import_dref%(x),j): j in d};'//& ' p=index(dims(region.dist),node);'//& ' _send_slice(p,a,region.dist[node])}}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) <> {'//& - 'chan var xx=_v1%(x);_getref_s(&xx@,region,^^(x),at <>);_bcast_shared(&xx);return xx}',line) - call dcl_uproc(parser,'_getref_s(&xx,region,x,at) {'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,int,_s_ref),at:invar) complete <> {'//& + 'chan var xx=_v1%(x);_getref_s%(&xx!,^^(x),at);_bcast_shared(&xx);return xx}',line) + call dcl_uproc(parser,'_getref_s%(&xx:invar,x:invar,at:invar) PM__node {'//& 'PM__head_node{_irecv(_v4(x),&xx)};'//& '_scatter(x,region);'//& '_sync_messages(xx,x)}',line) - call dcl_uproc(parser,'PM__getref%(x:complete _comp and ^*(,,,int,_s_ref),at:invar) <>{'//& - 'chan var xx=_v1%(x);_getref_sc(&xx@,region,^^(x),at <>);_bcast_shared(&xx);return xx}',line) - call dcl_uproc(parser,'_getref_sc(&xx,region,x,at) {'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(_comp,,,int,_s_ref),at:invar) complete <>{'//& + 'chan var xx=_v1%(x);_getref_sc%(&xx!,^^(x),at);_bcast_shared(&xx);return xx}',line) + call dcl_uproc(parser,'_getref_sc%(&xx:invar,x:invar,at:invar) PM__node {'//& '_scatter(x,region);PM__head_node{_recv(_v4(x),&xx)};'//& '_sync_messages(xx,x)}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) <> {'//& - 'chan var a=_v1%(x);_getref_d(&^(PM__local(^(&a@) <>)),region,subregion(schedule),'//& - '^^(x),at <>);'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,^*(,,,,),,,_d_ref),at:invar) complete <> {'//& + 'chan var a=_v1%(x);_getref_d%(&^(PM__local%(^(&a!))),'//& + '^^(x),at <>);'//& '_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_d(&a,region,subregion,x,at) {'//& + call dcl_uproc(parser,'_getref_d%(&a:invar,x:invar,at:invar) PM__node {'//& '_get_dindex_from_dref(&a,x,t.2,'//& - '_local_region(region._tile,subregion),region,t.1,'//& + '_local_region(region._tile,subregion(schedule)),region,t.1,'//& '_drat(at,region._tile,t.1)) where t=_v4(x)'//& '}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) <> {'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_d_ref),at:invar) complete <> {'//& 'chan var a=_arb(_v2%(x));'//& - '_getref_dc(&a@,region,subregion(schedule),^^(x),at <>);_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_dc(&a,region,subregion,x,at) {'//& + '_getref_dc%(&a!,^^(x),at <>);_bcast_shared(&a);return a}',line) + call dcl_uproc(parser,'_getref_dc%(&a:invar,x:invar,at:invar) PM__node {'//& 'PM__head_node{_get_dindex(&^(PM__local(^(&a))),PM__local(_v2(x)),t.2,'//& - '_local_region(region._tile,subregion),region,t.1,_drat(at,region._tile,t.1)) '//& + '_local_region(region._tile,subregion(schedule)),region,t.1,_drat(at,region._tile,t.1)) '//& ' where t=_v4(x)}}',line) - call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) <> {'//& + call dcl_uproc(parser,'PM__getref%(x:complete ^*(,,,,_dp_ref),at:invar) complete <> {'//& 'chan var a=_v1%(x);'//& - '_getref_dp(&^(^^(^(&a))),region,subregion(schedule),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>);'//& + '_getref_dp%(&^(^^(^(&a))),^^(_cap%(x,here)),at,^^(^??),_v4(x) <>);'//& '_bcast_shared(&a);return a}',line) - call dcl_uproc(parser,'_getref_dp(&a,region,subregion,x,at,atq,t) {'//& + call dcl_uproc(parser,'_getref_dp%(&a:invar,x:invar,at:invar,atq:invar,t:invar) PM__node {'//& 'PM__head_node{_get_dindex_from_ref(&a,x,t.2,'//& - ' _local_region(region._tile,subregion),region,'//& + ' _local_region(region._tile,subregion(schedule)),region,'//& ' t.1,atq,_drat(at,region._tile,t.1))}'//& '}',line) @@ -3424,10 +3502,9 @@ subroutine sysdefs(parser) ' u=overlap(_v3%(x),dist[p]);'//& ' ppp=index(dims(dist),p);'//& ' PM__recv pp,xx,vvv,_cap%(x,here),ppp,at,_getref(xx,null);'//& - ' v[u]:=vvv};return v}',line) - + ' v[u]=vvv};return v}',line) - ! Resolve reference locally (once communicated) +write(*,'(a)') '// Resolve reference locally (once communicated)' call dcl_uproc(parser,'_getref_elem(x:any^mshape,i)=_get_aelem(x,i)',line) call dcl_uproc(parser,& '_getref_elem(x:any^dshape,i)=_get_aelem(PM__local(x),i)',line) @@ -3441,33 +3518,33 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_getref(x:^shared(,null,null,null,null),y)<>=_v1(x)',line) call dcl_uproc(parser,'_getref(x:^#(,,,,),y)<>=_getslice(_getref(_v2(x),y),_v3(x))',line) call dcl_uproc(parser,'_getslice(x:any^dshape,tt) {t=overlap((#x)._tile,tt);'//& - 'var v=varray(_arb(x),#t);v:=PM__local(x)[t];return v}',line) + 'var v=varray(_arb(x),#t);v=PM__local(x)[t];return v}',line) call dcl_uproc(parser,'_getslice(x:any^mshape,t) {'//& - 'var v=varray(_arb(x),#t);v:=x[t];return v}',line) + 'var v=varray(_arb(x),#t);v=x[t];return v}',line) call dcl_uproc(parser,'_getref(x:any^any,y)=x',line) call dcl_uproc(parser,'_getref(x:^shared(,,indexed,,),y)<>='//& '_getref(_v2(x),y)[_dmap(_v3(x),y)]',line) call dcl_uproc(parser,'_getref(x:^shared(,any^dshape,indexed,,),y)<>='//& - '_get_elem(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) '//& + 'element(PM__local(_v2(x)),ms._tile#_dmap(_correct(_v3(x),ms._mshape._extent),y)) '//& 'where ms=#_v2(x)',line) call dcl_uproc(parser,'_getref(x:^shared(,,indexed,,),y:null)<>=_v1(x) '//& ':test "Internal error - uncapped dref" => ''false',line) - if(pm_is_compiling) then - call dcl_proc(parser,'_sync%(any,any,any,&x:any)',op_sync,0,line,0) - else + write(*,'(a)') 'PM__if_compiling' + call dcl_proc(parser,'_sync%(any,any,any,&x:any)',"sync",0,line,0) +write(*,'(a)') 'PM__else' call dcl_uproc(parser,'_sync%(&x:any){}',line) - endif +write(*,'(a)') 'PM__endif' - ! Assignment of distributed and/or shared or uniform references +write(*,'(a)') '// Assignment of distributed and/or shared or uniform references' call dcl_uproc(parser,'PM__assign%(&x:priv,y,at) {'//& '_sync%(&x);PM__assign(&x,y <>)}',line) - call dcl_uproc(parser,'PM__assign%(&x:invar,y,at) {_assign_to_invar%(&x,y) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar) '//& - '{ _sync%(&x);PM__assign(&x,y <>) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar) '//& - '{ _sync%(&x);PM__assign(&x,y <>) }',line) + call dcl_uproc(parser,'PM__assign%(&x:invar,y,at) {_sync%(&x);_assign_to_invar%(&x,y) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar) complete '//& + '{ PM__assign(&x,y <>) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar) shared'//& + '{ PM__assign(&x,y) }',line) call dcl_uproc(parser,& '_assign_to_invar%(&x:invar,y:priv) '//& '{ test "Can only assign an ""invar"" value to an ""invar"" variable" => ''false }',line) @@ -3501,23 +3578,24 @@ subroutine sysdefs(parser) '{ PM__assign(&^(_getlhs(^(&xx),null)),PM__import_val(y))}}',line) call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y,at) {'//& - '_set_ref_dp(&^(^^(_cap%(^(&x),here))),^(^^(y)),'//& - ' region,subregion(schedule),$_just_assign,^^(^??),at,_v4(x) <>)}',line) + '_set_ref_dp%(&^(^^(_cap%(^(&x),here))),^(^^(y)),'//& + ' $_just_assign,^^(^??),at,_v4(x) <>)}',line) call dcl_uproc(parser,'_just_assign(x,y)=y',line) - call dcl_uproc(parser,'_set_ref_dp(&x,y,region,subregion,prc,atq,at,t) {'//& + call dcl_uproc(parser,'_set_ref_dp%(&x:invar,y:invar,'//& + ' prc:invar,atq:invar,at:invar,t:invar) PM__node {'//& '_set_dindex_of_ref(&x,y,t.2,'//& - '_local_region(region._tile,subregion),'//& + '_local_region(region._tile,subregion(schedule)),'//& 'region,t.1,prc,atq,at)'//& '}',line) - ! Operater assignment: x =y +write(*,'(a)') '// Operater assignment: x =y' call dcl_uproc(parser,'PM__assign%(&x:priv,y:priv,pr,at) {PM__assign(&x,y,pr)}',line) call dcl_uproc(parser,'PM__assign%(&x:priv,y:invar,pr,at) {PM__assign(&x,y,pr)}',line) call dcl_uproc(parser,'PM__assign%(&x:invar,y,pr,at) { _assign_to_invar%(&x,y,pr,at) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar,pr,at) '//& - '{ PM__assign(&x,y,pr <>) }',line) - call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar,pr,at) '//& - '{ PM__assign(&x,y,pr <>) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:uniform,y:invar,pr:uniform,at:uniform) complete'//& + '{ PM__assign(&x,y,pr <>) }',line) + call dcl_uproc(parser,'_assign_to_invar%(&x:shared,y:invar,pr:uniform,at:uniform) shared '//& + '{ PM__assign(&x,y,pr) }',line) call dcl_uproc(parser,'_assign_to_invar%(&x:invar,y:priv,pr,at){'//& '_assign_to_invar%(&x,_reduce_for_assign%(pr,y,x),pr,at)}',line) call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_p_ref),y,pr,at) {'//& @@ -3537,12 +3615,12 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,int,_sp_ref),y:invar,pr,at) {'//& 'PM__collect p,xx,yy,_cap%(x,here),_v4%(x),null,at { PM__assign(&^(_getlhs(^(&xx),null)),y,pr)}}',line) call dcl_uproc(parser,'PM__assign%(&x:priv ^*(,,,,_d_ref or _dp_ref),y:priv,pr,at) {'//& - '_set_dindex_of_ref(&^(^^(_cap%(^(&x),here))),^^(y),t.2,'//& + '_set_dindex_of_ref%(&^(^^(_cap%(^(&x),here))),^^(y),t.2,'//& '_local_region(region._tile,subregion(schedule)),'//& - 'region,t.1,pr,^^(^??),at <>)'//& + 'region,t.1,pr,^^(^??),at <>)'//& 'where t=_v4%(x)}',line) - ! Resolve LHS reference (locally after communication) +write(*,'(a)') '// Resolve LHS reference (locally after communication)' call dcl_uproc(parser,'_getlhs(x:^*(,,_here,,),y)=_getlhs(_v2(x),_v3(x).here)',line) call dcl_uproc(parser,'_getlhs(x:^*(,,_lcl,,),y)=_getlhs(_v2(x),y)',line) call dcl_uproc(parser,'_getlhs(x:^(,,int,,),y)='//& @@ -3572,9 +3650,9 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_getlhs(x:^shared(,,indexed,,),y:null)='//& '_v1(x) :test "Internal error -- uncapped indexed ref" => ''false',line) - !************************************************************** - ! INDEXED VARIABLES - !************************************************************** +write(*,'(a)') '// **************************************************************' +WRITE(*,'(A)') '// INDEXED VARIABLES' +write(*,'(a)') '// **************************************************************' call dcl_type(parser,'indexed_dim(d:int,m:int,c:int,n:int) is rec {_m:m=''1,_c:c=''0,_d:d=''1,_n:n}',line) call dcl_type(parser,'indexed(t:int) is tuple(indexed_dim or int) except tuple(int)',line) @@ -3587,11 +3665,10 @@ subroutine sysdefs(parser) '=map($PM__makeidxdim,x,indices(x))',line) call dcl_uproc(parser,'PM__makeidxdim(x:seq)=[PM__makeidxdim(x,''1)]',line) - !!! Obsolete? - call dcl_uproc(parser,'PM__makeidx(x:indexed_dim or tuple(indexed_dim or int))='//& + call dcl_uproc(parser,'PM__makeidx(x:indexed_dim or indexed)='//& 'new _indexed {_t=_tup(x),_r=null}',line) - call dcl_uproc(parser,'PM__makeidx(x:indexed_dim or tuple(indexed_dim or int),y)='//& + call dcl_uproc(parser,'PM__makeidx(x:indexed_dim or indexed,y)='//& 'new _indexed {_t=_tup(x),_r=y}',line) call dcl_uproc(parser,'PM__makeidx(x,y)=x :test "Malformed indexed expression" => ''false',line) call dcl_uproc(parser,'PM__makeidx(x)=x :test "Malformed indexed expression" => ''false',line) @@ -3626,7 +3703,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'string(x:indexed_dim(''1,''1))="$here."++x._n++"+"++x._c',line) call dcl_uproc(parser,'string(x:indexed_dim(''1,''1,''0))="$here."++x._n',line) - call dcl_uproc(parser,'_correct(x:tuple(indexed_dim),y:extent)=map($-,x,low(y))',line) + call dcl_uproc(parser,'_correct(x:indexed,y:extent)=map($-,x,low(y))',line) call dcl_uproc(parser,'_dmap(x:any_int,n:int)=x',line) call dcl_uproc(parser,'_dmap(x:any_int,n:grid_slice_dim)=single_point(x)',line) @@ -3638,16 +3715,12 @@ subroutine sysdefs(parser) 'where lo=_dmap(x,low(n)),hi=_dmap(x,high(n))',line) call dcl_uproc(parser,'_dmap(x:indexed_dim(''1,''1),n:strided_range)=n._lo+x._c..n._hi+x._c by n._st',line) call dcl_uproc(parser,'_dmap(x:indexed_dim(''1,''1),n:block_seq)='//& - 'block_seq(n._lo+x._c,n._hi+x._c,n._st.n._b,n._align)',line) + 'block_seq(n._lo+x._c,n._hi+x._c,n._st,n._b,n._align)',line) call dcl_uproc(parser,'_dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice)='//& 'map_const($_dmap,x,n)',line) call dcl_uproc(parser,'_dmap(x:tuple(indexed_dim or any_int),n:tuple(int) or grid_slice,s:extent)='//& 's#map_const($_dmap,x,n)',line) - call dcl_uproc(parser,'_drev(x:indexed_dim,n)=new indexed_dim {_m=x._d,_c=-x._c,_d=x._m,_n=n}',line) - call dcl_uproc(parser,'_drev(n,x:tuple(indexed_dim))=_drev(get_dim(x,n),n)',line) - call dcl_uproc(parser,'_drev(x:tuple(indexed_dim),y:tuple(fix int))=map_const($_drev,y,x)',line) - call dcl_type(parser,'_round_up is unique',line) call dcl_type(parser,'_round_down is unique',line) call dcl_uproc(parser,'_dunmap(x:indexed_dim,n:null)=null',line) @@ -3657,23 +3730,23 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_dunmap(x:indexed_dim,n:grid_slice_dim)='//& 'min(lo,hi)..max(lo,hi) where lo=_dunmap(x,low(n),_round_down),hi=_dunmap(x,high(n),_round_up)',line) call dcl_uproc(parser,& - '_dun(x:indexed_dim,m:range(int),n:extent)=replace(n,x._n,intersect(get_dim(n,x._n),_dunmap(x,m)))',line) - call dcl_uproc(parser,'_dun(x:int,m:range(int),n:extent)=n',line) - call dcl_uproc(parser,'_dunmap(x:tuple(indexed_dim or int),m:grid_slice or tuple(int),n:extent)='//& + '_dun(x:indexed_dim,m,n:extent)=replace(n,x._n,intersect(get_dim(n,x._n),_dunmap(x,m)))',line) + call dcl_uproc(parser,'_dun(x:int,m,n:extent)=n',line) + call dcl_uproc(parser,'_dunmap(x:indexed,m:grid_slice or tuple(int),n:extent)='//& '_dun(x.1,m.1,nn) where nn=_dunmap(tail(x),tail(m),n)',line) call dcl_uproc(parser,'_dunmap(x:[indexed_dim or int],m:grid_slice or tuple(int),n:extent)='//& '_dun(x.1,m.1,n)',line) - ! Given tile and global region (which may be null) compute local region +write(*,'(a)') '// Given tile and global region (which may be null) compute local region' call dcl_uproc(parser,'_local_region(t,r:null)=t',line) call dcl_uproc(parser,'_local_region(t,r)=intersect(t,r)',line) call dcl_uproc(parser,'_root_node(at:''true)=_root_node()',line) call dcl_uproc(parser,'_root_node(at:''false)=_this_node()',line) - ! Resolve x[indexed] +write(*,'(a)') '// Resolve x[indexed]' call dcl_uproc(parser,& - '_get_dindex(&a,x,shapex,local_tile,local_region,t:tuple(indexed_dim),at) {'//& + '_get_dindex(&a,x,shapex,local_tile,local_region,t:indexed,at) {'//& 'tt=_correct(t,shapex._mshape);'//& 'if size(_dmap(tt,local_region._mshape))*4>size(local_region._mshape) {'//& ' if at or a is <_comp^any> {'//& @@ -3689,18 +3762,18 @@ subroutine sysdefs(parser) ' }'//& '}}',line) - ! Resolve x[indexed] for cases where size(x[indexed])>=size(region) - ! -- in this case send one value for every point in current (sub)region +write(*,'(a)') '// Resolve x[indexed] for cases where size(x[indexed])>=size(region)' +write(*,'(a)') '// -- in this case send one value for every point in current (sub)region' call dcl_uproc(parser,& - '_get_dindex_s(&a:any^any,x,shapex,local_tile,local_region,t:tuple(indexed_dim),at) {'//& + '_get_dindex_s(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) {'//& 'PM__head_node{'//& ' shapexx=#shapex._mshape;'//& ' this_tile=shapex._tile;'//& ' foreach p in nodes_for_grid(shapex.dist,_dmap(t,local_tile)) {'//& ' if contains(#(shapex.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& + ' i=index(dims(shapex.dist),p);'//& ' if i/=_this_node(){'//& - ' other_tile=_get_elem(shapex.dist,p);'//& + ' other_tile=element(shapex.dist,p);'//& ' dest_range2=_dunmap(t,other_tile,local_region._mshape);'//& ' portion_to_recv=overlap(local_tile,dest_range2);'//& ' if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv)'//& @@ -3710,7 +3783,7 @@ subroutine sysdefs(parser) ' if contains(#(local_region.dist),p) {'//& ' i=index(dims(local_region.dist),p);'//& ' if i/=_this_node() {'//& - ' other_tile=_get_elem(local_region.dist,p);'//& + ' other_tile=element(local_region.dist,p);'//& ' portion_to_recv=intersect(other_tile,dest_range);'//& ' if size(portion_to_recv)>0: '//& ' _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile)'//& @@ -3718,40 +3791,40 @@ subroutine sysdefs(parser) ' _copy_dmapped(&a,local_tile,local_region._mshape,x,shapex._tile,t);'//& ' _sync_messages(a,x)}}',line) - ! Resolve x[indexed] for cases where size(x[indexed])<=size(region) - ! -- in this case send those values in x which are needed to calculate x[indexed] +write(*,'(a)') '// Resolve x[indexed] for cases where size(x[indexed])<=size(region)' +write(*,'(a)') '// -- in this case send those values in x which are needed to calculate x[indexed]' call dcl_uproc(parser,& - '_get_dindex_r(&a:any^any,x,shapex,local_tile,local_region,t:tuple(indexed_dim),at) {'//& + '_get_dindex_r(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) {'//& 'shapexx=#shapex._mshape;'//& 'src_range=_dmap(t,local_tile);var b=array(_arb(a),#src_range);'//& 'foreach p in nodes_for_grid(shapex.dist,src_range) {'//& - ' if contains(#(local_region.dist),p) {'//& - ' i=index(dims(local_region.dist),p);'//& + ' if contains(#(shapex.dist),p) {'//& + ' i=index(dims(shapex.dist),p);'//& ' if i/=_this_node() {'//& - ' other_tile=_get_elem(shapex.dist,p);'//& + ' other_tile=element(shapex.dist,p);'//& ' portion_to_send=overlap(src_range,other_tile);'//& - ' if size(portion_to_send)>0:_recv_slice(i,&b,portion_to_send);'//& + ' if size(portion_to_send)>0:_recv_slice(i,&b,active_dims(src_range,portion_to_send));'//& ' }}};'//& ' dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& ' foreach p in nodes_for_grid(local_region.dist,dest_range){'//& ' if contains(#(local_region.dist),p) {'//& ' i=index(dims(local_region.dist),p);'//& ' if i/=_this_node() {'//& - ' other_tile=_get_elem(local_region.dist,p);'//& + ' other_tile=element(local_region.dist,p);'//& ' src_range2=_dmap(t,other_tile);'//& ' portion_to_send=overlap(shapex._tile,src_range2);'//& ' if size(portion_to_send)>0:_send_slice(i,x,portion_to_send);'//& ' }}};'//& ' u,v=overlap(src_range,shapex._tile);'//& - ' for i in u,j in v <>{_set_elem(&b,PM__getelem(x,j),i <>)};'//& + ' forall i in u,j in v{_set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <>)};'//& ' _sync_messages(x,b);'//& '_copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t)}',line) - ! Resolve x[indexed] for cases where size(x[indexed])>=size(region) - ! -- in this case send one value for every point in current (sub)region - ! -- Version for more complex types that need sync receive +write(*,'(a)') '// Resolve x[indexed] for cases where size(x[indexed])>=size(region)' +write(*,'(a)') '// -- in this case send one value for every point in current (sub)region' +write(*,'(a)') '// -- Version for more complex types that need sync receive' call dcl_uproc(parser,& - '_get_dindex_ss(&a:any^any,x,shapex,local_tile,local_region,t:tuple(indexed_dim),at) {'//& + '_get_dindex_ss(&a:any^any,x,shapex,local_tile,local_region,t:indexed,at) {'//& 'shapexx=#shapex._mshape;'//& 'this_tile=shapex._tile;'//& 'dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& @@ -3759,7 +3832,7 @@ subroutine sysdefs(parser) ' if contains(#(local_region.dist),p) {'//& ' i=index(dims(local_region.dist),p);'//& ' if i/=_this_node() {'//& - ' other_tile=_get_elem(local_region.dist,p);'//& + ' other_tile=element(local_region.dist,p);'//& ' portion_to_recv=intersect(other_tile,dest_range);'//& ' if size(portion_to_recv)>0: '//& ' _send_slice_mapped(i,x,portion_to_recv,t,shapex._tile)'//& @@ -3769,18 +3842,18 @@ subroutine sysdefs(parser) ' if contains(#(shapex.dist),p) {'//& ' i=index(dims(local_region.dist),p);'//& ' if i/=_this_node() {'//& - ' other_tile=_get_elem(shapex.dist,p);'//& + ' other_tile=element(shapex.dist,p);'//& ' dest_range2=_dunmap(t,other_tile,local_region._mshape);'//& ' portion_to_recv=overlap(local_tile,dest_range2);'//& ' if size(portion_to_recv)>0 { '//& ' _recv_slice_sync(i,&a,portion_to_recv);'//& '}}}};_sync_messages(a,x)}',line) - ! Resolve x[indexed] for cases where size(x[indexed])<=size(region) - ! -- in this case send those values in x which are needed to calculate x[indexed] - ! -- Version for more complex types that need sync receive +write(*,'(a)') '// Resolve x[indexed] for cases where size(x[indexed])<=size(region)' +write(*,'(a)') '// -- in this case send those values in x which are needed to calculate x[indexed]' +write(*,'(a)') '// -- Version for more complex types that need sync receive' call dcl_uproc(parser,& - '_get_dindex_rs(&a:_comp^any,x,shapex,local_tile,local_region,t:tuple(indexed_dim),at) {'//& + '_get_dindex_rs(&a:_comp^any,x,shapex,local_tile,local_region,t:indexed,at) {'//& 'PM__head_node {'//& 'shapexx=#shapex._mshape;'//& 'dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& @@ -3788,39 +3861,41 @@ subroutine sysdefs(parser) ' if contains(#(local_region.dist),p) {'//& ' i=index(dims(local_region.dist),p);'//& ' if i/=_this_node() {'//& - ' other_tile=_get_elem(local_region.dist,p);'//& + ' other_tile=element(local_region.dist,p);'//& ' src_range=_dmap(t,other_tile);'//& ' portion_to_send=overlap(shapex._tile,src_range);'//& ' if size(portion_to_send)>0:_send_slice(i,x,portion_to_send);'//& '}}}};'//& 'src_range=_dmap(t,local_tile);var b=array(_arb(a),#src_range);'//& 'if _head_node() or at { u,v=overlap(src_range,shapex._tile);'//& - ' for i in u,j in v <>{_set_elem(&b,PM__getelem(x,j),i <>)};'//& + ' forall i in u,j in v {_set_elem(&b,PM__getelem(x,j),active_dims(src_range,i) <>)};'//& ' foreach p in nodes_for_grid(shapex.dist,src_range) {'//& ' if contains(#(local_region.dist),p) {'//& ' i=index(dims(local_region.dist),p);'//& ' if i/=_this_node() {'//& - ' other_tile=_get_elem(shapex.dist,p);'//& + ' other_tile=element(shapex.dist,p);'//& ' portion_to_send=overlap(src_range,other_tile);'//& - ' if size(portion_to_send)>0{ PM__head_node{_recv_slice_sync(i,&b,portion_to_send)};'//& - ' if at:_bcast_slice_shared(&b,#b,portion_to_send,''true)}'//& + ' if size(portion_to_send)>0{ PM__head_node{'//& + ' _recv_slice_sync(i,&b,active_dims(src_range,portion_to_send))};'//& + ' if at:_bcast_slice_shared(&b,active_dims(src_range,portion_to_send))}'//& ' }}}};'//& ' _copy_dmapped(&a,local_tile,local_region._mshape,b,src_range,t);'//& ' _sync_messages(x,b)}',line) call dcl_uproc(parser,'_copy_dmapped(&a,a_tile,a_extent,b,b_tile,t) {'//& 'u=overlap(a_tile,_dunmap(t,b_tile,a_extent));'//& - 'for i in u <>{_set_elem(&a,PM__getelem(b,j),i <>) '//& - ' where j=b_tile#_dmap(t,a_tile[i])}}',line) + 'forall i in u {'//& + ' j=b_tile#_dmap(t,a_tile[i]);if j in #b_tile:_set_elem(&a,PM__getelem(b,j),i <>) '//& + '}}',line) call dcl_uproc(parser,'_copy_dmapped_ref(&a,a_tile,a_extent,b,b_tile,t) {'//& 'u=intersect(a_tile,_dunmap(t,b_tile,a_extent));'//& - 'for i in u <>{ bb=_import_dref%(b);_set_elem(&a,_getref(bb,i),a_tile#i <>);'//& + 'forall i in u { bb=_import_dref%(b);_set_elem(&a,_getref(bb,i),a_tile#i <>);'//& '}}',line) - ! Resolve x[ indexed ][ indexed or shared ] ... +write(*,'(a)') '// Resolve x[ indexed ][ indexed or shared ] ... ' call dcl_uproc(parser,& - '_get_dindex_from_dref(&a:any^any,x,shapex,local_tile,local_region,tt:tuple(indexed_dim),at) {'//& + '_get_dindex_from_dref(&a:any^any,x,shapex,local_tile,local_region,tt:indexed,at) {'//& 't=_correct(tt,shapex._mshape);shapexx=#shapex._mshape;'//& 'this_tile=shapex._tile;'//& 'dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& @@ -3828,7 +3903,7 @@ subroutine sysdefs(parser) ' if contains(#(shapex.dist),p) {'//& ' i=index(dims(local_region.dist),p);'//& ' if i/=_this_node(){'//& - ' other_tile=_get_elem(shapex.dist,p);'//& + ' other_tile=element(shapex.dist,p);'//& ' dest_range2=_dunmap(t,other_tile,local_region._mshape);'//& ' portion_to_recv=overlap(local_tile,dest_range2);'//& ' if size(portion_to_recv)>0:_recv_slice(i,&a,portion_to_recv);'//& @@ -3840,10 +3915,10 @@ subroutine sysdefs(parser) ' if contains(#(local_region.dist),p) {'//& ' i=index(dims(local_region.dist),p);'//& ' if i/=_this_node() {'//& - ' other_tile=_get_elem(local_region.dist,p);'//& + ' other_tile=element(local_region.dist,p);'//& ' portion_to_recv=intersect(other_tile,dest_range);'//& ' if size(portion_to_recv)>0 {'//& - ' b[pp]:={_getref(_import_dref%(x),h):h in portion_to_recv};'//& + ' b[pp]={_getref(_import_dref%(x),h):h in portion_to_recv};'//& ' _isend(i,b[pp]) }'//& '}}};'//& '_copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t);'//& @@ -3851,9 +3926,9 @@ subroutine sysdefs(parser) '}',line) - ! Resolve x[ indexed ][ indexed or shared ] ... +write(*,'(a)') '// Resolve x[ indexed ][ indexed or shared ] ... ' call dcl_uproc(parser,& - '_get_dindex_from_dref_s(&a:_comp^any,x,shapex,local_tile,local_region,tt:tuple(indexed_dim),at) {'//& + '_get_dindex_from_dref_s(&a:_comp^any,x,shapex,local_tile,local_region,tt:indexed,at) {'//& 't=_correct(tt,shapex._mshape);shapexx=#shapex._mshape;'//& 'this_tile=shapex._tile;'//& 'dest_range=_dunmap(t,shapex._tile,local_region._mshape);'//& @@ -3864,10 +3939,10 @@ subroutine sysdefs(parser) ' if contains(#(local_region.dist),p) {'//& ' i=index(dims(local_region.dist),p);'//& ' if i/=_this_node() {'//& - ' other_tile=_get_elem(local_region.dist,p);'//& + ' other_tile=element(local_region.dist,p);'//& ' portion_to_recv=intersect(other_tile,dest_range);'//& ' if size(portion_to_recv)>0 {'//& - ' b[pp]:={_getref(_import_dref%(x),h):h in portion_to_recv};'//& + ' b[pp]={_getref(_import_dref%(x),h):h in portion_to_recv};'//& ' _isend(i,b[pp]) }'//& '}}};'//& '_copy_dmapped_ref(&a,local_tile,local_region._mshape,x,shapex._tile,t);'//& @@ -3875,52 +3950,56 @@ subroutine sysdefs(parser) ' if contains(#(shapex.dist),p) {'//& ' i=index(dims(local_region.dist),p);'//& ' if i/=_this_node(){'//& - ' other_tile=_get_elem(shapex.dist,p);'//& + ' other_tile=element(shapex.dist,p);'//& ' dest_range2=_dunmap(t,other_tile,local_region._mshape);'//& ' portion_to_recv=overlap(local_tile,dest_range2);'//& ' if size(portion_to_recv)>0{ PM__head_node{ _recv_slice_sync(i,&a,portion_to_recv)};'//& - ' if at:_bcast_shared_slice(&a,#a,portion_to_recv,''true);}'//& + ' if at:_bcast_slice_shared(&a,portion_to_recv);}'//& ' }};'//& '};_sync_messages(a,x)}',line) - ! Resolve x[ indexed ][ priv ] +write(*,'(a)') '// Resolve x[ indexed ][ priv ]' call dcl_uproc(parser,& - '_get_dindex_from_ref(&a,x,shapex,this_tile,local_region,t:tuple(indexed_dim),complt,at) {'//& + '_get_dindex_from_ref(&a,x,shapex,this_tile,local_region,t:indexed,complt,at) {'//& 'dest_range=_dmap(t,this_tile,#shapex._mshape);'//& ' foreach p in nodes_for_grid(shapex.dist,dest_range){'//& ' i=index(dims(local_region.dist),p);'//& ' if contains(#(local_region.dist),p) and i/=_this_node() {'//& - ' other_tile=_get_elem(shapex.dist,p);'//& + ' other_tile=element(shapex.dist,p);'//& ' portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape));'//& ' _send_recv_slice_req(i,x,&a,local_region._mshape,portion_to_send,complt)'//& '}};'//& 'src_range=_dunmap(t,shapex._tile,local_region._mshape);'//& - 'for j in overlap(this_tile,src_range) <>{'//& + 'forall j in overlap(this_tile,src_range) {'//& ' jj=index(#this_tile,j);PM__do_at size(this_tile),jj,aa,a,xx,x { '//& ' PM__assign(&aa,_getref(xx,null))}}; '//& 'foreach p in nodes_for_grid(local_region.dist,src_range) {'//& ' if contains(#(local_region.dist),p) and index(dims(local_region.dist),p)/=_this_node() {'//& ' PM__recv_req pp,xx,x,_getref(xx,null)'//& ' }};'//& - ' if a is <_comp>: foreach p in nodes_for_grid(shapex.dist,dest_range){'//& + 'if a is <_comp>: foreach p in nodes_for_grid(shapex.dist,dest_range){'//& ' i=index(dims(local_region.dist),p);'//& ' if contains(#(local_region.dist),p) and i/=_this_node() {'//& - ' other_tile=_get_elem(shapex.dist,p);'//& + ' other_tile=element(shapex.dist,p);'//& ' portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape));'//& ' _recv_slice_reply(i,&a,local_region._mshape,portion_to_send,complt)'//& - ' }};'//& - ' _sync_messages(a,x);'//& + '}};'//& + ' _sync_messages(a,x)'//& '}',line) - ! Resolve x[ indexed ][ whatever ] = priv +write(*,'(a)') '// Resolve x[ indexed ][ whatever ] = priv' call dcl_uproc(parser,& - '_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt:tuple(indexed_dim),'//& + '_set_dindex_of_ref%(&x:invar,y:invar,shapex:invar,this_tile:invar,local_region:invar,tt:invar indexed,'//& + ' pr:invar proc,complt:invar,at:invar) PM__node <>:'//& + '_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt,pr,complt,at)',line) + call dcl_uproc(parser,& + '_set_dindex_of_ref(&x,y,shapex,this_tile,local_region,tt:indexed,'//& ' pr:proc,complt,at) {'//& 't=_correct(tt,shapex._mshape);dest_range=_dmap(t,this_tile,#shapex._mshape);'//& 'PM__head_node{foreach p in nodes_for_grid(shapex.dist,dest_range){'//& ' i=index(dims(shapex.dist),p);'//& ' if contains(#(shapex.dist),p) and i/=_this_node() {'//& - ' other_tile=_get_elem(shapex.dist,p);'//& + ' other_tile=element(shapex.dist,p);'//& ' portion_to_send=overlap(this_tile,_dunmap(t,other_tile,local_region._mshape));'//& ' _send_slice_assn(i,x,y,#this_tile,portion_to_send,complt)'//& '}}};'//& @@ -3929,20 +4008,20 @@ subroutine sysdefs(parser) ' jj=index(#this_tile,j);PM__do_at size(this_tile),jj,yy,y,xx,x { '//& ' PM__assign(&^(_getlhs(xx,null)),yy,pr)}}; '//& 'foreach p in nodes_for_grid(local_region.dist,src_range) {'//& - ' i=index(dims(shapex.dist),p);'//& + ' i=index(dims(local_region.dist),p);'//& ' if contains(#(local_region.dist),p) and i/=_this_node() {'//& - ' PM__recv_assn pp,xx,yy,x,y,at{PM__assign(&^(_getlhs(^(&xx),null)),yy,pr)}'//& + 'PM__recv_assn pp,xx,yy,x,y,at{PM__assign(&^(_getlhs(^(&xx),null)),yy,pr)}'//& '}};'//& '_sync_messages(x,y)}',line) - !************************************************************** - ! Envelope and stencil definitions - !************************************************************** +write(*,'(a)') '// **************************************************************' +write(*,'(a)') '// Envelope and stencil definitions' +write(*,'(a)') '// **************************************************************' call dcl_type(parser,'envelope is rec{cross:extent or null,corner:extent or null,envelope:extent}',line) call dcl_uproc(parser,'ortho(x:extent)=new envelope {cross=x,corner=spread(0..0,x),envelope=x}',line) call dcl_uproc(parser,'ortho(x:extent,y:extent)='//& - 'new envelope {cross=x,corner=y,envelope=envelope(x,y)}',line) + 'new envelope {cross=if(x inc y=>x,y),corner=y,envelope=envelope(x,y)}',line) call dcl_uproc(parser,'envelope(x:envelope)=x.envelope',line) call dcl_uproc(parser,'envelope(x:extent)=x',line) call dcl_uproc(parser,'envelope(x:any_int,y:any_int)='//& @@ -3961,28 +4040,28 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'envelope(x:envelope,y:envelope)=envelope(x.envelope,y.envelope)',line) call dcl_uproc(parser,'string(x:envelope)=string(x.cross++" ortho "++x.corner)',line) - !************************************************************** - ! Support for nhd statement - !************************************************************** +write(*,'(a)') '// **************************************************************' +write(*,'(a)') '// Support for nhd statement' +write(*,'(a)') '// **************************************************************' - call dcl_type(parser,'_nhd is rec{_nbhd,_tile,_tilesz,_bounds,_interior,_limits}',line) + call dcl_type(parser,'_nhd is rec{_nbhd,_tile,_tilesz,_interior,_limits}',line) call dcl_type(parser,'nbhd(t) is struct^{_array:farray(t),_nbhd,_index,_here}',line) - call dcl_uproc(parser,'PM__nhd%(x:invar envelope or extent,y:invar boundary)<>='//& - 'new _nhd {_nbhd=x,_tile=t,_tilesz=#t,_bounds=y,_interior=overlap(t,region._tile),'//& - '_limits=region._extent} '//& + call dcl_uproc(parser,'PM__nhd%(x:invar envelope or extent,bound:invar) shared <>='//& + 'new _nhd {_nbhd=x,_tile=t,_tilesz=#t,_interior=overlap(t,region._tile),'//& + '_limits=_expand_limits(region._extent,envelope(x),bound)} '//& 'where t=_get_halo(region,region._tile,envelope(x))',line) - call dcl_uproc(parser,'PM__nhd%(x,y)='//& - '^(new _nhd {_nbhd=n,_tile=t,_tilesz=#t,_bounds=null,_interior=t,'//& + call dcl_uproc(parser,'PM__nhd%(x,bound:invar)='//& + '^(new _nhd {_nbhd=n,_tile=t,_tilesz=#t,_interior=t,'//& '_limits=region._extent},shared) '//& 'where t=region._tile where n=xx '//& 'where xx=spread(0..0,here){_check_nhd%(x)}',line) - call dcl_uproc(parser,'_check_nhd%(n:invar envelope or extent) {}',line) call dcl_uproc(parser,'_check_nhd%(n:extent):test "Neighbourhood must be invar"=>''false',line) call dcl_uproc(parser,'_check_nhd%(n):test "Neighbourhood must be an extent or envelope"=>''false',line) - call dcl_uproc(parser,'PM__check_bounds%(n,b:invar boundary){_check_ranks(n,b)}',line) - call dcl_uproc(parser,'PM__check_bounds%(n,b:boundary):test "Bounds must be ""invar"""=>''false',line) - call dcl_uproc(parser,'PM__check_bounds%(n,b):test "Bounds must have a boundary type"=>''false',line) + + call dcl_uproc(parser,'PM__check_bounds%(b:invar boundary){_check_ranks(extent(region),b)}',line) + call dcl_uproc(parser,'PM__check_bounds%(b:boundary):test "Bounds must be ""invar"""=>''false',line) + call dcl_uproc(parser,'PM__check_bounds%(b):test "Bounds must have a boundary type"=>''false',line) call dcl_uproc(parser,'_check_ranks(n:tuple,b:tuple):'//& 'test "Rank of boundary does not match that of neighbourhood"=>same_type(rank(n),rank(b))',line) call dcl_uproc(parser,'_check_ranks(n:envelope,b:tuple):'//& @@ -3991,16 +4070,36 @@ subroutine sysdefs(parser) 'test "Rank of boundary does not match that of neighbourhood"=>same_type(''1,rank(b))',line) call dcl_uproc(parser,'_check_ranks(n,b){}',line) + call dcl_type(parser,'boundary is boundary_dim,tuple(boundary_dim)',line) + call dcl_type(parser,'boundary_dim is CYCLE,EXCLUDED,range(int),null',line) + call dcl_type(parser,'CYCLE is unique',line) + call dcl_type(parser,'EXCLUDED is unique',line) + + call dcl_uproc(parser,'_expand_limits(t:range(int),n:range(int),b:boundary_dim)=t',line) + call dcl_uproc(parser,'_expand_limits(t:range(int),n:range(int),b:CYCLE)=_exterior(t,n)',line) + call dcl_uproc(parser,'_expand_limits(t:tuple,n:tuple,b:boundary_dim)=map($_expand_limits,t,n,spread(b,n))',line) + call dcl_uproc(parser,'_expand_limits(t:tuple,n:tuple,b:tuple(boundary_dim))='//& + 'map($_expand_limits,t,n,b)',line) + call dcl_uproc(parser,'PM__set_nhd%(&n,x:complete){'//& - 'n._array[n._nbhd._interior[n._index]]:=x}',line) - call dcl_uproc(parser,'PM__set_nhd%(&n,x):n._array[n._nbhd._interior[n._index]]:=x'//& + 'n._array[n._nbhd._interior[n._index]]=x}',line) + call dcl_uproc(parser,'PM__set_nhd%(&n,x):n._array[n._nbhd._interior[n._index]]=x'//& ' check "Expression in ""nhd"" must be ""complete"""=>''false',line) call dcl_uproc(parser,'PM__nhd_join(x)=x._array',line) call dcl_uproc(parser,'PM__nhd_join(x,y)=new _join{head=x,tail=y._array}',line) - call dcl_uproc(parser,'PM__nhd_var%(x,n:_nhd,i,h)='//& - 'new nbhd{_array=_make_nhd(^(x,shared),n._tilesz <>),_nbhd=n,_index=i,_here=h}',line) - call dcl_uproc(parser,'_make_nhd(x,d){var v=array(x,d);return v}',line) + call dcl_uproc(parser,'PM__nhd_var%(x,n:_nhd,i,h)<>='//& + 'new nbhd{_array=_make_nhd%(^(x,shared),n._tilesz),_nbhd=n,_index=i,_here=h}',line) + call dcl_uproc(parser,'PM__nhd_active(region,nbhd,bound:null)=region._extent',line) + call dcl_uproc(parser,& + 'PM__nhd_active(region,nbhd,bound:tuple)=map($_nhd_active,region._extent,nbhd,bound)',line) + call dcl_uproc(parser,'PM__nhd_active(region,nbhd,bound){'//& + 'r=PM__nhd_active(region,nbhd,spread(bound,region._extent));return r}',line) + call dcl_uproc(parser,'_nhd_active(r,n,b:CYCLE or null)=r',line) + call dcl_uproc(parser,'_nhd_active(r,n,b:range)=low(r)-min(0,low(b))..high(r)-max(0,high(b))',line) + call dcl_uproc(parser,'_nhd_active(r,n,b:EXCLUDED)=_nhd_active(r,n,n)',line) + + call dcl_uproc(parser,'_make_nhd%(x:invar,d:invar) shared <>{var v=array(x,d);return v}',line) call dcl_uproc(parser,'PM__set_edge%(&x,y,z){}',line) @@ -4008,25 +4107,15 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__subref(x:nbhd,t:null)=_nhd_sub(x,t)',line) call dcl_uproc(parser,'_nhd_sub(x:nbhd,t:any except contains(null or stretch_dim))='//& - 'PM__subref(x._array,tt+x._nbhd._interior[x._index])'//& - '{tt=_tup(t);'//& - 'test t++" not in neighbourhood"++x._nbhd._nbhd=>contains(_foot(tt,x._nbhd._nbhd),tt),'//& - '"At "++x._here++" nhd "++t++" goes outside of boundary "++limits=>'//& - '_check_limits(dtt,limits,x._nbhd._bounds)'//& - 'where limits=x._nbhd._limits '//& - 'where dtt=tt+x._here}',line) + 'PM__subref(x._array,tt+x._nbhd._interior[x._index]) {'//& + 'tt=_tup(t);'//& + 'test "Subscript"++tt++" not in neighbourhood"++x._nbhd._nbhd=>contains(_foot(tt,x._nbhd._nbhd),tt),'//& + '"At "++x._here++" nhd "++tt++" goes outside of boundary "++limits=>'//& + 'contains(limits,dtt) where limits=x._nbhd._limits '//& + ' where dtt=tt+x._here}',line) call dcl_uproc(parser,'_nhd_sub(x:nbhd,t)=_arb(x._array)'//& 'check "Subscripts with null or ""_"" dimensions not accepted for ""nbhd"""=>''false',line) - call dcl_uproc(parser,'_check_limits(t:int,extent:range,bound:null)=t in extent',line) - call dcl_uproc(parser,'_check_limits(t:seq,extent:range,bound:null)=extent inc t',line) - call dcl_uproc(parser,'_check_limits(t,extent,bound)=''true',line) - call dcl_uproc(parser,'_check_limits(t:tuple,extent,bound:tuple)='//& - 'map_reduce($_check_limits,$and,t,extent,bound)',line) - call dcl_uproc(parser,'_check_limits(t:tuple(int),extent,bound:null)=t in extent',line) - call dcl_uproc(parser,'_check_limits(t:tuple,extent,bound:null)=extent inc t',line) - call dcl_uproc(parser,'_check_limits(t:tuple,extent,bound)=''true',line) - call dcl_uproc(parser,'PM__dup(x:nbhd)=x:test "Cannot make a variable or constant of type ""nbhd"""=>''false',line) call dcl_uproc(parser,'envelope(x:_nhd)=envelope(x._nbhd)',line) @@ -4044,104 +4133,173 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_positive(x)=x>0',line) call dcl_uproc(parser,& - 'PM__send_nhd%(&a:shared,nbhd:shared) <> { '//& - ' this_tile=region._tile;this_tile_x=nbhd._tile;'//& + 'PM__send_nhd%(&a:invar,nbhd:invar,b:invar boundary) shared <> { '//& + ' PM__head_node{this_tile=region._tile;this_tile_x=nbhd._tile;'//& ' pp=index2point(_this_node(),dims(region.dist));'//& ' foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) {'//& - ' ok,p=_to_exchange(region.dist,i,nbhd._bounds);if ok {'//& - ' other_tile=_wrapped_tile(region.dist,region._extent,i);'//& - ' other_tile_x=_get_halo(region._mshape,other_tile,'//& + ' if contains(#region.dist,i) and i/=pp {'//& + ' p=index(dims(region.dist),i);'//& + ' other_tile=element(region.dist,i);'//& + ' tile_x=_get_halo(region._mshape,region._tile,'//& ' _foot(i-pp,nbhd._nbhd));'//& - ' ov=overlap(this_tile_x,other_tile);if size(ov)>0 {'//& - ' _recv_slice(p,&a,ov);'//& + ' ov=this_tile_x#intersect(tile_x,other_tile);if size(ov)>0 {'//& + ' _recv_slice(p,&a,ov)'//& ' }}'//& ' };'//& - ' foreach ii in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { '//& - ' i=pp*2-ii;ok,p=_to_exchange(region.dist,i,nbhd._bounds);if ok {'//& - ' other_tile=_wrapped_tile(region.dist,region._extent,i);'//& + ' foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { '//& + ' if contains(#region.dist,i) and i/=pp {'//& + ' p=index(dims(region.dist),i);'//& + ' other_tile=element(region.dist,i);'//& ' other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd));'//& ' ov=overlap(this_tile_x,intersect(this_tile,other_tile_x));if size(ov)>0 {'//& - ' _send_slice(p,a,ov);'//& + ' _send_slice(p,a,ov)'//& ' }} '//& - ' }'//& - '}',line) - - call dcl_uproc(parser,'_exchange_cyclic_bounds(&a,nbhd,region,bound) {'//& - ' this_tile=region._tile;this_tile_x=nbhd._tile;'//& - ' pp=spread(0,this_tile);'//& - ' print("exchange");foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) {'//& - ' print("ww"++i);ok,p=_to_exchange(region.dist,i,nbhd._bounds);if ok {'//& - ' other_tile=_wrapped_tile(region.dist,region._extent,i);'//& - ' other_tile_x=_get_halo(region._mshape,other_tile,'//& - ' _foot(i-pp,nbhd._nbhd));print("CP"++i);'//& - ' ov=overlap(this_tile_x,other_tile);if size(ov)>0 {'//& - ' ov2=overlap(other_tile_x,intersect(other_tile,this_tile_x));'//& - ' print("copy"++ov2++"to"++ov);for k1 in ov,k2 in ov2:sync a[k1]:=v where v=a[k2]'//& - ' }}'//& + ' };'//& + '_apply_boundaries(&a,region,envelope(nbhd._nbhd),this_tile_x,extent(region),'//& + ' envelope(nbhd._nbhd),b,rank(extent(region)),''false)'//& '}}',line) + call dcl_uproc(parser,& - '_exchange_cyclic_bounds(&a,nbhd,this_tile,bound:boundary except contains(CYCLE)) {}',line) + 'PM__send_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { '//& + ' PM__head_node{this_tile=region._tile;this_tile_x=nbhd._tile;'//& + ' pp=index2point(_this_node(),dims(region.dist));'//& + ' foreach i in node_nhd(region.dist,pp,_rev(envelope(nbhd._nbhd))) { '//& + ' if contains(#region.dist,i) and i/=pp {'//& + ' p=index(dims(region.dist),i);'//& + ' other_tile=element(region.dist,i);'//& + ' other_tile_x=_get_halo(region._mshape,other_tile,_foot(i-pp,nbhd._nbhd));'//& + ' ov=overlap(this_tile_x,intersect(this_tile,other_tile_x));if size(ov)>0 {'//& + ' _send_slice(p,a,ov);'//& + ' }} '//& + ' };'//& + '_apply_boundaries(&a,region,envelope(nbhd._nbhd),this_tile_x,extent(region),'//& + ' envelope(nbhd._nbhd),b,rank(extent(region)),''false)'//& + '}}',line) + + call dcl_uproc(parser,'inside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo..lo-y,hi-y..hi))'//& + ' where lo=low(x),hi=high(x)',line) + call dcl_uproc(parser,'inside_edge(x:extent,y:tuple(int))=map($inside_edge,x,y)',line) + call dcl_uproc(parser,'outside_edge(x:range(int),y:int)=if(y==0=>x,if(y<0=>lo+y..lo,hi..hi+y))'//& + ' where lo=low(x),hi=high(x)',line) + call dcl_uproc(parser,'outside_edge(x:extent,y:tuple(int))=map($outside_edge,x,y)',line) + call dcl_uproc(parser,'_foot(d,n:envelope)=if(_crss(d)=>n.cross,n.corner)',line) call dcl_uproc(parser,'_foot(d,n:extent)=n',line) - call dcl_uproc(parser,'PM__recv_nhd%(&a:shared,nbhd:shared) {}',line) + call dcl_uproc(parser,'PM__recv_nhd%(&a:invar,nbhd:invar,b:invar) shared <> {'//& + 'PM__head_node{_apply_boundaries(&a,region,envelope(nbhd._nbhd),nbhd._tile,extent(region),'//& + ' envelope(nbhd._nbhd),b,rank(extent(region)),''true)}}',line) call dcl_uproc(parser,& - 'PM__recv_nhd%(&a:shared _comp^any,nbhd:shared) <> { '//& - ' this_tile=region._tile;this_tile_x=nbhd._tile;'//& + 'PM__recv_nhd%(&a:invar _comp^any,nbhd:invar,b:invar boundary) shared <> { '//& + ' PM__head_node{this_tile=region._tile;this_tile_x=nbhd._tile;'//& ' pp=index2point(_this_node(),dims(region.dist));'//& ' foreach i in node_nhd(region.dist,pp,envelope(nbhd._nbhd)) {'//& - ' ok,p=_to_exchange(region.dist,i,nbhd._bounds);if ok {'//& - ' other_tile=_wrapped_tile(region.dist,i);'//& - ' other_tile_x=_get_halo(region._mshape,other_tile,_foot(_crss(i-pp),nbhd._nbhd));'//& - ' ov=overlap(this_tile_x,other_tile);if size(ov)>0 {'//& - ' _recv_slice_sync(p,&a,ov);'//& + ' if contains(#region.dist,i) and i/=pp {'//& + ' p=index(dims(region.dist),i);'//& + ' other_tile=element(region.dist,i);'//& + ' tile_x=_get_halo(region._mshape,region._tile,'//& + ' _foot(i-pp,nbhd._nbhd));'//& + ' ov=this_tile_x#intersect(tile_x,other_tile);if size(ov)>0 {'//& + ' _recv_slice_sync(p,&a,ov);'//& ' }}'//& - ' }}',line) + ' };'//& + '_apply_boundaries(&a,region,envelope(nbhd._nbhd),region._tile,extent(region),'//& + ' envelope(nbhd._nbhd),b,rank(extent(region)),''true)'//& + '}}',line) + + call dcl_uproc(parser,& + 'PM__bcast_nhd%(&a:invar,nbhd:invar,b:invar) shared <> {'//& + 'if shrd_nnode()>1 {'//& + ' foreach i in 1..chunks(region,envelope(nbhd._nbhd))-1 {'//& + ' chunk=chunk(region,envelope(nbhd._nbhd),i,b);'//& + ' _bcast_slice_shared(&a,chunk)'//& + '}}}',line) call dcl_uproc(parser,'_rev(a:tuple)=map($_rev,a)',line) call dcl_uproc(parser,'_rev(a:range)=-high(a)..-low(a)',line) - call dcl_uproc(parser,'_to_exchange(d,p,b:boundary_dim)=ok,pp'//& - ' where ok,pp=_to_exchange(d,p,spread(b,p))',line) - call dcl_uproc(parser,'_to_exchange(d,p,b)=ok,pp {'//& - 'var pp=0;dd=dims(d);var ok=_exchange_needed(dd,p,b);'//& - 'if ok {pp2=index(dd,p);pp:=index(dd,map($_mod_if_needed,p,dd,b));ok:=pp2/=_this_node()}}',line) - call dcl_uproc(parser,'_exchange_needed(d:tuple,p:tuple,b:tuple)='//& - 'map_reduce($_exchange_needed,$and,d,p,b)',line) - call dcl_uproc(parser,'_exchange_needed(d,p,b)='//& - 'p>=0 and p>"++q)}',line) - -!!$ '{print(_sys_node()++">>>"++p++";"++p mod size(d)++";"++size(s)++";"++'//& -!!$ '_get_elem(d,p mod ss)+_rdiv(p,ss)*size(s)) where ss=size(d)}',line) + call dcl_uproc(parser,'_apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:tuple,index,recv) { '//& + '_apply_boundaries(&a,d,n,this_tile_x,extent,envelope,get_dim(bound,index),index,recv);'//& + '_apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound,index-''1,recv)}',line) + call dcl_uproc(parser,'_apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:tuple,index:''0,recv)'//& + ' {}',line) + call dcl_uproc(parser,'_apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound,index,recv) {}',line) + call dcl_uproc(parser,'_apply_boundaries(&a,d,n,this_tile_x,extent,envelope,bound:CYCLE,index,recv) { '//& + 'ex=get_dim(extent,index);ev=get_dim(envelope,index);'//& + 'lo=low(ex);hi=high(ex);up=max(high(ev),0);down=min(low(ev),0);'//& + 'upper_outside=replace(extent,index,hi+1..hi+up);'//& + 'upper_inside=replace(extent,index,hi+down+1..hi);'//& + 'lower_outside=replace(extent,index,lo+down..lo-1);'//& + 'lower_inside=replace(extent,index,lo..lo+up-1);'//& + '_copy_bounds(&a,d,n,this_tile_x,upper_outside,lower_inside,recv);'//& + '_copy_bounds(&a,d,n,this_tile_x,lower_outside,upper_inside,recv)}',line) + + call dcl_uproc(parser,'_copy_bounds(&a,d,n,this_tile_x,to,from,recv:''false) {'//& + 'oldpart,oldtile=overlap(from,d._tile);'//& + 'newpart,newtile=overlap(to,this_tile_x);'//& + 'foreach pp in nodes_for_grid(d.dist,element(from,newpart)) {'//& + ' p=index(dims(d.dist),pp);'//& + ' if pp in #d.dist and p/=_this_node() {'//& + ' tile=element(to,overlap(from,element(d.dist,p)));'//& + ' ov=overlap(this_tile_x,tile);'//& + ' if size(ov)>0{_recv_slice(p,&a,ov)}}'//& + '};'//& + 'foreach pp in nodes_for_grid(d.dist,_get_anti_halo(d,element(to,oldpart),n)) {'//& + ' p=index(dims(d.dist),pp);'//& + ' if pp in #d.dist and p/=_this_node() {'//& + ' tile=element(from,overlap(to,_get_halo(d,element(d.dist,p),n)));'//& + ' ov=this_tile_x#intersect(d._tile,tile);'//& + ' if size(ov)>0{_send_slice(p,a,ov)}}'//& + '}}',line) + + call dcl_uproc(parser,'_copy_bounds(&a:_comp^any,d,n,this_tile_x,to,from,recv:''false) {'//& + 'oldpart,oldtile=overlap(from,d._tile);'//& + 'newpart,newtile=overlap(to,this_tile_x);'//& + 'foreach pp in nodes_for_grid(d.dist,_get_anti_halo(d,element(to,oldpart),n)) {'//& + ' p=index(dims(d.dist),pp);'//& + ' if pp in #d.dist and p/=_this_node() {'//& + ' tile=element(from,overlap(to,_get_halo(d,element(d.dist,p),n)));'//& + ' ov=this_tile_x#intersect(d._tile,tile);'//& + ' if size(ov)>0{_send_slice(p,a,ov)}}'//& + '}}',line) + call dcl_uproc(parser,'_copy_bounds(&a,d,n,this_tile_x,to,from,recv:''true) {'//& + 'oldpart,oldtile=overlap(from,this_tile_x);'//& + 'newpart,newtile=overlap(to,this_tile_x);'//& + 'o,oo=overlap(newpart,oldpart);'//& + '_set_slice(&a,element(newtile,o),a,element(oldtile,oo))}',line) + + call dcl_uproc(parser,'_copy_bounds(&a:_comp^any,d,n,this_tile_x,to,from,recv:''true) {'//& + 'oldpart,oldtile=overlap(from,this_tile_x);'//& + 'newpart,newtile=overlap(to,this_tile_x);'//& + 'o,oo=overlap(newpart,oldpart);'//& + '_set_slice(&a,element(newtile,o),a,'//& + ' element(oldtile,oo));'//& + 'foreach pp in nodes_for_grid(d.dist,element(from,newpart)) {'//& + ' p=index(dims(d.dist),pp);'//& + ' if pp in #d.dist and p/=_this_node() {'//& + ' tile=element(to,overlap(from,element(d.dist,p)));'//& + ' _recv_slice(p,&a,overlap(this_tile_x,tile))}'//& + '}}',line) + call dcl_uproc(parser,'_send_slice(p,a:_join,o) {_send_slice(p,a.head,o);_send_slice(p,a.tail,o)}',line) call dcl_uproc(parser,'_recv_slice(p,&a:_join,o) {_recv_slice(p,&a.head,o);_recv_slice(p,&a.tail,o)}',line) call dcl_uproc(parser,'_recv_slice_sync(p,&a:_join,o)'//& '{_recv_slice_sync(p,&a.head,o);_recv_slice_sync(p,&a.tail,o)}',line) + call dcl_uproc(parser,'_bcast_slice_shared(&a:_join,o)'//& + ' {_bcast_slice_shared(&a.head,o);_bcast_slice_shared(&a.tail,o)}',line) call dcl_uproc(parser,'_sync_messages(x:_join):_sync_messages(x.head,x.tail)',line) call dcl_uproc(parser,'_not_zero(x)=if(x/=0=>1,0)',line) call dcl_uproc(parser,'_crss(x)=1==map_reduce($_not_zero,$+,x)',line) + - call dcl_type(parser,'boundary is boundary_dim,tuple(boundary_dim)',line) - call dcl_type(parser,'boundary_dim is CYCLE,NO_EDGE,null',line) - call dcl_type(parser,'CYCLE is unique',line) - call dcl_type(parser,'NO_EDGE is unique',line) - - ! Add (anti) halo around tile - ! Args: mshape / tile / displacement - ! (mshape not used at the moment - there to cope with other topologies) - ! Result: expanded tile +write(*,'(a)') '// Add (anti) halo around tile' +write(*,'(a)') '// Args: mshape / tile / displacement' +write(*,'(a)') '// (mshape not used at the moment - there to cope with other topologies)' +write(*,'(a)') '// Result: expanded tile' call dcl_uproc(parser,& '_get_halo(d:range(int),t:range(int),i:any_int)='//& 'low(t)+ii..high(t)+ii where ii=int(i)',line) @@ -4153,7 +4311,7 @@ subroutine sysdefs(parser) 'return block_seq(low(t)+ii,high(t)+ii,step(t),width(t),0) where ii=int(i)}',line) call dcl_uproc(parser,& '_get_halo(d:range(int),t:map_seq,i:any_int) {'//& - 'var a=array(0,size(t));for j in a,k in t.array:j:=k+i;return new map_seq {array=a}}',line) + 'var a=array(0,size(t));for j in a,k in t.array:j=k+i;return new map_seq {array=a}}',line) call dcl_uproc(parser,& '_get_halo(d:range(int),t:range(int),i:range(any_int))='//& @@ -4161,12 +4319,12 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& '_get_halo(d:range(int),t:strided_range(int),i:range(any_int)){'//& 'var step=step(t);var width=size(i);'//& - 'if width>step {step:=1;width:=1};'//& + 'if width>step {step=1;width=1};'//& 'return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0)}',line) call dcl_uproc(parser,& '_get_halo(d:range(int),t:block_seq,i:range(any_int)){'//& 'var step=step(t);var width=size(i)+width(t)-1;'//& - 'if width>step {step:=1;width:=1}'//& + 'if width>step {step=1;width=1}'//& 'return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width,0)}',line) call dcl_uproc(parser,& '_get_halo(d:range(int),t:map_seq,i:range(any_int)) {'//& @@ -4179,7 +4337,6 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& '_get_halo(d:tuple1d(range(int)),t:grid1d,i:any_int or range(any_int))='//& '_get_halo(d.1,t.1,i)',line) - call dcl_uproc(parser,'_get_halo(d,t,i:null)=t',line) call dcl_uproc(parser,& @@ -4193,7 +4350,7 @@ subroutine sysdefs(parser) 'return block_seq(low(t)-ii,high(t)-ii,step(t),width(t)) where ii=int(i)}',line) call dcl_uproc(parser,& '_get_anti_halo(d:range(int),t:map_seq,i:any_int) {'//& - 'var a=array(0,size(t));for j in a,k in t.array:j:=k-i;return new map_seq {array=a}}',line) + 'var a=array(0,size(t));for j in a,k in t.array:j=k-i;return new map_seq {array=a}}',line) call dcl_uproc(parser,& '_get_anti_halo(d:range(int),t:range(int),i:range(any_int))='//& 'low(t)-int(high(i))..high(t)-int(low(i))',line) @@ -4201,12 +4358,12 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& '_get_anti_halo(d:range(int),t:strided_range(int),i:range(any_int)){'//& 'var step=step(t);var width=size(i);'//& - 'if width>step {step:=1;width:=1}'//& + 'if width>step {step=1;width=1}'//& 'return block_seq(low(t)-int(high(i)),high(t)-int(low(i)),step,width)}',line) call dcl_uproc(parser,& '_get_anti_halo(d:range(int),t:block_seq,i:range(any_int)){'//& 'var step=step(t);var width=size(i)+width(t)-1;'//& - 'if width>step {step:=1;width:=1}'//& + 'if width>step {step=1;width=1}'//& 'return block_seq(low(t)+int(low(i)),high(t)+int(high(i)),step,width)}',line) call dcl_uproc(parser,& '_get_anti_halo(d:range(int),t:map_seq,i:range(any_int)) {'//& @@ -4222,49 +4379,54 @@ subroutine sysdefs(parser) '_get_anti_halo(d.1,t.1,i)',line) call dcl_uproc(parser,'_get_anti_halo(d,t,i:null)=t',line) - - call dcl_uproc(parser,'_interior(d:range,t:range,n:range)=low(t)+max(0,-low(n))..high(t)-max(0,high(n))',line) - call dcl_uproc(parser,'_interior(d:range,t:strided_range,n:range)=1..0 by 1',line) - call dcl_uproc(parser,'_interior(d:range,tt:block_seq,n:range)='//& + call dcl_uproc(parser,'_interior(t:range,n:range)=low(t)+max(0,-low(n))..high(t)-max(0,high(n))',line) + call dcl_uproc(parser,'_interior(t:strided_range,n:range)=1..0 by 1',line) + call dcl_uproc(parser,'_interior(tt:block_seq,n:range)='//& 'block_seq(low(t)+max(-low(n),0),high(t),width(t),width(t)-max(-low(n),0)-max(high(n),0),0)'//& 'where t=middle_blocks(tt)',line) - call dcl_uproc(parser,'_get_chunk(d:range,t:range,n:range,l:''true)='//& + + call dcl_uproc(parser,'_get_chunk(t:range,n:range,l:''true)='//& 'low(t)..low(t)+min(-min(0,low(n))-1,size(t)-1)',line) - call dcl_uproc(parser,'_get_chunk(d:range,t:range,n:range,l:''false)='//& + call dcl_uproc(parser,'_get_chunk(t:range,n:range,l:''false)='//& 'low(t)+max(size(t)-max(high(n),0),-min(low(n),-1))..high(t)',line) - call dcl_uproc(parser,'_get_chunk(d:range,tt:block_seq,n:range,l:''true)='//& + call dcl_uproc(parser,'_get_chunk(t:range,n:range,l:_down)='//& + 'low(t)+w..low(t)+w+w-1 where w=max(0,-low(n))',line) + call dcl_uproc(parser,'_get_chunk(t:range,n:range,l:_up)='//& + 'high(t)-w-w+1..high(t)-w where w=max(0,high(n))',line) + call dcl_uproc(parser,'_get_chunk(tt:block_seq,n:range,l:''true)='//& 'if(low(n)<0=>block_seq(low(t),high(t),step(t),min(-low(n),width(t)),0),empty(t))'//& ' where t=middle_blocks(tt)',line) - call dcl_uproc(parser,'_get_chunk(d:range,tt:block_seq,n:range,l:''false)='//& + call dcl_uproc(parser,'_get_chunk(tt:block_seq,n:range,l:''false)='//& 'if(high(n)>0=>block_seq(low(t)+max(0,width(t)-high(n)),high(t),step(t),min(width(t),high(n)),0),empty(t))'//& ' where t=middle_blocks(tt)',line) - call dcl_uproc(parser,'_get_chunk(d:range,t:grid_dim,n:range,l:_left or _right)=empty(t)',line) - call dcl_uproc(parser,'_get_chunk(d:range,t:block_seq,n:range,l:_left)='//& + call dcl_uproc(parser,'_get_chunk(t:grid_dim,n:range,l:_left or _right)=empty(t)',line) + call dcl_uproc(parser,'_get_chunk(t:block_seq,n:range,l:_left)='//& 'block_seq(low(b),high(b),1,1,0) where b=first_block(t)',line) - call dcl_uproc(parser,'_get_chunk(d:range,t:block_seq,n:range,l:_right)='//& + call dcl_uproc(parser,'_get_chunk(t:block_seq,n:range,l:_right)='//& 'block_seq(low(b),high(b),1,1,0) where b=last_block(t)',line) - call dcl_uproc(parser,'_chunk(d,t,n,r,e,l)='//& - 'if(r_interior(d,t,n),r>e=>t,_get_chunk(d,t,n,l))',line) - call dcl_uproc(parser,'_get_chunk(d:tuple1d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l)]',line) - call dcl_uproc(parser,'_get_chunk(d:tuple2d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l),'//& - '_chunk(d.2,t.2,n.2,''2,e,l)]',line) - call dcl_uproc(parser,'_get_chunk(d:tuple3d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l),'//& - '_chunk(d.2,t.2,n.2,''2,e,l),_chunk(d.3,t.3,n.3,''3,e,l)]',line) - call dcl_uproc(parser,'_get_chunk(d:tuple4d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l),'//& - '_chunk(d.2,t.2,n.2,''2,e,l),_chunk(d.3,t.3,n.3,''3,e,l),'//& - '_chunk(d.4,t.4,n.4,''4,e,l)]',line) - call dcl_uproc(parser,'_get_chunk(d:tuple5d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l),'//& - '_chunk(d.2,t.2,n.2,''2,e,l),_chunk(d.3,t.3,n.3,''3,e,l),'//& - '_chunk(d.4,t.4,n.4,''4,e,l),_chunk(d.5,t.5,n.5,''5,e,l)]',line) - call dcl_uproc(parser,'_get_chunk(d:tuple6d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l),'//& - '_chunk(d.2,t.2,n.2,''2,e,l),_chunk(d.3,t.3,n.3,''3,e,l),'//& - '_chunk(d.4,t.4,n.4,''4,e,l),_chunk(d.5,t.5,n.5,''5,e,l),'//& - '_chunk(d.6,t.6,n.6,''6,e,l)]',line) - call dcl_uproc(parser,'_get_chunk(d:tuple7d,t,n,e,l)=[_chunk(d.1,t.1,n.1,''1,e,l),'//& - '_chunk(d.2,t.2,n.2,''2,e,l),_chunk(d.3,t.3,n.3,''3,e,l),'//& - '_chunk(d.4,t.4,n.4,''4,e,l),_chunk(d.5,t.5,n.5,''5,e,l),'//& - '_chunk(d.6,t.6,n.6,''6,e,l),_chunk(d.7,t.7,n.7,''7,e,l)]',line) + call dcl_uproc(parser,'_chunk(t,n,r,e,l)='//& + 'if(r>e=>_interior(t,n),rt,_get_chunk(t,n,l))',line) + + call dcl_uproc(parser,'_get_chunk(t:tuple1d,n,e,l)=[_chunk(t.1,n.1,1,e,l)]',line) + call dcl_uproc(parser,'_get_chunk(t:tuple2d,n,e,l)=[_chunk(t.1,n.1,1,e,l),'//& + '_chunk(t.2,n.2,2,e,l)]',line) + call dcl_uproc(parser,'_get_chunk(t:tuple3d,n,e,l)=[_chunk(t.1,n.1,1,e,l),'//& + '_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l)]',line) + call dcl_uproc(parser,'_get_chunk(t:tuple4d,n,e,l)=[_chunk(t.1,n.1,1,e,l),'//& + '_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),'//& + '_chunk(t.4,n.4,4,e,l)]',line) + call dcl_uproc(parser,'_get_chunk(t:tuple5d,n,e,l)=[_chunk(t.1,n.1,1,e,l),'//& + '_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),'//& + '_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l)]',line) + call dcl_uproc(parser,'_get_chunk(t:tuple6d,n,e,l)=[_chunk(t.1,n.1,1,e,l),'//& + '_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),'//& + '_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l),'//& + '_chunk(t.6,n.6,6,e,l)]',line) + call dcl_uproc(parser,'_get_chunk(t:tuple7d,n,e,l)=[_chunk(t.1,n.1,1,e,l),'//& + '_chunk(t.2,n.2,2,e,l),_chunk(t.3,n.3,3,e,l),'//& + '_chunk(t.4,n.4,4,e,l),_chunk(t.5,n.5,5,e,l),'//& + '_chunk(t.6,n.6,6,e,l),_chunk(t.7,n.7,7,e,l)]',line) call dcl_uproc(parser,'chunks(t:tuple(range(any_int)),n:extent)=rank(t)*2+1',line) call dcl_uproc(parser,'chunks(t:tuple(range(any_int) or block_seq),n:extent)=rank(t)*4+1',line) @@ -4272,79 +4434,60 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_cr(i,n):test "Index out of range in ""get_chunk"""=>i>=0 and i<=n',line) - call dcl_uproc(parser,'get_chunk(d:shape,t:tuple(range(any_int)),n:extent,i:int) {'//& - '_cr(i,rank(t)*2);const r;switch i {'//& - 'case 0: r=map($_interior,d,t,n);'//& - 'case 1: r=_get_chunk(d,t,n,''1,''true);'//& - 'case 2: r=_get_chunk(d,t,n,''1,''false);'//& - 'case 3: r=_get_chunk(d,t,n,''2,''true);'//& - 'case 4: r=_get_chunk(d,t,n,''2,''false);'//& - 'case 5: r=_get_chunk(d,t,n,''3,''true);'//& - 'case 6: r=_get_chunk(d,t,n,''3,''false);'//& - 'case 7: r=_get_chunk(d,t,n,''4,''true);'//& - 'case 8: r=_get_chunk(d,t,n,''4,''false);'//& - 'case 9: r=_get_chunk(d,t,n,''5,''true);'//& - 'case 10:r=_get_chunk(d,t,n,''5,''false);'//& - 'case 11:r=_get_chunk(d,t,n,''6,''true);'//& - 'case 12:r=_get_chunk(d,t,n,''6,''false);'//& - 'case 13:r=_get_chunk(d,t,n,''7,''true);'//& - 'case 14:r=_get_chunk(d,t,n,''7,''false);'//& - 'default:r=_get_chunk(d,t,n,''1,''true);'//& - '};return r}',line) - + call dcl_uproc(parser,'chunk(t:tuple(range(any_int)),n:extent,i:int) {'//& + ' _cr(i,rank(t)*2);var r=n;'//& + ' if i==0: r=map($_interior,t,n) elseif i&1==0: r=_get_chunk(t,n,(i+1)/2,''true) '//& + ' else: r=_get_chunk(t,n,(i+1)/2,''false);return r}',line) + call dcl_type(parser,'_left is unique',line) call dcl_type(parser,'_right is unique',line) - - call dcl_uproc(parser,'get_chunk(d:shape,t:tuple(range(any_int) or block_seq),n:extent,i:int) {'//& - '_cr(i,rank(t)*4);const r;switch i {'//& - 'case 0:r=map($_interior,d,t,n);'//& - 'case 1:r=_get_chunk(d,t,n,''1,''true);'//& - 'case 2:r=_get_chunk(d,t,n,''1,''false);'//& - 'case 3:r=_get_chunk(d,t,n,''1,_left);'//& - 'case 4:r=_get_chunk(d,t,n,''1,_right);'//& - 'case 5:r=_get_chunk(d,t,n,''2,''true);'//& - 'case 6:r=_get_chunk(d,t,n,''2,''false);'//& - 'case 7:r=_get_chunk(d,t,n,''2,_left);'//& - 'case 8:r=_get_chunk(d,t,n,''2,_right);'//& - 'case 9:r=_get_chunk(d,t,n,''3,''true);'//& - 'case 10:r=_get_chunk(d,t,n,''3,''false);'//& - 'case 11:r=_get_chunk(d,t,n,''3,_left);'//& - 'case 12:r=_get_chunk(d,t,n,''3,_right);'//& - 'case 13:r=_get_chunk(d,t,n,''4,''true);'//& - 'case 14:r=_get_chunk(d,t,n,''4,''false);'//& - 'case 15:r=_get_chunk(d,t,n,''4,_left);'//& - 'case 16:r=_get_chunk(d,t,n,''4,_right);'//& - 'case 17:r=_get_chunk(d,t,n,''5,''true);'//& - 'case 18:r=_get_chunk(d,t,n,''5,''false);'//& - 'case 19:r=_get_chunk(d,t,n,''5,_left);'//& - 'case 20:r=_get_chunk(d,t,n,''5,_right);'//& - 'case 21:r=_get_chunk(d,t,n,''6,''true);'//& - 'case 22:r=_get_chunk(d,t,n,''6,''false);'//& - 'case 23:r=_get_chunk(d,t,n,''6,_left);'//& - 'case 24:r=_get_chunk(d,t,n,''6,_right);'//& - 'case 25:r=_get_chunk(d,t,n,''7,''true);'//& - 'case 26:r=_get_chunk(d,t,n,''7,''false);'//& - 'case 27:r=_get_chunk(d,t,n,''7,_left);'//& - 'case 28:r=_get_chunk(d,t,n,''7,_right);'//& - 'default:r=_get_chunk(d,t,n,''1,''true);'//& + call dcl_type(parser,'_up is unique',line) + call dcl_type(parser,'_down is unique',line) + + call dcl_uproc(parser,'chunk(t:tuple(range(any_int) or block_seq),n:extent,i:int) {'//& + '_cr(i,rank(t)*4);var r=t;if i==0:r=map($_interior,t,n) else: switch (i-1)&3 {'//& + 'case 0:r=_get_chunk(t,n,(i+3)/4,''true);'//& + 'case 1:r=_get_chunk(t,n,(i+3)/4,''false);'//& + 'case 2:r=_get_chunk(t,n,(i+3)/4,_left);'//& + 'default:r=_get_chunk(t,n,(i+3)/4,_right);'//& '};return r}',line) - - call dcl_uproc(parser,'get_chunk(d:shape,t:grid,n:extent,i:int) {'//& - '_cr(i,1);const r;switch i {case 0:r=empty(#t);default:r=#t};return r}',line) - - ! ************************************************************* - ! nbr% and nbhd% intrinsics - ! ************************************************************* + call dcl_uproc(parser,'chunk(t:grid,n:extent,i:int) {'//& + '_cr(i,1);var r=#t;if i==0:r=empty(#t);return r}',line) + + call dcl_uproc(parser,'chunk(t:grid,n:extent,i:int,b:null)='//& + 'chunk(t,n,i)',line) + call dcl_uproc(parser,'chunk(t:grid,n:extent,i:int,b:extent)='//& + 'intersect(chunk(t,n,i),b)',line) + + call dcl_uproc(parser,'inside_edge(t:tuple(range(any_int)),n:extent,i:int,low:fix bool)='//& + '_get_chunk(t,n,i,low)',line) + call dcl_uproc(parser,'outside_edge(t:tuple(range(any_int)),n:extent,i:int,low:fix bool)='//& + '_get_chunk(map($_exterior,t,n),n,i,low)',line) + call dcl_uproc(parser,'outside_edge_wrapped(t:tuple(range(any_int)),n:extent,i:int,low:''true)='//& + '_get_chunk(map($_exterior,t,n),n,i,_up)',line) + call dcl_uproc(parser,'outside_edge_wrapped(t:tuple(range(any_int)),n:extent,i:int,low:''false)='//& + '_get_chunk(map($_exterior,t,n),n,i,_down)',line) + + call dcl_uproc(parser,'_exterior(t:range(int),n:range(int))=low(t)+min(low(n),0)..high(t)+max(high(n),0)',line) + call dcl_uproc(parser,'_get_external_chunk(t:tuple(range(any_int)),n:extent,i:int) {'//& + ' var r=t;tt=map($_exterior,t,n);'//& + ' if i==0: r=#tt elseif i&1==0: r=_get_chunk(tt,n,(i+1)/2,_up)'//& + ' else: r=_get_chunk(tt,n,(i+1)/2,_down);return r}',line) + + +write(*,'(a)') '// *************************************************************' +write(*,'(a)') '// nbr% and nbhd% intrinsics' +write(*,'(a)') '// *************************************************************' call dcl_type(parser,'disp_index is any_int,tuple(any_int)',line) call dcl_type(parser,& 'disp_sub is disp_index,tuple(any_int or range(any_int))',line) - ! *** Default *** +write(*,'(a)') '// *** Default ***' call dcl_uproc(parser,'nbr%(x:chan,t:shared disp_index,v:shared){'//& ' test "Default and chan values must have same type in ""nbr"""=>same_type(x,v);'//& ' j=displace(region._mshape,here,t);'//& - ' var y=v;if contains(region._mshape,j) {y:=x@[j]};'//& + ' var y=v;if contains(region._mshape,j) {y=x![j]};'//& ' return y} ',line) call dcl_uproc(parser,& 'nbhd%(x:chan,t:shared disp_sub,v:shared) { '//& @@ -4352,10 +4495,10 @@ subroutine sysdefs(parser) ' var a=array(v,#t);'//& ' foreach invar i in t {'//& ' j=displace(region._mshape,here,i);'//& - ' if j in region._mshape {a[here]:=x@[j]}'//& + ' if j in region._mshape {a[here]=x![j]}'//& ' };return a}',line) - ! *** Blocked distributions *** +write(*,'(a)') '// *** Blocked distributions ***' call dcl_uproc(parser,& 'nbr%(region:dshape(,blocked_distr),x:chan,t:shared disp_index,v:shared) {'//& ' test "Default and chan values must have same type in ""nbr"""=>same_type(x,v);'//& @@ -4375,13 +4518,13 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'tile_with_halo%(x,t,v) {return a,d '//& 'where a,d=_local_tile_with_halo(region,PM__local(x),t,v)}',line) - ! Return local tile with halo cells +write(*,'(a)') '// Return local tile with halo cells ' call dcl_uproc(parser,& '_local_tile_with_halo(region,x,t,v) { '//& ' this_tile_x=_get_halo(region._mshape,region._tile,t);'//& ' var a=array(v,#this_tile_x);'//& ' foreach i in nodes_for_grid(region.dist,this_tile_x) {'//& - ' other_tile=_get_elem(region.dist,i);'//& + ' other_tile=element(region.dist,i);'//& ' other_tile_x=_get_halo(region._mshape,other_tile,t);'//& ' var p=index(dims(region.dist),i);'//& ' if contains(#region.dist,i) and p/=_this_node() {'//& @@ -4390,14 +4533,14 @@ subroutine sysdefs(parser) ' };'//& ' foreach i in '//& ' nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) {'//& - ' other_tile=_get_elem(region.dist,i);'//& + ' other_tile=element(region.dist,i);'//& ' other_tile_x=_get_halo(region._mshape,other_tile,t);'//& ' p=index(dims(region.dist),i);'//& ' if contains(#region.dist,i) and p/=_this_node() {'//& ' _send_slice(p,x,overlap(region._tile,other_tile_x));'//& ' } '//& ' };'//& - ' o,oo=overlap(this_tile_x,region._tile);a[o]:=x[oo];'//& + ' o,oo=overlap(this_tile_x,region._tile);a[o]=x[oo];'//& ' _sync_messages(a,x);return a,this_tile_x }',line) call dcl_uproc(parser,& @@ -4406,16 +4549,16 @@ subroutine sysdefs(parser) ' var a=array(v,#this_tile_x);'//& ' foreach i in '//& ' nodes_for_grid(region.dist,_get_anti_halo(region._mshape,region._tile,t)) {'//& - ' other_tile=_get_elem(region.dist,i);'//& + ' other_tile=element(region.dist,i);'//& ' other_tile_x=_get_halo(region._mshape,other_tile,t);'//& ' p=index(dims(region.dist),i);'//& ' if contains(#region.dist,i) and p/=_this_node() {'//& ' _send_slice(p,x,overlap(region._tile,other_tile_x));'//& ' } '//& ' };'//& - ' o,oo=overlap(this_tile_x,region._tile);a[o]:=x[oo];'//& + ' o,oo=overlap(this_tile_x,region._tile);a[o]=x[oo];'//& ' foreach i in nodes_for_grid(region.dist,this_tile_x) {'//& - ' other_tile=_get_elem(region.dist,i);'//& + ' other_tile=element(region.dist,i);'//& ' other_tile_x=_get_halo(region._mshape,other_tile,t);'//& ' p=index(dims(region.dist),i);'//& ' if contains(dims(region.dist),i) and p/=_this_node() {'//& @@ -4424,7 +4567,7 @@ subroutine sysdefs(parser) ' };'//& ' _sync_messages(a,x);return a,this_tile_x }',line) - ! Displace x by y within mshape d +write(*,'(a)') '// Displace x by y within mshape d' call dcl_uproc(parser,'displace(d:range(int),x:int,y:any_int)='//& 'x+int(y)',line) call dcl_uproc(parser,'displace(d:range(int),x:int,y:range(any_int))='//& @@ -4436,40 +4579,46 @@ subroutine sysdefs(parser) 'map($displace,d,x,y)',line) - !************************************************ - ! TOPOLOGIES - !************************************************ +write(*,'(a)') '// ************************************************' +WRITE(*,'(A)') '// TOPOLOGIES' +write(*,'(a)') '// ************************************************' + + call dcl_uproc(parser,& + 'topology(tp:null,dis,d:tuple,l:int)=cart_topo(int(d),dis,l)',line) + call dcl_uproc(parser,& + 'topology(tp,dis,d,l:int)=tp',line) - call dcl_proc(parser,'_get_dims(int,int)->int',op_get_dims,0,& + call dcl_proc(parser,'_get_dims(int,int)->int',"get_dims",0,& line,proc_is_impure) call dcl_proc(parser,'_get_dims(int,int,int)->int,int',& - op_get_dims,0,& + "get_dims",0,& line,proc_is_impure) call dcl_proc(parser,'_get_dims(int,int,int,int)->int,int,int',& - op_get_dims,0,& + "get_dims",0,& line,proc_is_impure) call dcl_proc(parser,& '_get_dims(int,int,int,int,int)->int,int,int,int',& - op_get_dims,0,& + "get_dims",0,& line,proc_is_impure) call dcl_proc(parser,'_get_dims(int,int,int,int,int,int)->'//& 'int,int,int,int,int',& - op_get_dims,0,& + "get_dims",0,& line,proc_is_impure) call dcl_proc(parser,'_get_dims(int,int,int,int,int,int,int)->'//& 'int,int,int,int,int,int',& - op_get_dims,0,& + "get_dims",0,& line,proc_is_impure) call dcl_proc(parser,& '_get_dims(int,int,int,int,int,int,int,int)->'//& 'int,int,int,int,int,int,int',& - op_get_dims,0,& + "get_dims",0,& line,proc_is_impure) - - call dcl_uproc(parser,'_zd(x,y:null)=1',line) - call dcl_uproc(parser,'_zd(x,y)=if(x==1=>1,0)',line) + + call dcl_uproc(parser,'_zd(x,y)=if(x==1=>1,nodes_needed(y,x))',line) +!!$ call dcl_uproc(parser,& +!!$ 'cart_topo(dd:tuple,t:null,n:int)=cart_topo(dd,dd,n)',line) call dcl_uproc(parser,& - 'cart_topo(dd:tuple,t:null,n:int)=cart_topo(dd,dd,n)',line) + 'cart_topo(dd:tuple,t:null,n:int)=cart_topo(dd,spread(VBLOCK,dd),n)',line) call dcl_uproc(parser,& 'cart_topo(dd:tuple,t,n:int)=cart_topo(dd,spread(t,dd),n)',line) call dcl_uproc(parser,& @@ -4492,37 +4641,52 @@ subroutine sysdefs(parser) 'where a,b,c,dd,e,f,g=_get_dims(n,_zd(d.7,t.7),_zd(d.6,t.6),'//& '_zd(d.5,t.5),_zd(d.4,t.4),_zd(d.3,t.3),_zd(d.2,t.2),_zd(d.1,t.1))',line) - ! ************************************************ - ! DISTRIBUTIONS - ! ************************************************ +write(*,'(a)') '// ************************************************' +WRITE(*,'(A)') '// DISTRIBUTIONS' +write(*,'(a)') '// ************************************************' call dcl_type(parser,& 'distr_dim is no_distr,direct_distr,block_distr,vblock_distr,cyclic_distr,block_cyclic_distr',line) - call dcl_type(parser,'distr:indexable is null,blocked_distr,distr_dim,tuple(distr_dim)',line) + call dcl_type(parser,'distr:iterable is null,blocked_distr,distr_dim,tuple(distr_dim),sliced_distr',line) call dcl_type(parser,'blocked_distr is block_distr,vblock_distr,tuple(block_distr or vblock_distr)',line) + + call dcl_type(parser,& + 'distr_template is null,distr_template_dim,tuple(distr_template_dim),...',line) + call dcl_type(parser,& + 'distr_template_dim is null,vblock_template,direct_template,'//& + 'block_template,cyclic_template,block_cyclic_template,...',line) - ! Null distribution (mirroring) - call dcl_type(parser,'no_distr is rec {_hi:int,_p:int}',line) - +write(*,'(a)') '// Null distribution (mirroring)' + call dcl_uproc(parser,& + 'distribute(dis:null,d:int,t:int,p:int)='//& + 'no_distr(d,t,p)',line) + call dcl_type(parser,'no_distr is rec {_hi:int,_p:int,_pr:int}',line) + call dcl_uproc(parser,'nodes_needed(d:null,g:int)=1',line) call dcl_uproc(parser,& - 'no_distr(g:int,d:int)='//& - 'new no_distr {_hi=int(g),_p=int(d)}',line) + 'no_distr(g:int,d:int,p:int)='//& + 'new no_distr {_hi=int(g),_p=int(d),_pr=p}',line) call dcl_uproc(parser,'#(b:no_distr)=shape([0..b._p-1])',line) call dcl_uproc(parser,'_shp(b:no_distr)=0..b._p-1',line) call dcl_uproc(parser,'dims(b:no_distr)=[b._p]',line) call dcl_uproc(parser,'size(b:no_distr)=b._p',line) call dcl_uproc(parser,& - '_get_elem(b:no_distr,i:int)=0..b._hi-1',line) + 'element(b:no_distr,i:int)=0..b._hi-1',line) call dcl_uproc(parser,& 'tile_size(b:no_distr,i:int)=b._hi',line) call dcl_uproc(parser,'empty(b:no_distr)=1..0',line) call dcl_uproc(parser,'nodes_for_grid(b:no_distr,g:seq(int))='//& - '0..0',line) - call dcl_uproc(parser,'node_for(b:no_distr,j:int)=0',line) + 'b._pr..b._pr',line) + call dcl_uproc(parser,'node_for(b:no_distr,j:int)=b._pr',line) call dcl_uproc(parser,'index(b:no_distr,j:int,p:int)=j',line) - call dcl_uproc(parser,'node_nhd(b:no_distr,p:int,d:range(int))=0..0',line) + call dcl_uproc(parser,'node_nhd(b:no_distr,p:int,d:range(int))=p..p',line) + call dcl_uproc(parser,'node_co_nhd(b:no_distr,p:int,d:range(int))=p..p',line) - ! Direct distribution (1-1 map to processor topology) +write(*,'(a)') '// Direct distribution (1-1 map to processor topology)' call dcl_type(parser,'direct_distr is rec {_p:int}',line) + call dcl_type(parser,'direct_template is unique{DIRECT}',line) + call dcl_uproc(parser,& + 'distribute(dis:direct_template,d:int,t:int,p:int)='//& + 'direct_distr(d)',line) + call dcl_uproc(parser,'nodes_needed(d:direct_template,g:int)=g',line) call dcl_uproc(parser,& 'direct_distr(d:int)=new direct_distr {_p=int(d)}',line) call dcl_uproc(parser,'#(b:direct_distr)=shape([0..b._p-1])',line) @@ -4530,7 +4694,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'dims(b:direct_distr)=[b._p]',line) call dcl_uproc(parser,'size(b:direct_distr)=b._p',line) call dcl_uproc(parser,& - '_get_elem(b:direct_distr,i:int)=''0..''0',line) + 'element(b:direct_distr,i:int)=''0..''0',line) call dcl_uproc(parser,& 'tile_size(b:direct_distr,i:int)=''1',line) call dcl_uproc(parser,'empty(b:direct_distr)=''1..''0',line) @@ -4540,10 +4704,15 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'index(b:direct_distr,j:int,p:int)=''0',line) call dcl_uproc(parser,'node_nhd(b:direct_distr,p:int,d:int or range(int))=d+p',line) call dcl_uproc(parser,'node_co_nhd(b:direct_distr,p:int,d:int or range(int))='//& - '-high(d)+p..-low(d)+p by -1',line) + '-low(d)+p..-high(d)+p by -1',line) - ! Variable block distribution +write(*,'(a)') '// Variable block distribution' call dcl_type(parser,'vblock_distr is rec {_hi:int,_p:int}',line) + call dcl_type(parser,'vblock_template is unique{VBLOCK}',line) + call dcl_uproc(parser,& + 'distribute(dis:vblock_template,d:int,t:int,p:int)='//& + 'vblock_distr(d,t)',line) + call dcl_uproc(parser,'nodes_needed(d:vblock_template,g:int)=0',line) call dcl_uproc(parser,& 'vblock_distr(g:int,d:int)='//& 'new vblock_distr {_hi=int(g),_p=int(d)}',line) @@ -4552,7 +4721,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'dims(b:vblock_distr)=[b._p]',line) call dcl_uproc(parser,'size(b:vblock_distr)=b._p',line) call dcl_uproc(parser,& - '_get_elem(b:vblock_distr,i:int)=start..finish'//& + 'element(b:vblock_distr,i:int)=start..finish'//& ' where finish=(ii+1)*b._hi/b._p-1'//& ' where start=ii*b._hi/b._p where ii=int(i)',line) call dcl_uproc(parser,& @@ -4562,24 +4731,37 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'empty(b:vblock_distr)=1..0',line) call dcl_uproc(parser,'nodes_for_grid(b:vblock_distr,g:seq(int))='//& 'lo1..hi1 where'//& - ' lo1=_rdiv(b._p*(int(low(g))+1)-1,b._hi),'//& - ' hi1=_rdiv(b._p*(int(high(g))+1)-1,b._hi)',line) + ' lo1=_rdiv(b._p*(low(g)+1)-1,b._hi),'//& + ' hi1=_rdiv(b._p*(high(g)+1)-1,b._hi)',line) call dcl_uproc(parser,'node_for(b:vblock_distr,j:int)=p'//& - ' where p=_rdiv(b._p*(jj+1)-1,b._hi) where jj=int(j)',line) + ' where p=_rdiv(b._p*(j+1)-1,b._hi)',line) call dcl_uproc(parser,'index(b:vblock_distr,j:int,p:int)=i'//& ' where i=jj-s1'//& ' where s1=p*b._hi/b._p'//& ' where jj=int(j)',line) - call dcl_uproc(parser,'_rdiv(x,y)=if(x>0=>x/y,(x-y+1)/y)',line) + call dcl_uproc(parser,'_rdiv(x,y)=if(y<0=>if(x<0=>x/y,(y-x+1)/y),x>0=>x/y,(x-y+1)/y)',line) call dcl_uproc(parser,'node_nhd(b:vblock_distr,p:int,d:range(int))='//& - 'node_for(b,low(r)+low(d))..node_for(b,high(r)+high(d))'//& - ' where r=_get_elem(b,p)',line) - call dcl_uproc(parser,'node_co_nhd(b:vblock_distr,p:int,d:range(int))='//& - 'node_for(b,high(r)-low(d))..node_for(b,low(r)-high(d)) by -1'//& - ' where r=_get_elem(b,p)',line) + 'p+(low(d)-bk+1)/bk..p+(high(d)+bk-1)/bk where bk=b._hi/b._p',line) - ! fixed block distribution +write(*,'(a)') '// fixed block distribution' call dcl_type(parser,'block_distr is rec {_b:int,_s:int,_p:int}',line) + call dcl_type(parser,'_block_template is rec{block:int}',line) + call dcl_type(parser,'_block_template_default is unique{BLOCK}',line) + call dcl_type(parser,& + 'block_template is _block_template_default,_block_template',line) + call dcl_uproc(parser,& + 'BLOCK(block:int)=new _block_template {block=block}',line) + call dcl_uproc(parser,& + 'distribute(dis:_block_template,d:int,t:int,p:int)='//& + 'block_distr(d,t,dis.block)',line) + call dcl_uproc(parser,& + 'distribute(dis:block_template,d:int,t:int,p:int)='//& + 'block_distr(d,t)',line) + call dcl_uproc(parser,'nodes_needed(d:_block_template,g:int)=(g+d.block)/d.block',line) + call dcl_uproc(parser,'nodes_needed(d:block_template,g:int)=0',line) + call dcl_uproc(parser,& + 'block_distr(s:int,p:int)='//& + 'new block_distr {_b=b,_s=s,_p=p} where b=(s+p-1)/p',line) call dcl_uproc(parser,& 'block_distr(s:int,t:int,b:int)='//& 'new block_distr {_b=b,_s=s,_p=p} where p=(s+b-1)/b',line) @@ -4588,7 +4770,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'dims(b:block_distr)=[b._p]',line) call dcl_uproc(parser,'size(b:block_distr)=b._p',line) call dcl_uproc(parser,& - '_get_elem(b:block_distr,i:int)=start..finish'//& + 'element(b:block_distr,i:int)=start..finish'//& ' where finish=min(b._s-1,(ii+1)*b._b-1)'//& ' where start=ii*b._b where ii=int(i)',line) call dcl_uproc(parser,& @@ -4609,11 +4791,14 @@ subroutine sysdefs(parser) ' where jj=int(j)',line) call dcl_uproc(parser,'node_nhd(b:block_distr,p:int,d:range(int))='//& 'p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b',line) - call dcl_uproc(parser,'node_co_nhd(b:block_distr,p:int,d:range(int))='//& - 'p+(-low(d)+b._b-1)/b._b..p+(-high(d)-b._b+1)/b._b by -1',line) - - ! Cyclic distribution + +write(*,'(a)') '// Cyclic distribution' call dcl_type(parser,'cyclic_distr is rec {_hi:int,_p:int}',line) + call dcl_type(parser,'cyclic_template is unique{CYCLIC}',line) + call dcl_uproc(parser,& + 'distribute(dis:cyclic_template,d:int,t:int,p:int)='//& + 'cyclic_distr(d,t)',line) + call dcl_uproc(parser,'nodes_needed(d:cyclic_template,g:int)=0',line) call dcl_uproc(parser,& 'cyclic_distr(g:int,d:int)='//& 'new cyclic_distr {_hi=int(g),_p=int(d)}',line) @@ -4622,47 +4807,43 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'dims(b:cyclic_distr)=[b._p]',line) call dcl_uproc(parser,'size(b:cyclic_distr)=b._p',line) call dcl_uproc(parser,& - '_get_elem(b:cyclic_distr,i:int)='//& + 'element(b:cyclic_distr,i:int)='//& ' int(i)..b._hi-1 by b._p',line) call dcl_uproc(parser,& 'tile_size(b:cyclic_distr,i:int)='//& '(b._hi-1-int(i))/b._p+1',line) call dcl_uproc(parser,& - 'empty(b:cyclic_distr)=1..0 by 1',line) - call dcl_uproc(parser,'_cyx(p,low,high){'//& - ' var lo=0;var hi=p-1;'//& - ' if high-low

lo2 {lo:=lo2;hi:=hi2}'//& - ' };'//& - 'return lo,hi}',line) + 'empty(b:cyclic_distr)=1..0 by 1',line) call dcl_uproc(parser,'nodes_for_grid(b:cyclic_distr,g:seq(int))='//& - 'lo1..hi1 '//& - ' where lo1,hi1=_cyx(b._p,int(low(g)),int(high(g)))',& + 'cyclic_range(lo,high,p) where high=if(hi-lo>=p=>lo+p-1,hi+if(hi>lo=>0,p))'//& + ' where lo=low(g) mod p,hi=high(g) mod p where p=b._p',& line) call dcl_uproc(parser,'node_for(b:cyclic_distr,j:any_int)=p'//& ' where p=int(j) mod b._p',line) call dcl_uproc(parser,'index(b:cyclic_distr,j:int,p:int)=int(j)/b._p',line) call dcl_uproc(parser,'node_nhd(b:cyclic_distr,p:int,d:range(int))='//& - 'p+low(d)..p+high(d)',line) - call dcl_uproc(parser,'node_co_nhd(b:cyclic_distr,p:int,d:range(int))='//& - 'p-low(d)..p-high(d) by -1',line) + 'cyclic_range(p+low(d),p+high(d),b._p)',line) - ! Block cyclic distribution +write(*,'(a)') '// Block cyclic distribution' call dcl_type(parser,& 'block_cyclic_distr is rec {_hi:int,_p:int,_b:int,_s:int}',line) + call dcl_type(parser,'block_cyclic_template is rec {block:int}',line) + call dcl_uproc(parser,'BLOCK_CYCLIC(block:int)=new block_cyclic_template{block=block}',line) + call dcl_uproc(parser,& + 'distribute(dis:block_cyclic_template,d:int,t:int,p:int)='//& + 'block_cyclic_distr(d,t,dis.block)',line) + call dcl_uproc(parser,'nodes_needed(d:block_cyclic_template,g:int)=0',line) call dcl_uproc(parser,& 'block_cyclic_distr(g:int,p:int,b:int)='//& - 'new block_cyclic_distr {_hi=int(g),_p=int(p),_b=int(b),'//& + 'new block_cyclic_distr {_hi=int(g),_p=int(pp),_b=bb,'//& ' _s=s}'//& - ' where s=p*b',line) + ' where s=pp*bb where bb=if(pp==1=>g,b) where pp=min((g+b-1)/b,p)',line) call dcl_uproc(parser,'#(b:block_cyclic_distr)=shape([0..b._p-1])',line) call dcl_uproc(parser,'_shp(b:block_cyclic_distr)=0..b._p-1',line) call dcl_uproc(parser,'dims(b:block_cyclic_distr)=[b._p]',line) call dcl_uproc(parser,'size(b:block_cyclic_distr)=b._p',line) call dcl_uproc(parser,& - '_get_elem(b:block_cyclic_distr,i:int)='//& + 'element(b:block_cyclic_distr,i:int)='//& ' block_seq(s,b._hi-1,b._s,b._b,0)'//& ' where s=ii*b._b where ii=int(i)',& line) @@ -4672,22 +4853,17 @@ subroutine sysdefs(parser) ' where s=ii*b._b where ii=int(i)',& line) call dcl_uproc(parser,& - 'empty(b:block_cyclic_distr)=block_seq(1,0,1,1)',line) - call dcl_uproc(parser,'_cybx(b,p,low,high) {'//& - ' var lo=0;var hi=p;'//& - ' if high-lowlo2 {lo:=lo2;hi:=hi2};'//& - ' }; '//& - ' return lo,hi}',line) - call dcl_uproc(parser,'nodes_for_grid(b:block_cyclic_distr,g:seq(int))='//& - 'lo1..hi1 '//& - ' where lo1,hi1=_cybx(b._b,b._p,int(low(g)),int(high(g)))',& + 'empty(b:block_cyclic_distr)=block_seq(1,0,1,1,0)',line) + call dcl_uproc(parser,'nodes_for_grid(b:block_cyclic_distr,g:grid_dim)='//& + 'if(hi-lo+1cyclic_range(lo,hi,p),cyclic_range(0,p-1,p))'//& + ' where lo=low(g)/b._b,hi=high(g)/b._b where p=b._p',& line) + call dcl_uproc(parser,'nodes_for_grid(b:block_cyclic_distr,g:strided_range){'//& + ' var r=0..0;if b._s==step(g) {r=nodes_for_grid(b,low(g)..low(g))} else'//& + ' {r=nodes_for_grid(b,low(g)..high(g))};return r}',line) call dcl_uproc(parser,'nodes_for_grid(b:block_cyclic_distr,g:block_seq){'//& - ' var r=0..b._p;'//& - ' if b._s==step(g) {r:=nodes_for_grid(b,low(g)..low(g)+width(g)-1)};return r}',line) + ' var r=cyclic_range(0,0,1);if b._s==step(g) {r=nodes_for_grid(b,low(g)..low(g)+width(g)-1)} else'//& + ' {r=nodes_for_grid(b,low(g)..high(g))};return r}',line) call dcl_uproc(parser,'node_for(b:block_cyclic_distr,j:int)=p'//& ' where p=_rdiv(jj,b._b) mod b._p where jj=int(j)',line) call dcl_uproc(parser,'index(b:block_cyclic_distr,j:int,p:int)=i'//& @@ -4696,23 +4872,34 @@ subroutine sysdefs(parser) ' where s=_rdiv(j,b._s)',line) call dcl_uproc(parser,'node_nhd(b:block_cyclic_distr,p:int,d:range(int))='//& 'p+(low(d)-b._b+1)/b._b..p+(high(d)+b._b-1)/b._b',line) - call dcl_uproc(parser,'node_co_nhd(b:block_cyclic_distr,p:int,d:range(int))='//& - 'p+(-low(d)+b._b-1)/b._b..p+(-high(d)-b._b+1)/b._b by -1',line) + call dcl_uproc(parser,'nodes_for_grid(b,g:single_point)=nodes_for_grid(b,g._t..g._t)',line) - ! Tuple of distributions +write(*,'(a)') '// Tuple of distributions' + call dcl_uproc(parser,& + 'distribute(dis:tuple(distr_template_dim),d:tuple(int),t:tuple(int))='//& + 'map($distribute,dis,d,t,p) where p=index2point(_this_node(),t)',line) + call dcl_uproc(parser,& + 'distribute(dis:distr_template_dim,d:tuple(int),t:tuple(int))='//& + 'map($distribute,spread(dis,d),d,t,p) where p=index2point(_this_node(),t)',line) + call dcl_uproc(parser,& + 'distribute(dis:null,d:tuple(int),t:tuple(int))=distribute(VBLOCK,d,t)',line) + call dcl_uproc(parser,& + 'nodes_needed(b:tuple(distr_template_dim),g:tuple(int))=map($nodes_needed,b,g)',line) + call dcl_uproc(parser,& + 'nodes_needed(b:distr_template_dim,g:tuple(int))=map($nodes_needed,spread(b,g),g)',line) call dcl_uproc(parser,'node_for(b:tuple(distr_dim),j:tuple(int))='//& 'map($node_for,b,j)',line) call dcl_uproc(parser,'#(b:tuple(distr_dim))=shape(map($_shp,b))',line) call dcl_uproc(parser,'dims(b:tuple(distr_dim))=map($size,b)',line) - call dcl_uproc(parser,'_get_elem(b:tuple(distr_dim),i:tuple(int))'//& - '=map($_get_elem,b,i)',line) - call dcl_uproc(parser,'_get_elem(b:tuple(distr_dim),i:int)='//& - '_get_elem(b,index2point(i,dims(b)))',line) + call dcl_uproc(parser,'element(b:tuple(distr_dim),i:tuple(int))'//& + '=map($element,b,i)',line) + call dcl_uproc(parser,'element(b:tuple(distr_dim),i:int)='//& + 'element(b,index2point(i,dims(b)))',line) call dcl_uproc(parser,'tile_size(b:tuple(distr_dim),i:tuple(int))'//& '=map($tile_size,b,i)',line) call dcl_uproc(parser,'empty(b:tuple(distr_dim))=map($empty,b)',line) - call dcl_uproc(parser,'nodes_for_grid(b:tuple(distr_dim),g:grid)'//& + call dcl_uproc(parser,'nodes_for_grid(b:tuple(distr_dim),g:grid_slice)'//& '=map($nodes_for_grid,b,g)',line) call dcl_uproc(parser,'node_num_for(b:tuple(distr_dim),j:tuple(int))'//& '=index(dims(b),map($node_for,b,j))',line) @@ -4725,20 +4912,42 @@ subroutine sysdefs(parser) 'where i=index(b,j,p) where p=node_for(b,j)',line) call dcl_uproc(parser,'node_nhd(b:tuple,p:tuple,d:tuple)=map($node_nhd,b,p,d)',line) call dcl_uproc(parser,'node_co_nhd(b:tuple,p:tuple,d:tuple)=map($node_co_nhd,b,p,d)',line) - - ! ***************************************** - ! SUPPORT FOR PARALLEL STATEMENTS - ! ***************************************** - ! Get and set elements in "for" - call dcl_uproc(parser,'PM__getelem(x:grid_slice_dim,y)=_get_elem(x,y)',line) - call dcl_uproc(parser,'PM__getelem(x:grid_slice,y)=_get_elem(x,y)',line) +write(*,'(a)') '// Slice of a tuple of distributions' + call dcl_type(parser,'sliced_distr(t,s) is rec{_t:t,_s:s}',line) + call dcl_uproc(parser,'sliced_distr(t:tuple(distr_dim),s:tuple(seq(int) or single_point(int)))='//& + 'new sliced_distr{_t=t,_s=s}',line) + call dcl_uproc(parser,'node_for(t:sliced_distr,j:tuple(int))=node_for(t._t,t._s[j])',line) + call dcl_uproc(parser,'#(t:sliced_distr)=#t._t',line) + call dcl_uproc(parser,'dims(t:sliced_distr)=dims(t._t)',line) + call dcl_uproc(parser,'element(t:sliced_distr,i:tuple(int) or int)=overlap(t._s,element(t._t,i))',line) + call dcl_uproc(parser,'tile_size(t:sliced_distr,i:tuple(int) or int)=dims(element(t,i))',line) + call dcl_uproc(parser,'empty(t:sliced_distr)=new sliced_distr{_t=empty(t._t),_s=t._s}',line) + call dcl_uproc(parser,'nodes_for_grid(t:sliced_distr,g:grid)=nodes_for_grid(t._t,t._s[g])',line) + call dcl_uproc(parser,'node_num_for(t:sliced_distr,j:tuple(int))'//& + '=node_num_for(t._t,t._s[j])',line) + call dcl_uproc(parser,'index(t:sliced_distr,j:tuple(int),p:tuple(int))='//& + 'index(tile_size(t,p),element(t,p)#j)',line) + call dcl_uproc(parser,'node_and_index(t:sliced_distr,j:int)=p,i'//& + ' where i=index(t,j,p) where p=node_for(t,j)',line) + call dcl_uproc(parser,'node_nhd(t:sliced_distr,p:tuple,d:tuple)=node_nhd(t._t,p,_stpmult(d,t._s))',line) + call dcl_uproc(parser,'node_co_nhd(t:sliced_distr,p:tuple,d:tuple)=node_co_nhd(t._t,p,_stpmult(d,t._s))',line) + call dcl_uproc(parser,'_stpmult(d:tuple,s:tuple)=map($_stpmult,d,s)',line) + call dcl_uproc(parser,'_stpmult(d:range,s:range)=d',line) + call dcl_uproc(parser,& + '_stpmult(d:range,s:strided_range)=if(st>0=>st*low(d)..st*high(d),st*high(d)..st*low(d)) where st=step(s)',line) + +write(*,'(a)') '// *****************************************' +WRITE(*,'(A)') '// SUPPORT FOR PARALLEL STATEMENTS' +write(*,'(a)') '// *****************************************' + +write(*,'(a)') '// Get and set elements in "for"' + call dcl_uproc(parser,'PM__getelem(x:grid_slice_dim or cyclic_range,y)=element(x,y)',line) + call dcl_uproc(parser,'PM__getelem(x:grid_slice or iterable_grid,y)=element(x,y)',line) call dcl_uproc(parser,'PM__getelem(a:any^mshape,t)=_get_aelem(a,index(dims(a),t))',line) - call dcl_uproc(parser,'PM__getelem(a:array_slice(any^any,),y)=_get_elem(a,y)',line) + call dcl_uproc(parser,'PM__getelem(a:array_slice(any^any,),y)=element(a,y)',line) call dcl_uproc(parser,'PM__getelem(x:array_template,y)=x._a',line) -!!$ call dcl_uproc(parser,'PM__getelem(a:any^dshape,t)=_get_aelem(a,i) '//& -!!$ 'check p==_this_node() where p,i=node_and_index(_shape(a).dist,_tup(t))',line) - call dcl_uproc(parser,'PM__getelem(a:any^dshape,t)=_get_elem(a,(#a)[t])',line) + call dcl_uproc(parser,'PM__getelem(a:any^dshape,t)=element(a,(#a)[t])',line) call dcl_uproc(parser,'PM__setelem(&x,v,y) {_set_elem(&x,v,(#x)[y])}',line) call dcl_uproc(parser,'PM__setelem(&a:any^mshape,v,t:index)'//& @@ -4749,31 +4958,38 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__setelem(&a:array_slice(any^any,),v,t:index) {'//& ' _set_elem(&a._a,v,a._s[t]) }',line) - call dcl_uproc(parser,'PM__get_elem%(x:shared,i,h)=PM__getelem(x,h)',line) - call dcl_uproc(parser,'PM__set_elem%(&x:shared,v:complete,i,h)'//& - '{PM__setelem(&x,v,h <>);_assemble(&x,region <>)}',line) + call dcl_uproc(parser,'PM__get_elem%(x,i,h)=PM__getelem(x,h)',line) + call dcl_uproc(parser,'PM__set_elem%(&x:invar,v:complete,i,h)'//& + '{PM__setelem(&x,v,h <>);_assemble%(&x,region)}',line) call dcl_uproc(parser,'PM__get_elem%(x:shared any^dshape,i,h)='//& - '_get_elem(PM__local(x),i)',line) - call dcl_uproc(parser,'PM__set_elem%(&x:shared any^dshape,v:complete,i,h) '//& - '{_set_elem(&x,v,i <>)}',line) + 'element(PM__local(x),i)',line) + call dcl_uproc(parser,'PM__set_elem%(&x:invar any^dshape,v:complete,i,h) '//& + '{_set_elem(&^(PM__local(^(&x))),v,i <>)}',line) - call dcl_uproc(parser,'_assemble(&a:any^mshape,region:mshape) {}',line) + call dcl_uproc(parser,'PM__get_elem%(x:shared array_slice(any^dshape),j,h)='//& + '_get_aelem(x._a,i) check p==_this_node() '//& + ' where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h])',line) !!!!! + call dcl_uproc(parser,'PM__set_elem%(&x:invar array_slice(any^dshape),v:complete,j,h){'//& + 'PM__setaelem(&x._a,i,v <>) check p==_this_node() '//& + ' where p,i=node_and_index((#x._a).dist,(#x._a)._mshape._extent#x._s[h]) }',line) !!! + + call dcl_uproc(parser,'_assemble%(&a:invar any^mshape,xregion:invar mshape) {}',line) - call dcl_uproc(parser,'_assemble(&a:array_slice(any^shape,),region:mshape) {}',line) + call dcl_uproc(parser,'_assemble%(&a:invar array_slice(any^shape,),xregion:invar mshape) {}',line) - call dcl_uproc(parser,'_assemble(&a:any^mshape,region) {'//& - ' dist=region.dist; '//& + call dcl_uproc(parser,'_assemble%(&a:invar any^mshape,xregion:invar) shared <> {'//& + ' dist=xregion.dist; '//& ' foreach p in #(dist) {'//& ' tile=dist[p];'//& ' i=index(dims(dist),p);'//& ' if i==_this_node() {'//& - ' for j in tile <>{ '//& + ' forall j in tile { '//& ' var k=PM__getelem(a,j); '//& ' PM__broadcast(&k,i)'//& ' };'//& ' } else { '//& - ' for j in tile <>{ '//& + ' forall j in tile { '//& ' var k=_arb(a);'//& ' PM__broadcast(&k,i);'//& ' PM__setelem(&a,k,j <>)'//& @@ -4782,18 +4998,18 @@ subroutine sysdefs(parser) ' } }',& line) - call dcl_uproc(parser,'_assemble(&a:array_slice(any^shape,),region) {'//& - ' dist=region.dist; '//& + call dcl_uproc(parser,'_assemble%(&a:invar array_slice(any^shape,),xregion:invar) shared <> {'//& + ' dist=xregion.dist; '//& ' foreach p in #(dist) {'//& ' tile=intersect((#(a._a))#a._s,dist[p]);'//& ' i=index(dims(dist),p);'//& ' if i==_this_node() {'//& - ' for j in tile <>{ '//& + ' forall j in tile { '//& ' var k=PM__getelem(a._a,j); '//& ' PM__broadcast(&k,i)'//& ' };'//& ' } else { '//& - ' for j in tile <>{ '//& + ' forall j in tile { '//& ' var k=_arb(a._a);'//& ' PM__broadcast(&k,i);'//& ' PM__setelem(&a._a,k,j <>)'//& @@ -4802,52 +5018,53 @@ subroutine sysdefs(parser) ' } }',& line) - ! Support for % procs +write(*,'(a)') '// Support for % procs' call dcl_uproc(parser,'PM__get_tilesz(d)=d._tile,d._size',line) call dcl_uproc(parser,'PM__get_tilesz(d:mshape)=d,size(d)',line) - ! Support for @ operator - if(pm_is_compiling) then +write(*,'(a)') '// Support for ! operator' + write(*,'(a)') 'PM__if_compiling' call dcl_uproc(parser,& - 'PM__makearray%(x:chan)<>=_makearray(x,region,size(region))',line) + 'PM__makearray%(x:chan) complete <>=_makearray(x,region,size(region))',line) call dcl_uproc(parser,& 'PM__makearray%(x:priv)=_makearray(x,region,size(region))'//& - ':test "Can only apply ""@"" to a ""chan"" " => ''false',line) + ':test "Can only apply ""!"" to a ""chan"" " => ''false',line) call dcl_uproc(parser,& 'PM__makearray%(x:invar)=_makearray(x,region,size(region))'//& - ':test "Cannot apply ""@"" to a ""shared"" or ""uniform"" value" => ''false',line) + ':test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => ''false',line) call dcl_proc(parser,& '_makearray(x:any,y:any,z:any)->PM__invar_dim x,y',& - op_make_array,0,line,proc_needs_type) - else + "make_array",0,line,proc_needs_type) +write(*,'(a)') 'PM__else' call dcl_uproc(parser,& - 'PM__makearray%(x:chan)<>=_makearray(x,region)',line) + 'PM__makearray%(x:chan) complete <>=_makearray(x,region)',line) call dcl_uproc(parser,& 'PM__makearray%(x:priv)=_makearray(x,region)'//& - ':test "Can only apply ""@"" to a ""chan"" " => ''false',line) + ':test "Can only apply ""!"" to a ""chan"" " => ''false',line) call dcl_uproc(parser,& 'PM__makearray%(x:invar)=_makearray(x,region)'//& - ':test "Cannot apply ""@"" to a ""shared"" or ""uniform"" value" => ''false',line) + ':test "Cannot apply ""!"" to a ""shared"" or ""uniform"" value" => ''false',line) call dcl_proc(parser,& '_makearray(x:any,y:any)->PM__dim x,y',& - op_make_array,0,line,proc_needs_type) + "make_array",0,line,proc_needs_type) !!$ call dcl_uproc(parser,'PM__correctarray(x)=_redim(PM__export - endif +write(*,'(a)') 'PM__endif' - ! active%() intrinsic - call dcl_uproc(parser,'active%(x)=masked(^(x,coherent),^(^??,coherent) <>)',line) +write(*,'(a)') '// active%() intrinsic' + call dcl_uproc(parser,'active%(x)=_masked%(^(x,coherent),^(^??,coherent) <>)',line) + call dcl_uproc(parser,'_masked%(x) complete <>=masked(x)',line) call dcl_uproc(parser,'active%()=^(^??,coherent)',line) - call dcl_proc(parser,'PM__active()->bool',op_active,0,line,0) + call dcl_proc(parser,'PM__active()->bool',"active",0,line,0) - ! Imports and exports +write(*,'(a)') '// Imports and exports' call dcl_proc(parser,'_import_val(x:any)->=x',& - op_import_val,0,line,0) + "import_val",0,line,0) call dcl_proc(parser,'PM__importshrd(x:any)->=x',& - op_import_val,0,line,0) + "import_val",0,line,0) call dcl_proc(parser,'PM__importvarg(x:any)->=x',& - op_import_varg,0,line,proc_is_not_inlinable) + "import_varg",0,line,proc_is_not_inlinable) call dcl_proc(parser,'_import_scalar(x:any)->invar x',& - op_import_scalar,0,line,0) + "import_scalar",0,line,0) call dcl_uproc(parser,'PM__import_val(x) {PM__checkimp(x);return _import_val(x)}',line) call dcl_uproc(parser,'PM__impscalar(x) {PM__checkimp(x);return _import_scalar(x)}',line) call dcl_uproc(parser,'PM__import_val(x:^*(,,,,)) {'//& @@ -4867,21 +5084,21 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'subregion(schedule:null)=null',line) call dcl_uproc(parser,'subtile(schedule:schedule)=schedule._subtile',line) - ! Over statements - call dcl_uproc(parser,'PM__over%(schedule:null,x:invar,block:invar)<>='//& - 'new schedule{_subregion=x,_subtile=overlap(region._tile,x),_blocking=_blocking(block,region)}',line) - call dcl_uproc(parser,'PM__over%(x:invar,block:invar)<>='//& +write(*,'(a)') '// Over statements' + call dcl_uproc(parser,'PM__over%(schedule:null,x:invar,block:invar) shared <>='//& + 'new schedule{_subregion=x,_subtile=overlap(region._tile,x),_blocking=_blocking(block,region)}',line) + call dcl_uproc(parser,'PM__over%(x:invar,block:invar) shared <>='//& 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& 'where s=intersect(x,schedule._subregion)',line) call dcl_uproc(parser,'PM__make_over%(schedule:null,'//& - 'x:invar tuple(subs_dim except stretch_dim),block:invar)<>='//& + 'x:invar tuple(subs_dim except stretch_dim),block:invar) shared <>='//& 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& 'check "Value"++s++" in ""over"" out of bounds: "++region._extent=>region._extent inc s '//& - 'where s=fill_in(region._extent,x)',line) + 'where s=fill_in(region._extent,x,null)',line) call dcl_uproc(parser,'PM__make_over%(x:invar tuple(subs_dim except stretch_dim)'//& - ',block:invar)<>='//& + ',block:invar) shared <>='//& 'new schedule{_subregion=s,_subtile=overlap(region._tile,s),_blocking=_blocking(block,region)}'//& - 'where s=intersect(map($norm,fill_in(region._extent,x)),schedule._subregion)',line) + 'where s=intersect(map($norm,fill_in(region._extent,x,''true)),schedule._subregion)',line) call dcl_uproc(parser,'PM__make_over%(x:invar,block)=x'//& ' check "Expression in an ""over"" statement must be a subscript tuple"=>''false',line) call dcl_uproc(parser,'PM__make_over%(x,block)=x'//& @@ -4894,50 +5111,50 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_blocking(b,region)=null {'//& 'test "Blocking factor must be a tuple of integers"=>''false}',line) call dcl_uproc(parser,'_blocking(b:null,region)=null',line) - - - if(.not.pm_is_compiling) then - call dcl_uproc(parser,'PM__do_over%(x:null)=true',line) - call dcl_uproc(parser,'PM__do_over%(x:invar schedule(tuple(seq or block_seq)))=here in x._subregion',line) - call dcl_uproc(parser,'PM__do_over%(x:invar schedule(grid))=PM__do_over%(schedule._subtile)',line) - call dcl_uproc(parser,'PM__do_over%(x:invar grid) <>'//& - '{chan var t=false;'//& - ' _in(x,&^(PM__local(^(&t@))) <>);'//& - ' return t}',line) - call dcl_uproc(parser,'PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x',line) - call dcl_uproc(parser,'_in(x,&t){for i in x <>{sync t[i]:=true}}',line) - else + + + write(*,'(a)') 'PM__if_compiling' call dcl_uproc(parser,'PM__do_over(x:null,region)=x',line) call dcl_uproc(parser,'PM__do_over(x:schedule,region)='//& '_st(map_apply($_do_elem,$_st,x._subtile),_ldims(region),x._blocking)',line) call dcl_uproc(parser,'_do_elem(x:range(int))=_st(low(x),high(x))',line) call dcl_uproc(parser,'_do_elem(x:strided_range(int))=_st(low(x),high(x),step(x))',line) call dcl_uproc(parser,'_do_elem(x:block_seq)=_st(low(x),high(x),step(x),width(x),align(x))',line) - call dcl_uproc(parser,'_do_elem(x:map_seq)=x.array',line) + call dcl_uproc(parser,'_do_elem(x:map_seq)=_st(x.array,size(x.array),null,null)',line) call dcl_uproc(parser,'_do_elem(x:single_point)=_st(x._t)',line) call dcl_uproc(parser,'PM__nested_loop(x:null){}',line) - call dcl_proc(parser,'PM__nested_loop(any)',op_nested_loop,0,line,0) + call dcl_proc(parser,'PM__nested_loop(any)',"nested_loop",0,line,0) call dcl_uproc(parser,'_ldims(x:mshape)=map_apply($size,$_st,x._extent)',line) call dcl_uproc(parser,'_ldims(x:dshape)=map_apply($size,$_st,x._tile)',line) - endif +write(*,'(a)') 'PM__else' + call dcl_uproc(parser,'PM__do_over%(x:null)=true',line) + call dcl_uproc(parser,'PM__do_over%(x:invar schedule(tuple(seq or block_seq)))=here in x._subregion',line) + call dcl_uproc(parser,'PM__do_over%(x:invar schedule(grid))=PM__do_over%(schedule._subtile)',line) + call dcl_uproc(parser,'PM__do_over%(x:invar grid) complete <>'//& + '{chan var t=false;'//& + ' _in%(x,&^(PM__local(^(&t!))) <>);'//& + ' return t}',line) + call dcl_uproc(parser,'PM__do_over%(x:invar tuple(seq or block_seq),h:complete)=h in x',line) + call dcl_uproc(parser,'_in%(x:invar,&t:invar) shared <>{forall i in x {sync t[i]=true}}',line) +write(*,'(a)') 'PM__endif' - ! Parallel processing inquiry - call dcl_proc(parser,'_sys_node()->int',op_sys_node,0,line,0) - call dcl_proc(parser,'sys_nnode()->int',op_sys_nnode,0,line,0) - call dcl_proc(parser,'_this_node()->int',op_this_node,1,line,0) - call dcl_proc(parser,'this_node%(r:any,s:any,h:any)->int',op_this_node,2,line,0) - call dcl_proc(parser,'this_nnode()->int',op_this_nnode,0,line,0) - call dcl_proc(parser,'_shrd_node()->int',op_shared_node,0,line,0) - call dcl_proc(parser,'shrd_nnode()->int',op_shared_nnode,0,line,0) - call dcl_proc(parser,'_root_node()->int',op_root_node,0,line,0) - call dcl_proc(parser,'is_shrd()->bool',op_is_shared,0,line,0) - call dcl_proc(parser,'is_shrd(any)->bool',op_is_shared,0,line,0) - call dcl_proc(parser,'is_par()->bool',op_is_par,0,line,0) +write(*,'(a)') '// Parallel processing inquiry' + call dcl_proc(parser,'_sys_node()->int',"sys_node",0,line,0) + call dcl_proc(parser,'sys_nnode()->int',"sys_nnode",0,line,0) + call dcl_proc(parser,'_this_node()->int',"this_node",1,line,0) + call dcl_proc(parser,'this_node%(r:any,s:any,h:any)->int',"this_node",2,line,0) + call dcl_proc(parser,'this_nnode()->int',"this_nnode",0,line,0) + call dcl_proc(parser,'_shrd_node()->int',"shared_node",0,line,0) + call dcl_proc(parser,'shrd_nnode()->int',"shared_nnode",0,line,0) + call dcl_proc(parser,'_root_node()->int',"root_node",0,line,0) + call dcl_proc(parser,'is_shrd()->bool',"is_shared",0,line,0) + call dcl_proc(parser,'is_shrd(any)->bool',"is_shared",0,line,0) + call dcl_proc(parser,'is_par()->bool',"is_par",0,line,0) call dcl_uproc(parser,'_head_node()=_shrd_node()==0',line) - ! Parallel system nested contexts +write(*,'(a)') '// Parallel system nested contexts' call dcl_proc(parser,'_push_node_grid(arg...:any)',& - op_push_node_grid,0,line,proc_is_impure+proc_has_for) + "push_node_grid",0,line,proc_is_impure+proc_has_for) call dcl_uproc(parser,'_push_node(d:int,t:int){'//& '_push_node_grid(false,t)}',line) call dcl_uproc(parser,'_push_node(d:tuple1d,t:tuple1d,e:tuple1d) { '//& @@ -4965,26 +5182,26 @@ subroutine sysdefs(parser) 'is_cyclic(e.4),is_cyclic(e.5),is_cyclic(e.6),is_cyclic(e.7),'//& 't.1,t.2,t.3,t.4,t.5,t.6,t.7) }',line) - call dcl_proc(parser,'_push_node_split(int)',op_push_node_split,& + call dcl_proc(parser,'_push_node_split(int)',"push_node_split",& 0,& line,proc_is_impure+proc_has_for) - call dcl_proc(parser,'_push_node_conc()',op_push_node_conc,0,& + call dcl_proc(parser,'_push_node_conc()',"push_node_conc",0,& line,0) - call dcl_uproc(parser,'PM__pop_node(x:mshape) {}',line) - call dcl_proc(parser,'PM__pop_node(x:shape)',op_pop_node,0,line,0) - call dcl_proc(parser,'PM__pop_conc(bool)',op_pop_node_conc,& + call dcl_uproc(parser,'PM_pop_node(x:mshape) {}',line) + call dcl_proc(parser,'PM_pop_node(x:shape)',"pop_node",0,line,0) + call dcl_proc(parser,'PM_pop_conc(bool)',"pop_node_conc",& 0,line,0) - call dcl_proc(parser,'_push_node_dist()',op_push_node_distr,0,line,proc_is_impure+proc_has_for) + call dcl_proc(parser,'_push_node_dist()',"push_node_distr",0,line,proc_is_impure+proc_has_for) call dcl_uproc(parser,'_lvl()=1',line) - ! ************************************************ - ! PROCESSOR ALLOCATION - ! ************************************************ +write(*,'(a)') '// ************************************************' +WRITE(*,'(A)') '// PROCESSOR ALLOCATION' +write(*,'(a)') '// ************************************************' - call dcl_uproc(parser,& - 'PM__partition(pp:null,dd:dshape)='//& - ' dd._tile,#dd._mshape,null',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__partition(pp:null,dd:dshape)='//& +!!$ ' dd._tile,#dd._mshape,null',line) call dcl_uproc(parser,& 'PM__partition(pp,d:dshape) {'//& '_push_node_dist();return dd._tile,dd,null where dd=new dshape {_mshape=#d._mshape,dist=d.dist,'//& @@ -5005,7 +5222,7 @@ subroutine sysdefs(parser) line) call dcl_uproc(parser,'PM__partition(pp,d:mshape)=tile,shape,sched'//& ' where tile,shape,sched='//& - ' PM__partition(pp,d,VBLOCK,null,null,null,null,null)',line) + ' PM__partition(pp,d,null,null,null,null,null,null)',line) call dcl_uproc(parser,& 'PM__partition(pp,mshape:mshape,distr,topo,simplify,work,sched,block) {'//& ' d=dims(mshape);topol=topology(topo,distr,d,min(max(1,size(d)),shrd_nnode()));'//& @@ -5015,13 +5232,13 @@ subroutine sysdefs(parser) ' test "requested topology "++#dist++" larger than available processors: "++s++">"++np=>s<=np;'//& ' if s=s { '//& - ' p:=workshare(work,mshape,dist,s,p-s,shrd_nnode()-s) '//& + ' p=workshare(work,mshape,dist,s,p-s,shrd_nnode()-s) '//& ' };'//& ' _push_node_split(p) '//& ' } else { '//& - ' _push_node_dist() '//& + ' _push_node_dist()'//& ' }; '//& - ' elem=_get_elem(dist,p); elemsz=#elem; '//& + ' elem=element(dist,p); elemsz=#elem; '//& ' dd=new dshape {_mshape=#mshape,dist=dist,_tile=elem,_tilesz=elemsz,'//& ' _size=size(elemsz),_level=_lvl()};'//& 'return dd._tile,dd,_block_schedule(block,dd) }',line) @@ -5036,55 +5253,6 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_block_schedule(block,region)='//& 'new schedule{_subregion=region,_subtile=region._tile,_blocking=_blocking(block,region)}',line) - call dcl_uproc(parser,& - 'topology(tp:null,dis,d:tuple,l:int)=cart_topo(int(d),dis,l)',line) - call dcl_uproc(parser,& - 'topology(tp,dis,d,l:int)=tp',line) - - call dcl_type(parser,& - 'distr_template is null,distr_template_dim,tuple(distr_template_dim),...',line) - call dcl_type(parser,& - 'distr_template_dim is null,vblock_template,'//& - 'block_template,cyclic_template,block_cyclic_template,...',line) - call dcl_type(parser,'vblock_template is unique{VBLOCK}',line) - call dcl_type(parser,'_block_template is rec{block:int}',line) - call dcl_type(parser,'_block_template_default is unique{BLOCK}',line) - call dcl_type(parser,& - 'block_template is _block_template_default,_block_template',line) - call dcl_uproc(parser,& - 'BLOCK(block:int)=new _block_template {block=block}',line) - call dcl_type(parser,'cyclic_template is unique{CYCLIC}',line) - call dcl_type(parser,'block_cyclic_template is rec {block:int}',line) - call dcl_uproc(parser,'BLOCK_CYCLIC(block:int)=new block_cyclic_template{block=block}',line) - - call dcl_uproc(parser,& - 'distribute(dis:tuple(distr_template_dim),d:tuple(int),t:tuple(int))='//& - 'map($distribute,dis,d,t):print("Topo:"++t)',line) - call dcl_uproc(parser,& - 'distribute(dis:distr_template_dim,d:tuple(int),t:tuple(int))='//& - 'map($distribute,spread(dis,d),d,t)',line) - call dcl_uproc(parser,& - 'distribute(dis:null,d:tuple(int),t:tuple(int))=distribute(VBLOCK,d,t)',line) - - call dcl_uproc(parser,& - 'distribute(dis:null,d:int,t:int)='//& - 'no_distr(d,t)',line) - call dcl_uproc(parser,& - 'distribute(dis:vblock_template,d:int,t:int)='//& - 'vblock_distr(d,t)',line) - call dcl_uproc(parser,& - 'distribute(dis:_block_template,d:int,t:int)='//& - 'block_distr(d,t,dis.block)',line) - call dcl_uproc(parser,& - 'distribute(dis:block_template,d:int,t:int)='//& - 'block_distr(d,t)',line) - call dcl_uproc(parser,& - 'distribute(dis:cyclic_template,d:int,t:int)='//& - 'cyclic_distr(d,t)',line) - call dcl_uproc(parser,& - 'distribute(dis:block_cyclic_template,d:int,t:int)='//& - 'block_cyclic_distr(d,t,dis.block)',line) - call dcl_uproc(parser,& 'workshare(work:null,d,dist,nnode:int,'//& 'snode:int,nsnode:int)='//& @@ -5095,42 +5263,43 @@ subroutine sysdefs(parser) 'conform(#work,#d); '//& 'var wk=work;return _wshare(wk,nnode,snode,nsnode) }',line) call dcl_proc(parser,& - '_wshare(int^any,int,int,int)->int',op_wshare,0,line,0) + '_wshare(int^any,int,int,int)->int',"wshare",0,line,0) - ! ************************************************************* - ! I/O OPERATIONS - ! ************************************************************* +write(*,'(a)') '// *************************************************************' +WRITE(*,'(A)') '// I/O OPERATIONS' +write(*,'(a)') '// *************************************************************' - ! Built-in operators +write(*,'(a)') '// Built-in operators' call dcl_proc(parser,'_open_file(string,bool,bool,bool,bool,bool,bool,bool)->sint,sint',& - op_open_file,0,line,proc_is_impure+proc_is_variant) + "open_file",0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_close_file(sint)->sint',& - op_close_file,0,line,proc_is_impure+proc_is_variant) + "close_file",0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_seek_file(sint,lint)->sint',& - op_seek_file,0,line,proc_is_impure+proc_is_variant) + "seek_file",0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_read_file(sint,&any)->sint',& - op_read_file,0,line,proc_is_impure+proc_is_variant) + "read_file",0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_write_file(sint,any)->sint',& - op_write_file,0,line,proc_is_impure+proc_is_variant) + "write_file",0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_read_file_array(sint,&any,int)->sint',& - op_read_file_array,0,line,proc_is_impure+proc_is_variant) + "read_file_array",0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_write_file_array(sint,any,int)->sint',& - op_write_file_array,0,line,proc_is_impure+proc_is_variant) + "write_file_array",0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_read_file_tile%(any,any,any,sint,&any,int,int)->sint',& - op_read_file_tile,0,line,proc_is_impure+proc_is_dcomm+proc_is_variant) + "read_file_tile",0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_write_file_tile%(any,any,any,sint,any,int,int)->sint',& - op_write_file_tile,0,line,proc_is_impure+proc_is_dcomm+proc_is_variant) + "write_file_tile",0,line,proc_is_impure+proc_is_file) call dcl_proc(parser,'_io_error_string(sint)->string',& - op_io_error_string,0,line,proc_is_impure) + "io_error_string",0,line,proc_is_impure) - ! IO/related types +write(*,'(a)') '// IO/related types' call dcl_type(parser,'io_type is num,bool',line) call dcl_type(parser,'filesystem is rec{_tag:PM__distr_tag}',line) call dcl_type(parser,'file is struct {_f:sint,_tag:PM__distr_tag}',line) call dcl_type(parser,'io_error is rec {_errno:sint,use _iserr:bool}',line) call dcl_uproc(parser,'PM__filesys()=new filesystem{}',line) +!write(*,'(a)') '// call dcl_uproc(parser,'PM__filesys()=0',line)' - ! Basic operations +write(*,'(a)') '// Basic operations' call dcl_uproc(parser,'open(&filesystem:filesystem,name,'//& 'append=false,create=false,temp=false,'//& 'excl=false,read=false,write=false,seq=false)=new file {_f=f},_make_file_error(err) '//& @@ -5146,7 +5315,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'write(&f:file,x:io_type)'//& '{err=_write_file(f._f,x);return _make_file_error(err)}',line) - ! Array I/O +write(*,'(a)') '// Array I/O' call dcl_uproc(parser,& 'read(&f:file,&x:io_type^mshape)'//& '{err=_read_file_array(f._f,&x,size(x));return _make_file_error(err)}',line) @@ -5155,13 +5324,13 @@ subroutine sysdefs(parser) '{err=_write_file_array(f._f,x,size(x));return _make_file_error(err)}',line) call dcl_uproc(parser,& 'read(&f:file,&x:io_type^dshape) '//& - '{var err=_make_file_error(0''s);for i in x:err:=read%(&f,&i);return err}',& + '{var err=_make_file_error(0''s);for i in x:err=read%(&f,&i);return err}',& line) call dcl_uproc(parser,& 'write(&f:file,x:io_type^dshape) '//& - '{var err=_make_file_error(0''s);for i in x:err:=write%(&f,i)}',line) + '{var err=_make_file_error(0''s);for i in x:err=write%(&f,i)}',line) - ! Distributed I/O +write(*,'(a)') '// Distributed I/O' call dcl_uproc(parser,'partition%(f:filesystem)=f:test "Partition not yet implemented"=>''false',line) call dcl_uproc(parser,& 'read%(&f:shared file,&x:complete io_type)'//& @@ -5172,7 +5341,7 @@ subroutine sysdefs(parser) '{err=_write_file_tile%(f._f,x,index(dims(region._mshape),here),size(region._mshape));'//& 'return _make_file_error(err)}',line) - ! Error trapping versions of I/O routines +write(*,'(a)') '// Error trapping versions of I/O routines' call dcl_uproc(parser,'string(error:io_error)=_io_error_string(error._errno)',line) call dcl_uproc(parser,'open(&f:filesystem,name:string,key...) {file,error=open(&f,name,key...);'//& ' test "Error opening file """++name++""": "++error=>not(error);return file}',line) @@ -5189,11 +5358,11 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'write%(&f:shared file,x) '//& '{error=write%(&f,x);test "Error writing to file:"=>not(error)}',line) - ! ************************************************************* - ! SUPPORT PROCEDURES FOR COMMUNICATING OPERATIONS - ! ************************************************************* +write(*,'(a)') '// *************************************************************' +WRITE(*,'(A)') '// SUPPORT PROCEDURES FOR COMMUNICATING OPERATIONS' +write(*,'(a)') '// *************************************************************' - ! SOA tuples +write(*,'(a)') '// SOA tuples' call dcl_type(parser,'_stuple1d is rec^{t1}',line) call dcl_type(parser,'_stuple2d is rec^{t1,t2}',line) call dcl_type(parser,'_stuple3d is rec^{t1,t2,t3}',line) @@ -5217,12 +5386,12 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& '_st(t1,t2,t3,t4,t5,t6,t7)=new _stuple7d{t1=t1,t2=t2,t3=t3,t4=t4,t5=t5,t6=t6,t7=t7}',line) - ! Create normalised form of a grid used for _xxx_slice operations +write(*,'(a)') '// Create normalised form of a grid used for _xxx_slice operations' call dcl_uproc(parser,'_norm(n,x:seq or block_seq)=_st(n,low(x),high(x),step(x),width(x),align(x))',line) - call dcl_uproc(parser,'_norm(n,x:map_seq)=_st(x.array)',line) + call dcl_uproc(parser,'_norm(n,x:map_seq)=_st(x.array,n)',line) call dcl_uproc(parser,'_norm(n,x:grid)=_st(map_apply($_norm,$_st,n,x),size(x))',line) - ! Apply idxdim index and convert to normal for for _send_slice_mapped +write(*,'(a)') '// Apply idxdim index and convert to normal for for _send_slice_mapped' call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:single_point)='//& '_st(m,t,t,1,1,0) where t=_dmap(x,n._t)',line) call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:range)='//& @@ -5234,7 +5403,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:block_seq)='//& '_dnorm(x,m,map_seq(n))',line) call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:map_seq){'//& - 'var a=array(0,#n._array);for i in a,j in n._array <>:i:=_dmap(x,j);return _st(a)}',line) + 'var a=array(0,#n._array);forall i in a,j in n._array:i=_dmap(x,j);return _st(a)}',line) call dcl_uproc(parser,'_dnorm(x:indexed_dim(''1),m,n:grid)='//& '_st(map_apply($_dnorm,$_st,x,m,n),size(n))',line) @@ -5246,18 +5415,18 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& '_send_slice(p,x:_comp^any,d) { '//& - 'for i in d <>{ _isend_offset%(j,p,x) '//& + 'forall i in d { _isend_offset%(j,p,x) '//& 'where j=index(#x,i) } }',line) call dcl_uproc(parser,& '_send_slice(p,x,d) { '//& '_isend_offset(_norm(dims(x),d),p,x) }',line) call dcl_uproc(parser,& '_send_slice_mapped(p,x,d,t,s) { '//& - 'for k in d <>{ _isend_offset%(j,p,x) '//& + 'forall k in d { _isend_offset%(j,p,x) '//& 'where j=index(dims(s),s#i) where i=_dmap(t,k)}}',line) call dcl_uproc(parser,& '_send_slice_mapped(p,x:_comp^any,d,t:indexed_dim(''1),s) { '//& - 'for k in d <>{ _isend_offset%(j,p,x) '//& + 'forall k in d { _isend_offset%(j,p,x) '//& 'where j=index(dims(s),s#i) where i=_dmap(t,k)}}',line) call dcl_uproc(parser,& '_send_slice_mapped(p,x,d,t:indexed_dim(''1),s) { '//& @@ -5265,122 +5434,131 @@ subroutine sysdefs(parser) call dcl_uproc(parser,& '_recv_slice(p,&x:_comp^any,d) { '//& - 'for i in d <>{ _irecv_offset%(j,p,&x) '//& + 'forall i in d { _irecv_offset%(j,p,&x) '//& 'where j=index(#x,i) } }',line) call dcl_uproc(parser,& '_recv_slice(p,&x,d) { '//& '_irecv_offset(_norm(dims(x),d),p,&x) }',line) call dcl_uproc(parser,& '_recv_slice_sync(p,&x:_comp^any,d) { '//& - 'for i in d <>{ _recv_offset%(j,p,&x) '//& + 'forall i in d { _recv_offset%(j,p,&x) '//& 'where j=index(#x,i) } }',line) call dcl_uproc(parser,& '_recv_slice_sync(p,&x,d) { '//& '_recv_offset(_norm(dims(x),d),p,&x) }',line) - call dcl_uproc(parser,& - '_recv_slice_resend(p,&x:_comp^any,d) { '//& - 'for i in d <>{ _recv_resend%(j,p,&x) '//& - 'where j=index(#x,i) } }',line) - call dcl_uproc(parser,& - '_recv_slice_resend(p,&x,d) { '//& - '_recv_resend(_norm(dims(x),d),p,&x) }',line) - call dcl_uproc(parser,& - '_send_recv_slice_req(p,&x:_comp,a,sx,d,c:''true) {'//& - 'for i in d <>{ j=index(sx,i);'//& + call dcl_uproc(parser,'_bcast_slice_shared(&x,d){_bcast_shared_offset(_norm(dims(x),d),&x)}',line) +!!$ call dcl_uproc(parser,& +!!$ '_recv_slice_resend(p,&x:_comp^any,d) { '//& +!!$ 'forall i in d { _recv_resend%(j,p,&x) '//& +!!$ 'where j=index(#x,i) } }',line) +!!$ call dcl_uproc(parser,& +!!$ '_recv_slice_resend(p,&x,d) { '//& +!!$ '_recv_resend(_norm(dims(x),d),p,&x) }',line) + call dcl_uproc(parser,& + '_send_recv_slice_req(p,x:_comp,&a,sx,d,c:^^(''true)) {'//& + 'forall i in d { j=index(sx,i);'//& '_isend_recv_req%(j,p,^(x),&^(^(a))); '//& '} }',line) call dcl_uproc(parser,& - '_send_recv_slice_req(p,x,&a,sx,d,c:''true) {'//& + '_send_recv_slice_req(p,x,&a,sx,d,c:^^(''true)) {'//& '_isend_recv_req(_norm(dims(sx),d),p,^(x),&^(^(a)))}',line) call dcl_uproc(parser,& '_send_recv_slice_req(p,x,&a,sx,d,c) {'//& - 'for i in d <>{ j=index(sx,i);_isend_recv_req%(j,p,^(x),&^(^(a)),c) '//& + 'forall i in d { j=index(sx,i);_isend_recv_req%(j,p,^(x),&^(^(a)),c) '//& '} }',line) call dcl_uproc(parser,& - '_send_slice_assn(p,x:_comp,y,sx,d,c:''true) {'//& - 'for i in d <>{ _isend_assn%(j,^(p),^(x),^(y)) '//& + '_send_slice_assn(p,x:_comp,y,sx,d,c:^^(''true)) {'//& + 'forall i in d { _isend_assn%(j,^(p),^(x),^(y)) '//& 'where j=index(sx,i) } }',line) call dcl_uproc(parser,& - '_send_slice_assn(p,x,y,sx,d,c:''true) {'//& + '_send_slice_assn(p,x,y,sx,d,c:^^(''true)) {'//& '_isend_assn(_norm(dims(sx),d),p,x,y)}',line) call dcl_uproc(parser,& '_send_slice_assn(p,x,y,sx,d,c) {'//& - 'for i in d <>{ _isend_assn%(j,p,^(x),^(y),^(c)) '//& + 'forall i in d { _isend_assn%(j,p,^(x),^(y),^(c)) '//& 'where j=index(sx,i) } }',line) call dcl_uproc(parser,& - '_recv_slice_reply(p,&x:_comp,sx,d,c:''true) {'//& - 'for i in d <>{ _recv_reply%(j,^(p),&^(^(x))) '//& + '_recv_slice_reply(p,&x:_comp,sx,d,c:^^(''true)) {'//& + 'forall i in d { _recv_reply%(j,^(p),&^(^(x))) '//& 'where j=index(sx,i) } }',line) call dcl_uproc(parser,& - '_recv_slice_reply(p,&x,sx,d,c:''true) {'//& + '_recv_slice_reply(p,&x,sx,d,c:^^(''true)) {'//& '_recv_reply(_norm(dims(sx),d),p,&x) }',line) call dcl_uproc(parser,& '_recv_slice_reply(p,&x,sx,d,c) {'//& - 'for i in d <>{ _recv_reply%(j,p,&^(^(x)),c) '//& - 'where j=index(sx,i) } }',line) - call dcl_uproc(parser,& - '_bcast_slice(&x:_comp,sx,d,c:''true) {'//& - 'for i in d <>{ _bcast_slice_shared%(_gd(_norm(dims(sx),d),j,size(d)),_head_node(),&^(^(x))) '//& - 'where j=index(sx,i) } }',line) - call dcl_uproc(parser,& - '_bcast_slice(&x,sx,d,c:''true) {'//& - '_bcast_slice_shared(_gd(_norm(dims(sx),d),null,size(d)),_head_node(),&^(^(x)))}',line) - call dcl_uproc(parser,& - '_bcast_slice_shared(&x,sx,d,c) {'//& - 'for i in d <>{ _bcast_slice_shared%(j,_head_node(),&^(^(x)),c) '//& + 'forall i in d { _recv_reply%(j,p,&^(^(x)),c) '//& 'where j=index(sx,i) } }',line) + + +!!$ call dcl_uproc(parser,& +!!$ '_bcast_slice(&x:_comp,sx,d,c:''true) {'//& +!!$ 'forall i in d { _bcast_slice_shared%(_gd(_norm(dims(sx),d),j,size(d)),_head_node(),&^(^(x))) '//& +!!$ 'where j=index(sx,i) } }',line) +!!$ call dcl_uproc(parser,& +!!$ '_bcast_slice(&x,sx,d,c:''true) {'//& +!!$ '_bcast_slice_shared(_gd(_norm(dims(sx),d),null,size(d)),_head_node(),&^(^(x)))}',line) +!!$ call dcl_uproc(parser,& +!!$ '_bcast_slice_shared(&x,sx,d,c) {'//& +!!$ 'forall i in d { _bcast_slice_shared%(j,_head_node(),&^(^(x)),c) '//& +!!$ 'where j=index(sx,i) } }',line) call dcl_proc(parser,'_isend_offset%(r:any,s:any,h:any,j:any,p:any,x:any)',& - op_isend_offset,0,line,proc_is_impure+proc_is_dcomm) + "isend_offset",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_isend_offset(j:any,p:any,x:any)',& - op_isend_grid,0,line,proc_is_impure+proc_is_dcomm) + "isend_grid",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_irecv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any)',& - op_irecv_offset,0,line,proc_is_impure+proc_is_dcomm) + "irecv_offset",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_irecv_offset(j:any,p:any,&x:any)',& - op_irecv_grid,0,line,proc_is_impure+proc_is_dcomm) + "irecv_grid",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_recv_offset%(r:any,s:any,h:any,j:any,p:any,&x:any)',& - op_recv_offset,0,line,proc_is_impure+proc_is_dcomm) + "recv_offset",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_recv_offset(j:any,p:any,&x:any)',& - op_recv_grid,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_recv_resend%(r:any,s:any,h:any,j:any,p:any,&x:any)',& - op_recv_offset_resend,1,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_recv_resend(j:any,p:any,&x:any)',& - op_recv_grid_resend,1,line,proc_is_impure+proc_is_dcomm) + "recv_grid",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_bcast_shared_offset%(r:any,s:any,h:any,j:any,&x:any)',& + "bcast_shared_offset",0,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_bcast_shared_offset(j:any,&x:any)',& + "bcast_shared_grid",0,line,proc_is_impure+proc_is_dcomm) +!!$ call dcl_proc(parser,'_recv_resend%(r:any,s:any,h:any,j:any,p:any,&x:any)',& +!!$ "recv_offset_resend",1,line,proc_is_impure+proc_is_dcomm) +!!$ call dcl_proc(parser,'_recv_resend(j:any,p:any,&x:any)',& +!!$ "recv_grid_resend",1,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_isend(p:any,x:any)',& - op_isend,0,line,proc_is_impure+proc_is_dcomm) + "isend",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_irecv(p:any,&x:any)',& - op_irecv,0,line,proc_is_impure+proc_is_dcomm) + "irecv",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_recv(p:any,&x:any)',& - op_recv,0,line,proc_is_impure+proc_is_dcomm) + "recv",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any)',& - op_isend_req,0,line,proc_is_impure+proc_is_dcomm) + "isend_req",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_isend_recv_req(j:any,p:any,x:any,&a:any)',& - op_isend_req,0,line,proc_is_impure+proc_is_dcomm) + "isend_req",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_isend_recv_req%(r:any,s:any,h:any,j:any,p:any,x:any,&a:any,c:any)',& - op_isend_req,0,line,proc_is_impure+proc_is_dcomm) + "isend_req",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any)',& - op_isend_assn,0,line,proc_is_impure+proc_is_dcomm) + "isend_assn",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_isend_assn(j:any,p:any,x:any,y:any)',& - op_isend_assn,0,line,proc_is_impure+proc_is_dcomm) + "isend_assn",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_isend_assn%(r:any,s:any,h:any,j:any,p:any,x:any,y:any,c:any)',& - op_isend_assn,0,line,proc_is_impure+proc_is_dcomm) + "isend_assn",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any,c:any)',& - op_recv_reply,0,line,proc_is_impure+proc_is_dcomm) + "recv_reply",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_recv_reply%(r:any,s:any,h:any,j:any,p:any,&x:any)',& - op_recv_reply,0,line,proc_is_impure+proc_is_dcomm) + "recv_reply",0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,'_recv_reply(j:any,p:any,&x:any)',& - op_recv_reply,0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_bcast_slice_shared%(r:any,s:any,h:any,j:any,p:any,&x:any,c:any)',& - op_broadcast_disp,1,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_bcast_slice_shared%(r:any,s:any,h:any,j:any,p:any,&x:any)',& - op_broadcast_disp,1,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_bcast_slice_shared(j:any,p:any,&x:any)',& - op_broadcast_disp,1,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'_bcast_shared(&x:any)',op_broadcast_shared,0,line,proc_is_impure) + "recv_reply",0,line,proc_is_impure+proc_is_dcomm) +!!$ call dcl_proc(parser,'_bcast_slice_shared%(r:any,s:any,h:any,j:any,p:any,&x:any,c:any)',& +!!$ "broadcast_disp",1,line,proc_is_impure+proc_is_dcomm) +!!$ call dcl_proc(parser,'_bcast_slice_shared%(r:any,s:any,h:any,j:any,p:any,&x:any)',& +!!$ "broadcast_disp",1,line,proc_is_impure+proc_is_dcomm) +!!$ call dcl_proc(parser,'_bcast_slice_shared(j:any,p:any,&x:any)',& +!!$ "broadcast_disp",1,line,proc_is_impure+proc_is_dcomm) + call dcl_proc(parser,'_bcast_shared(&x:any)',"broadcast_shared",0,line,proc_is_impure) + call dcl_proc(parser,'_bcast_shared(&x:any,p:int)',"broadcast_shared",0,line,proc_is_impure) + call dcl_type(parser,'_ct is array_slice,^*(,,,,),any^any,^^(any)',line) call dcl_uproc(parser,'PM__sync_messages(x)<>:_sync_messages(x)',line) - if(pm_is_compiling) then + write(*,'(a)') 'PM__if_compiling' call dcl_uproc(parser,'_sync_messages(x:_ct):_do_sync_messages(_core(x))',line) call dcl_uproc(parser,'_sync_messages(x:_ct,y:_ct):_do_sync_messages(_core(x),_core(y))',line) call dcl_uproc(parser,'_core(x:any^any)=x',line) @@ -5389,44 +5567,45 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'_core(x:^*(,,,,))=_core(_v2(x))',line) call dcl_proc(parser,& '_do_sync_messages(arg...:^^(any) or any^any)',& - op_sync_mess,0,line,proc_is_impure+proc_is_dcomm) - else + "sync_mess",0,line,proc_is_impure+proc_is_dcomm) +write(*,'(a)') 'PM__else' call dcl_proc(parser,& '_sync_messages(arg...:_ct)',& - op_sync_mess,0,line,proc_is_impure+proc_is_dcomm) - endif + "sync_mess",0,line,proc_is_impure+proc_is_dcomm) +write(*,'(a)') 'PM__endif' call dcl_uproc(parser,'_tup(x:tuple)=x',line) call dcl_uproc(parser,'_tup(arg...)=tuple(arg...)',line) call dcl_uproc(parser,'_tup(x:null)=x',line) + call dcl_uproc(parser,'_tup%(x:invar) shared=_tup(x)',line) - call dcl_proc(parser,'PM__broadcast(&b:any,a:int)',op_broadcast,& + call dcl_proc(parser,'PM__broadcast(&b:any,a:int)',"broadcast",& 0,line,proc_is_impure+proc_is_dcomm) - call dcl_proc(parser,'PM__broadcast(b:any,a:int)->=b',op_broadcast_val,& + call dcl_proc(parser,'PM__broadcast(b:any,a:int)->=b',"broadcast_val",& 0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,& 'get_remote%(r:any,s:any,h:any,a:shared any^dshape,'//& 'b:int,c:int)->%a',& - op_get_remote_distr,& + "get_remote_distr",& 0,line,proc_is_impure+proc_is_dcomm) call dcl_proc(parser,& 'put_remote%(r:any,s:any,h:any,a:shared any^dshape,'//& 'b:any,c:int,d:int)',& - op_put_remote_distr,& + "put_remote_distr",& 0,line,proc_is_impure+proc_is_dcomm) - ! ******************************************************** - ! OTHER COMMUNICATING & ARRAY OPERATIONS - ! ******************************************************** +write(*,'(a)') '// ********************************************************' +WRITE(*,'(A)') '// OTHER COMMUNICATING & ARRAY OPERATIONS' +write(*,'(a)') '// ********************************************************' - call dcl_uproc(parser,'map(p:proc,x:any^any) {var z=array(_arb(x),#x);for i in z, j in x:i:=p.(j)}',line) + call dcl_uproc(parser,'map(p:proc,x:any^any) {var z=array(p.(_arb(x)),#x);for i in z, j in x:i=p.(j)}',line) call dcl_uproc(parser,'map(p:proc,x:any^any,y:any^any) '//& '{var z=array(p.(_arb(x),_arb(y)),#x);for i in z,j in x,k in y:i=p.(j,k)}',line) call dcl_uproc(parser,'map(p:proc,x:any^mshape,y:any^dshape) '//& - '{var z=array(p.(_arb(x),_arb(y)),#(y));for i in z,j in x,k in y:i:=p.(j,k)}',line) + '{var z=array(p.(_arb(x),_arb(y)),#(y));for i in z,j in x,k in y:i=p.(j,k)}',line) call dcl_uproc(parser,'map_const(p:proc,x:any^mshape,y:any)'//& - '{var z=array(p.(_arb(x),y),#x);for i in z,j in x:i:=p.(j,y)}',line) + '{var z=array(p.(_arb(x),y),#x);for i in z,j in x:i=p.(j,y)}',line) call dcl_uproc(parser,'+(x:num^any,y:num^any)=map($+,x,y)',line) call dcl_uproc(parser,'-(x:num^any,y:num^any)=map($-,x,y)',line) @@ -5446,7 +5625,7 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'min(x:real_num^any,y:real_num)=map_const($min,x,y)',line) call dcl_proc(parser,'_pack(v:any,any,any,d:any)->PM__dim v,d',& - op_pack,0,line,0) + "pack",0,line,0) call dcl_uproc(parser,'pack(v:any^mshape,m:bool^mshape) { '//& ' test "arrays do not conform"=>conform(#v,#m); '//& ' result =_pack(v,m,n,tuple(0..n-1)) where n=count(m) }',line) @@ -5455,27 +5634,25 @@ subroutine sysdefs(parser) ' return _pack(v,m,n,tuple(0..n-1))'//& ' where n=count(m) }',line) - - - ! Reduction +write(*,'(a)') '// Reduction' call dcl_type(parser,'associative_proc is $+,$*,$max,$min,'//& '$&,$|,$xor,$++,$==,...',line) - if(pm_is_compiling) then + write(*,'(a)') 'PM__if_compiling' call dcl_uproc(parser,'reduce(p:proc,x:array(,mshape)) {'//& 'var s=_get_aelem(x,0);'//& 'foreach i in 1..size(#x)-1 {'//& - 's:=p.(s,_get_aelem(x,i))'//& + 's=p.(s,_get_aelem(x,i))'//& '};return s}',line) - else +write(*,'(a)') 'PM__else' call dcl_uproc(parser,'reduce(p:proc,x:array(,mshape)) {'//& 'var y=x;var n=size(x);'//& 'while n>1 {'//& ' var m=(n+1)/2;'//& - ' for k in m..n-1 <>{'//& + ' forall k in m..n-1 {'//& ' PM__setaelem(&y,k-m,p.(_get_aelem(y,k-m),_get_aelem(y,k)) <>)};'//& - ' n:=m};return _get_aelem(y,0)}',line) - endif + ' n=m};return _get_aelem(y,0)}',line) +write(*,'(a)') 'PM__endif' call dcl_uproc(parser,'reduce(p:proc,y:array)='//& '_reduce(p,reduce(p,PM__local(y)))',line) @@ -5488,99 +5665,159 @@ subroutine sysdefs(parser) 'chan yy=y;return init / _reduce%($*,yy,init)}',line) call dcl_uproc(parser,'reduce%(p:invar proc,y:chan,init)='//& - '^(p.(init,_reduce(p,reduce(p,PM__local(y@) <>)<>)),uniform)',line) + '^(p.(init,__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>)),uniform)',line) call dcl_uproc(parser,'_reduce%(p:invar proc,y:chan)='//& - '^(_reduce(p,reduce(p,PM__local(y@) <>)<>),uniform)',line) + '^(__reduce_on_node%(p,_reduce_on_node%(p,PM__local(y!) <>)<>),uniform)',line) + call dcl_uproc(parser,'_reduce_on_node%(p:invar,y:invar) PM__node=reduce(p,y)',line) + call dcl_uproc(parser,'__reduce_on_node%(p:invar,y:invar) PM__node=_reduce(p,y)',line) + + call dcl_uproc(parser,'_reduce(p:proc,y) {'//& 'var x=array(y,[0..0]);var z=array(y,[0..0]);'//& 'var n=this_nnode();var i=1;'//& - 'do {'//& + 'until i>n-1 {'//& ' other=_this_node() xor i;'//& ' if othern-1;return x[0]}',line) + ' _sync_messages(x);x[0]=p.(x[0],z[0])};'//& + ' i=i*2'//& + '};return x[0]}',line) - ! ************************************************** - ! SUPPORT FOR OTHER LANGUAGE FEATURES - ! ************************************************** +write(*,'(a)') '// **************************************************' +WRITE(*,'(A)') '// SUPPORT FOR OTHER LANGUAGE FEATURES' +write(*,'(a)') '// **************************************************' - ! Keyword arguments +write(*,'(a)') '// Keyword arguments' call dcl_uproc(parser,'PM__getkey(x:any,y:any)=convert(x,y)',line) call dcl_uproc(parser,'PM__getkey(x:null,y:any)=y',line) - ! Select statement - call dcl_uproc(parser,& - 'PM__checkcase(x,y,arg...) { var e=match_switch_case(x,y); '//& - 'if not e { e:=PM__checkcase(x,arg...) };return e }',line) +write(*,'(a)') '// Switch statement' + call dcl_uproc(parser,'PM__checkcase(x:literal,y:literal)=match_switch_case(x,y)',line) call dcl_uproc(parser,'PM__checkcase(x,y)=match_switch_case(x,y)',line) + call dcl_uproc(parser,'match_switch_case(x:literal,y:literal)=x==y',line) + call dcl_uproc(parser,'match_switch_case(x:fix any,y:fix any)=x==y',line) call dcl_uproc(parser,'match_switch_case(x,y)=x==y',line) call dcl_uproc(parser,& 'match_switch_case(x:real_num,y:range(real_num))=x>=y._lo and x<=y._hi',& line) + call dcl_uproc(parser,& + 'match_switch_case(x:real_num,y:_crange)=x>=y._lo and x<=y._hi',& + line) + call dcl_uproc(parser,& + 'match_switch_case(x:int_literal,y:_crange)=(x>=y._lo and x<=y._hi) as ',& + line) + call dcl_uproc(parser,& + 'match_switch_case(x:fix(int),y:_crange)=x>=y._lo and x<=y._hi',& + line) call dcl_uproc(parser,'match_switch_case(x:,y:)=y inc x',line) + call dcl_type(parser,'_crange is rec{_lo,_hi}',line) + call dcl_uproc(parser,'PM__caserange(x,y)=x..y',line) + call dcl_uproc(parser,'PM__caserange(x:fix(int),y:fix(int))='//& + 'new _crange{_lo=x,_hi=y}',line) - ! Conditional operators +write(*,'(a)') '// Conditional operators' call dcl_uproc(parser,& - 'PM__if(x,y,z) check "Incompatible types in different ""if""branches"=> '//& - 'same_type(y,z) { var r=z; if x { r:=y };return r }',& + 'PM__if(x,y,z) check "Incompatible types in different ""if"" branches"=> '//& + 'same_type(y,z) { var r=z; if x { r=y };return r }',& line) +!!$ call dcl_uproc(parser,'PM__if(x:bool_literal,y,z)=PM__do_if(x,y,z)'//& +!!$ 'check "Incompatible types in different ""if"" branches"=> '//& +!!$ 'same_type(y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:int_literal,z:int_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:real_literal,z:real_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:string_literal,z:string_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:bool_literal,z:bool_literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,& +!!$ 'PM__if(x:bool_literal,y:literal,z:literal)=PM__do_if(x,y,z)'//& +!!$ 'check "Incompatible types in different ""if"" branches"=>''false',line) + +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y,z)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y:literal,z:literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y,z:literal)=PM__do_if(x,y,z)',line) +!!$ call dcl_uproc(parser,'PM__if(x:fix(bool),y:literal,z)=PM__do_if(x,y,z)',line) + call dcl_uproc(parser,'PM__if(x:''true,y,z)=y',line) call dcl_uproc(parser,'PM__if(x:''false,y,z)=z',line) - call dcl_uproc(parser,'PM__if(x,y,arg...)=PM__if(x,y,PM__if(arg...))',line) + call dcl_uproc(parser,'PM__if(x:''true,y:literal,z)=y',line) + call dcl_uproc(parser,'PM__if(x:''false,y,z:literal)=z',line) +!!$ call dcl_uproc(parser,'PM__if(x,y,arg...)=PM__if(x,y,PM__if(arg...))',line) call dcl_uproc(parser,& 'PM__switch(w,x,y,z) check "Incompatible types in different ""switch"" branches"=> '//& - 'same_type(y,z) { var r=z; if match(w,x) { r:=y };return r }',& + 'same_type(y,z) { var r=z; if match(w,x) { r=y };return r }',& line) + call dcl_uproc(parser,'PM__switch(w:fix(int),x:fix(int),y,z)=PM__if(w==x,y,z)',line) + + call dcl_uproc(parser,'PM__switch(w:fix(string),x:fix(string),y,z)=PM__if(w==x,y,z)',line) + call dcl_uproc(parser,'PM__switch(w:fix(bool),x:fix(bool),y,z)=PM__if(w==x,y,z)',line) + call dcl_uproc(parser,'PM__switch(w,x,y,arg...)=PM__switch(w,x,y,PM__switch(w,arg...))',line) - ! Assignment - call dcl_uproc(parser,'PM__assign_var(&a,b) {PM__assign(&a,b)}',line) +write(*,'(a)') '// Assignment' + call dcl_uproc(parser,& + 'PM__assign_or_init(a,b)<>=a {PM__assign_var(&^(a),b)}',line) call dcl_uproc(parser,& - 'PM__assign(&a:any,b:any) {check_assign_types(a,b);_assign(&a,b)}',line) - call dcl_type(parser,'assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,...',line) + 'PM__assign_or_init(a:,b)=PM__dup(b as a)',line) + call dcl_uproc(parser,& + 'PM__assign_var(&a,b) {PM__assign(&a,b)}',line) + call dcl_uproc(parser,& + 'PM__assign(&a:any,b:any) {_assign(&a,c) where c=b as a}',line) + call dcl_type(parser,& + 'assignment_operator is $_just_assign,$+,$*,$&,$|,$xor,$and,$or,$++,...',line) call dcl_uproc(parser,& 'PM__assign(&a:any,b:any,c:assignment_operator) { PM__assign(&a,c.(a,b)) }',line) call dcl_uproc(parser,& - 'PM__assign(&a:any,b:any,c:proc) { test "Not a recognised assignment operator"=>''false }',line) + 'PM__assign(&a:any,b:any,c:proc) { '//& + 'test "Not a recognised assignment operator"=>''false }',line) call dcl_uproc(parser,'check_assign_types(x,y)'//& '{test "Type mismatch in assignment"=>same_type(x,y)}',line) call dcl_uproc(parser,'_assign(&a,b) {_assign_element(&a,b)}',line) call dcl_uproc(parser,'_assign(&a:contains(farray),b) {_assign_structure(&a,b)}',line) call dcl_uproc(parser,'_assign_structure(&a,b)<>{_assign_element(&a,b)}',line) call dcl_uproc(parser,'_assign_structure(&a:farray,b){_array_assign(&a,b,''true)}',line) - call dcl_proc(parser,'_assign_element(&any,any)',op_assign,0,line,0) + call dcl_proc(parser,'_assign_element(&any,any)',"assign",0,line,0) - ! Other variable operations - call dcl_proc(parser,'PM__clone(x:any)->=x',op_clone,0,line,0) +write(*,'(a)') '// Other variable operations' + call dcl_proc(parser,'PM__clone(x:any)->=x',"clone",0,line,0) call dcl_uproc(parser,'PM__dup(PM__dup) <>=PM__clone(PM__dup)',line) - call dcl_proc(parser,'PM__getref(x:any)->=x',op_get_rf,0,line,0) + call dcl_proc(parser,'PM__dup(x:fix int)->int',"clone",0,line,0) + call dcl_proc(parser,'PM__dup(x:fix real)->real',"clone",0,line,0) + call dcl_proc(parser,'PM__dup(x:fix string)->string',"clone",0,line,0) + call dcl_proc(parser,'PM__dup(x:fix bool)->bool',"clone",0,line,0) + + call dcl_proc(parser,'PM__getref(x:any)->=x',"get_rf",0,line,0) call dcl_proc(parser,'same_type(x:any,y:any)->==x,y',& - op_logical_return,0,line,proc_needs_type) + "logical_return",0,line,proc_needs_type) call dcl_uproc(parser,'==(x:any,y:any) {'//& 'test "Cannot apply ""=="" to different types"=> same_type(x,y);'//& 'var ok=true;_eq(x,y,&ok);return ok}',line) + call dcl_uproc(parser,'/=(x:any,y:any) {'//& + 'test "Cannot apply ""/="" to different types"=> same_type(x,y);'//& + 'var ok=true;_eq(x,y,&ok);return not ok}',line) call dcl_uproc(parser,& - '_eq(x:any,y:any,&ok) <> { ok:=ok and x==y }',line) - call dcl_proc(parser,'PM__copy_out(x:any)->=x',op_clone,0,line,0) - call dcl_proc(parser,'PM__copy_back(x:any)->=x',op_assign,0,line,0) + '_eq(x:any,y:any,&ok) <> { ok=ok and x==y }',line) + call dcl_proc(parser,'PM__copy_out(x:any)->=x',"clone",0,line,0) + call dcl_proc(parser,'PM__copy_back(x:any)->=x',"assign",0,line,0) call dcl_uproc(parser,'next_enum(x:int)=x+convert(1,x)',line) call dcl_uproc(parser,'next_enum(x:int,y:int)=x+convert(y,x)',line) - ! Type values - call dcl_proc(parser,'typeof(x:any)->type x',op_make_type_val,0,line,proc_needs_type) +write(*,'(a)') '// Type values' + call dcl_proc(parser,'typeof(x:any)->type x',"make_type_val",0,line,proc_needs_type) call dcl_uproc(parser,'is(x,t)=t inc typeof(x)',line) + call dcl_uproc(parser,'isnt(x,t)=not(x is t)',line) call dcl_uproc(parser,'as(x,t:)...=PM__cast(x,t)',line) call dcl_uproc(parser,'as(x,t)=PM__cast(x,typeof(t))',line) - call dcl_proc(parser,'inc(x:,y:)-> inc x,y',op_logical_return,0,line,proc_needs_type) + call dcl_proc(parser,'inc(x:,y:)-> inc x,y',"logical_return",0,line,proc_needs_type) call dcl_uproc(parser,'==(x:,y:)=x inc y and y inc x',line) - call dcl_proc(parser,'error_type()->?int',0,0,line,proc_needs_type) + call dcl_proc(parser,'error_type()->?0',"0",0,line,proc_needs_type) - ! Debugging - call dcl_proc(parser,'_dump(any,any)',op_new_dump,0,line,proc_is_impure) +write(*,'(a)') '// Debugging' + call dcl_proc(parser,'_dump(any,any)',"new_dump",0,line,proc_is_impure) call dcl_uproc(parser,'PM__dump(x)<>:_dump("Value:",x)',line) call dcl_uproc(parser,'PM__dump(y,x)<>:if y:_dump("Value:",x)',line) call dcl_uproc(parser,'PM__dump%(x)<>{print("$"++here);_dump(string(here),x)}',line) @@ -5588,10 +5825,93 @@ subroutine sysdefs(parser) call dcl_uproc(parser,'PM__dump%(y,x){'//& 'test "Selection expression in ''$$dump'' not ''bool''" => ''false;$$infer_type(y)}',line) - call dcl_proc(parser,'old_dump(any)',op_dump,0,line,proc_is_impure) + call dcl_proc(parser,'old_dump(any)',"dump",0,line,proc_is_impure) call dcl_uproc(parser,'old_dumpit(a) { old_dump(a);return a }',line) - call dcl_proc(parser,'old_dump_id(any)',op_dump_id,0,line,proc_is_impure) - - end subroutine sysdefs - -end module pm_sysdefs + call dcl_proc(parser,'old_dump_id(any)',"dump_id",0,line,proc_is_impure) + + contains + + subroutine dcl_proc(iparser,line,opcode,ioparg,iline,iflags) + character(len=*):: line,opcode + character(len=80):: str + str=' ' + if(iand(iflags,proc_is_comm)/=0) str=trim(str)//",is_comm" + if(iand(iflags,proc_is_open)/=0) str=trim(str)//",is_open" + if(iand(iflags,proc_is_each_proc)/=0) str=trim(str)//",is_each_proc" + if(iand(iflags,proc_is_cond)/=0) str=trim(str)//",is_cond" + if(iand(iflags,proc_is_uncond)/=0) str=trim(str)//",is_uncond" + if(iand(iflags,proc_is_abstract)/=0) str=trim(str)//",is_abstract" + if(iand(iflags,proc_is_thru_each )/=0) str=trim(str)//",is_thru_each" + if(iand(iflags,proc_is_empty_each )/=0) str=trim(str)//",is_empty_each" + if(iand(iflags,proc_is_dup_each )/=0) str=trim(str)//",is_dup_each" + if(iand(iflags,proc_is_var )/=0) str=trim(str)//",is_var" + if(iand(iflags,proc_is_generator )/=0) str=trim(str)//",is_generator" + if(iand(iflags,proc_needs_type )/=0) str=trim(str)//",needs_type" + if(iand(iflags,proc_is_recursive )/=0) str=trim(str)//",is_recursive" + if(iand(iflags,proc_is_impure )/=0) str=trim(str)//",is_impure" + if(iand(iflags,proc_is_not_inlinable )/=0) str=trim(str)//",is_not_inlinable" + if(iand(iflags,proc_has_for )/=0) str=trim(str)//",has_for" + if(iand(iflags,proc_is_not_pure_each )/=0) str=trim(str)//",is_not_pure_each" + if(iand(iflags,proc_has_vkeys )/=0) str=trim(str)//",has_vkeys" + if(iand(iflags,proc_is_dcomm )/=0) str=trim(str)//",is_dcomm" + if(iand(iflags,proc_is_file )/=0) str=trim(str)//",is_file" + if(str/=' ') str='<<'//trim(str(2:))//'>>' + if(ioparg<0.or.ioparg>9) stop 'xxx' + write(76,*) adjustl(trim(str)) + write(*,'(a,1h,a,a,a,1h",a,1h",1h(,i1,1h))') 'PM__intrinsic',line,adjustl(trim(str)),': ',opcode,ioparg + end subroutine dcl_proc + + subroutine dcl_type(iparser,line,iline) + character(len=*):: line + write(*,*) + write(*,'(a,a)') 'type ',line + write(*,*) + end subroutine dcl_type + + function aok(line,k) result(ok) + character(len=*):: line + character(len=5):: next + logical:: ok + next=adjustl(line(k+1:)) + ok=.true. + if(next=="where".or.next=="check".or.next(1:4)=="else") ok=.false. + end function aok + + subroutine dcl_uproc(iparser,linez,iline) + character(len=*):: linez + character(len=80),parameter::spaces=' ' + character(len=len(linez)+5):: line + write(*,*) + line="proc "//linez + k=1 + idepth=0 + do i=1,len(line) + select case(line(i:i)) + case(';') + if(i>k) write(*,'(a,a)') spaces(1:idepth),line(k:i-1) + k=i+1 + line(i+1:)=adjustl(line(i+1:)) + case('{') + write(*,'(a,a)') spaces(1:idepth),line(k:i) + k=i+1 + idepth=idepth+2 + line(i+1:)=adjustl(line(i+1:)) + case('}') + idepth=idepth-2 + if(aok(line,i)) then + if(i>k) write(*,'(a,a)') spaces(1:idepth+2),line(k:i-1) + write(*,'(a,a)') spaces(1:idepth),'}' + k=i+1 + line(i+1:)=adjustl(line(i+1:)) + endif + case(' ') + if(ivalue,type<>type,type==type) - integer,parameter:: pm_typ_incl_val=1 - integer,parameter:: pm_typ_incl_typ=2 - integer,parameter:: pm_typ_incl_equiv=4 - integer,parameter:: pm_typ_incl_indirect=8 - integer,parameter:: pm_typ_incl_nomatch=16 - integer,parameter:: pm_typ_incl_extract=32 + integer,parameter:: pm_type_incl_val=1 + integer,parameter:: pm_type_incl_type=2 + integer,parameter:: pm_type_incl_equiv=4 + integer,parameter:: pm_type_incl_indirect=8 + integer,parameter:: pm_type_incl_nomatch=16 + integer,parameter:: pm_type_incl_extract=32 - integer,parameter:: pm_typ_dref_offset=2000 + integer,parameter:: pm_type_dref_offset=2000 ! Return from struct/rec element lookup integer,parameter:: pm_elem_found=0 integer,parameter:: pm_elem_not_found=1 integer,parameter:: pm_elem_clash=2 - ! Information on location and kind of non-match/type error - type pm_typ_einfo - integer:: kind - integer:: index - integer:: name,vname,typ1,typ2,vtyp1,vtyp2 - end type pm_typ_einfo - ! Error codes from type testing - integer,parameter:: pm_typ_err_none=0 - integer,parameter:: pm_typ_err_elem=1 - integer,parameter:: pm_typ_err_param=2 - integer,parameter:: pm_typ_err_ambig=4 - integer,parameter:: pm_typ_err_not_set=8 - integer,parameter:: pm_typ_err_interface=16 - integer,parameter:: pm_typ_err_interface_clash=32 - integer,parameter:: pm_typ_err_interface_mismatch=64 - integer,parameter:: pm_typ_err_interface_bad_typ=128 - integer,parameter:: pm_typ_err_interface_write=256 - integer,parameter:: pm_typ_err_interface_nesting=512 - integer,parameter:: pm_typ_err_interface_inconsistent=1024 - integer,parameter:: pm_typ_err_interface_elem=2048 - integer,parameter:: pm_typ_err_elem_clash=4096 - integer,parameter:: pm_typ_err_elem_not_found=8192 - integer,parameter:: pm_typ_err_elem_bad_typ=16384 - integer,parameter:: pm_typ_err_elem_not_in_interface=32768 + integer,parameter:: pm_type_err_none=0 + integer,parameter:: pm_type_err_elem=1 + integer,parameter:: pm_type_err_param=2 + integer,parameter:: pm_type_err_ambig=4 + integer,parameter:: pm_type_err_not_set=8 + integer,parameter:: pm_type_err_elem_clash=16 + integer,parameter:: pm_type_err_elem_not_found=32 + integer,parameter:: pm_type_err_elem_bad_type=64 + integer,parameter:: pm_type_err_elem_not_in_interface=128 ! Maximum nesting of "type is" declarations integer,private,parameter:: max_user_nesting = 64 @@ -167,16 +164,29 @@ module pm_types integer(pm_p),public,parameter:: pm_prc_type = pm_last_lib_type+1 integer(pm_p),public,parameter:: pm_string_type=pm_last_lib_type+2 integer(pm_p),public,parameter:: pm_poly_type=pm_last_lib_type+3 - integer(pm_p),public,parameter:: pm_struct_type=pm_last_lib_type+4 - integer(pm_p),public,parameter:: pm_rec_type=pm_last_lib_type+5 - integer(pm_p),public,parameter:: pm_polyref_type=pm_last_lib_type+6 - integer(pm_p),public,parameter:: pm_array_type=pm_last_lib_type+7 - integer(pm_p),public,parameter:: pm_const_array_type=pm_last_lib_type+8 - integer(pm_p),public,parameter:: pm_dref_type=pm_last_lib_type+9 - integer(pm_p),public,parameter:: pm_dref_shared_type=pm_last_lib_type+10 - integer(pm_p),public,parameter:: pm_elemref_type=pm_last_lib_type+11 + integer(pm_p),public,parameter:: pm_rec_type=pm_last_lib_type+4 + integer(pm_p),public,parameter:: pm_polyref_type=pm_last_lib_type+5 + integer(pm_p),public,parameter:: pm_array_type=pm_last_lib_type+6 + integer(pm_p),public,parameter:: pm_const_array_type=pm_last_lib_type+7 + integer(pm_p),public,parameter:: pm_dref_type=pm_last_lib_type+8 + integer(pm_p),public,parameter:: pm_dref_shared_type=pm_last_lib_type+9 + integer(pm_p),public,parameter:: pm_elemref_type=pm_last_lib_type+10 integer(pm_p),public,parameter:: pm_last_sys_type=pm_elemref_type + ! Categorical types + integer,public,parameter:: pm_a_rec_type = pm_last_sys_type + 1 + integer,public,parameter:: pm_a_unique_type = pm_last_sys_type + 2 + integer,public,parameter:: pm_a_poly_type = pm_last_sys_type + 3 + integer,public,parameter:: pm_a_basic_type = pm_last_sys_type + 4 + integer,public,parameter:: pm_last_category_type = pm_a_basic_type + + ! Literal types + integer,public,parameter:: pm_int_literal_type = pm_last_category_type + 1 + integer,public,parameter:: pm_real_literal_type = pm_last_category_type + 2 + integer,public,parameter:: pm_bool_literal_type = pm_last_category_type + 3 + integer,public,parameter:: pm_string_literal_type = pm_last_category_type + 4 + integer,public,parameter:: pm_last_literal_type = pm_string_literal_type + ! Kind of dref type (internal type describing references) integer,public,parameter:: pm_dref_is_dot=0 integer,public,parameter:: pm_dref_is_var=-1 @@ -196,29 +206,29 @@ module pm_types contains ! Initialise type system - subroutine init_typ(context) + subroutine pm_init_types(context) type(pm_context),pointer:: context integer:: i,j - integer,dimension(2):: key + integer,dimension(3):: key integer:: flags - character(len=12),dimension(pm_last_sys_type),parameter:: base_types= (/& - 'PM__tinyint','proc ','type ','name ',& - 'null ','sint ','int ','lint ',& - 'int8 ','int16 ','int32 ','int64 ',& - ' ','sreal ','real ',' ',& - ' ',' ','scpx ','cpx ',& - ' ',' ',' ','bool ',& - ' ',' ',' ',' ',& - ' ',' ',' ',' ',& - 'prc_info ','string ',' ',' ',& - ' ',' ',' ',' ',& - ' ',' ',' '/) + character(len=15),dimension(pm_last_category_type),parameter:: base_types= (/& + 'PM__tinyint ','proc ','type ','name ',& + 'null ','sint ','int ','lint ',& + 'int8 ','int16 ','int32 ','int64 ',& + ' ','sreal ','real ',' ',& + ' ',' ','scpx ','cpx ',& + ' ',' ',' ','bool ',& + ' ',' ',' ',' ',& + ' ',' ',' ',' ',& + 'prc_info ','string ',' ',& + ' ',' ',' ',' ',& + ' ',' ',' ',& + 'a_rec ','a_unique ','a_poly ','a_basic '/) context%tcache=pm_dict_new(context,128_pm_ln) context%pcache=pm_dict_new(context,1024_pm_ln) - context%vcache=pm_set_new(context,1024_pm_ln) - key(1)=pm_typ_is_basic + key(1)=pm_type_is_basic do i=1,pm_null key(2)=pm_intern(context,trim(base_types(i))) if(pm_debug_level>2) then @@ -226,20 +236,38 @@ subroutine init_typ(context) endif j=pm_idict_add(context,context%tcache,key,2,& pm_null_obj) - if(j/=i) call pm_panic('init_typ') + if(j/=i) call pm_panic('init_type') enddo - key(1)=pm_typ_is_basic+pm_typ_has_storage+pm_typ_leaves - do i=pm_null+1,pm_last_sys_type + key(1)=pm_type_is_basic+pm_type_has_storage+pm_type_leaves + do i=pm_null+1,pm_last_category_type key(2)=pm_intern(context,trim(base_types(i))) if(pm_debug_level>2) then write(*,*) 'Init types(',trim(base_types(i)),')',key(2) endif j=pm_idict_add(context,context%tcache,key,2,& pm_null_obj) - if(j/=i) call pm_panic('init_typ') + if(j/=i) call pm_panic('init_type') + if(i==pm_last_sys_type) then + key(1)=pm_type_new_category + endif enddo - key(1)=pm_typ_is_user - do i=1,pm_last_sys_type + key(1)=pm_type_new_unfixed + key(2)=0 + key(3)=pm_long + j=pm_idict_add(context,context%tcache,key,3,& + pm_null_obj) + key(3)=pm_single + j=pm_idict_add(context,context%tcache,key,3,& + pm_null_obj) + key(3)=pm_logical + j=pm_idict_add(context,context%tcache,key,3,& + pm_null_obj) + key(3)=pm_string_type + j=pm_idict_add(context,context%tcache,key,3,& + pm_null_obj) + + key(1)=pm_type_is_user + do i=1,pm_last_category_type if(base_types(i)(1:1)/='<') then key(2)=pm_intern(context,trim(base_types(i))) j=pm_idict_add(context,context%tcache,key,2,& @@ -249,7 +277,7 @@ subroutine init_typ(context) if(pm_debug_level>2) write(*,*) 'Types inited' contains include 'ftypeno.inc' - end subroutine init_typ + end subroutine pm_init_types !============================================================ ! Make type description node @@ -258,7 +286,7 @@ end subroutine init_typ ! - flags can be specified in an optional argument ! Val optional argument gives value associated with the type !============================================================ - function pm_new_basic_typ(context,arr,val,flags) result(tno) + function pm_new_basic_type(context,arr,val,flags) result(tno) type(pm_context),pointer:: context integer,dimension(:),intent(inout):: arr type(pm_ptr),intent(in),optional:: val @@ -276,7 +304,7 @@ function pm_new_basic_typ(context,arr,val,flags) result(tno) call pm_panic('bad kind') endif if(present(flags)) then - arr(1)=ior(arr(1),iand(flags,not(pm_typ_kind_mask+pm_typ_flags_untainting))) + arr(1)=ior(arr(1),iand(flags,not(pm_type_kind_mask+pm_type_flags_untainting))) endif k=pm_ivect_lookup(context,context%tcache, & arr,size(arr)) @@ -285,7 +313,7 @@ function pm_new_basic_typ(context,arr,val,flags) result(tno) tno=k contains include 'ftiny.inc' - end function pm_new_basic_typ + end function pm_new_basic_type !============================================================= ! Make type description record returning type number @@ -294,7 +322,7 @@ end function pm_new_basic_typ ! arr must contain type_kind type_name arg1 arg2 ... ! val optional argument gives value associated with the type !============================================================= - function pm_new_typ(context,arr,val) result(tno) + function pm_new_type(context,arr,val) result(tno) type(pm_context),pointer:: context integer,dimension(:),intent(inout):: arr type(pm_ptr),intent(in),optional:: val @@ -316,13 +344,13 @@ function pm_new_typ(context,arr,val) result(tno) tflags=0 nleaves=0 do k=3,size(arr) - flags=pm_typ_flags(context,arr(k)) + flags=pm_type_flags(context,arr(k)) tflags=ior(tflags,flags) - nleaves=max(nleaves+flags/pm_typ_leaves,pm_typ_max_leaves) + nleaves=min(nleaves+flags/pm_type_leaves,pm_type_max_leaves) enddo - arr(1)=ior(arr(1),iand(tflags,& - iand(pm_typ_leaves-1,not(pm_typ_kind_mask+pm_typ_flags_untainting))))+& - nleaves*pm_typ_leaves + arr(1)=ior(iand(arr(1),pm_type_leaves-1),iand(tflags,& + iand(pm_type_leaves-1,not(pm_type_kind_mask+pm_type_flags_untainting))))+& + nleaves*pm_type_leaves k=pm_ivect_lookup(context,context%tcache, & arr,size(arr)) if(k==0) k=pm_idict_add(context,context%tcache,& @@ -330,14 +358,14 @@ function pm_new_typ(context,arr,val) result(tno) tno=k contains include 'ftiny.inc' - end function pm_new_typ + end function pm_new_type !========================================================================== ! Associate a type with a name (not necessarily the same as the type name) ! Used by struct/rec declarations !========================================================================== - subroutine pm_typ_record_by_name(context,name,typ) + subroutine pm_type_record_by_name(context,name,typ) type(pm_context),pointer:: context integer,intent(in):: name,typ integer(pm_ln):: k @@ -348,13 +376,13 @@ subroutine pm_typ_record_by_name(context,name,typ) call pm_dict_set(context,context%pcache,key,val,.true.,.true.,ok) contains include 'ftiny.inc' - end subroutine pm_typ_record_by_name + end subroutine pm_type_record_by_name !============================================================================== ! Retrieve type associated with a given name (again not same as the type name) ! Used by struct/rec declarations !============================================================================== - function pm_typ_from_recorded_name(context,name) result(typ) + function pm_type_from_recorded_name(context,name) result(typ) type(pm_context),pointer:: context integer,intent(in):: name integer:: typ @@ -364,41 +392,41 @@ function pm_typ_from_recorded_name(context,name) result(typ) typ=val%offset contains include 'ftiny.inc' - end function pm_typ_from_recorded_name + end function pm_type_from_recorded_name !==================================================== ! New parameters type with n parameters !==================================================== - function pm_new_params_typ(context,n,typ) result(tno) + function pm_new_params_type(context,n,typ) result(tno) type(pm_context),pointer:: context integer,intent(in):: n,typ integer:: tno integer:: arr(3) - arr(1)=pm_typ_new_params + arr(1)=pm_type_new_params arr(2)=n arr(3)=typ - tno=pm_new_basic_typ(context,arr,& - flags=iand(pm_typ_flags(context,typ),not(pm_typ_has_params))) - end function pm_new_params_typ + tno=pm_new_basic_type(context,arr,& + flags=iand(pm_type_flags(context,typ),not(pm_type_has_params))) + end function pm_new_params_type !======================================= ! Create new user type with body tno2 !======================================= - function pm_new_user_typ(context,arr,tno2) result(tno) + function pm_new_user_type(context,arr,tno2) result(tno) type(pm_context),pointer:: context integer,dimension(:),intent(inout):: arr integer:: tno2 integer:: tno - tno=pm_new_basic_typ(context,arr,& + tno=pm_new_basic_type(context,arr,& val=pm_fast_typeno(context,tno2)) contains include 'ftypeno.inc' - end function pm_new_user_typ + end function pm_new_user_type !======================================== ! Create new array type: etyp[dtyp] !======================================== - function pm_new_arr_typ(context,kind,etyp,dtyp,styp) result(tno) + function pm_new_arr_type(context,kind,etyp,dtyp,styp) result(tno) type(pm_context),pointer:: context integer,intent(in):: kind integer,intent(in):: etyp @@ -407,281 +435,454 @@ function pm_new_arr_typ(context,kind,etyp,dtyp,styp) result(tno) integer:: tno integer,dimension(5):: args integer:: flags - flags=pm_typ_is_array+merge(pm_typ_has_array,0,kind/=sym_fix) + flags=pm_type_is_array+merge(pm_type_has_array,0,kind/=sym_fix) args(1)=flags args(2)=kind args(3)=etyp args(4)=dtyp args(5)=styp - tno=pm_new_typ(context,args) - end function pm_new_arr_typ + tno=pm_new_type(context,args) + end function pm_new_arr_type !========================= ! Create type a or b !========================= - function pm_typ_combine(context,a,b) result(tno) + function pm_type_union(context,a,b) result(tno) type(pm_context),pointer:: context integer,intent(in):: a,b integer:: tno integer,dimension(4):: args - type(pm_typ_einfo):: einfo + if(a==b) then tno=a return - elseif(pm_typ_includes(context,a,b,pm_typ_incl_typ,einfo)) then + elseif(pm_type_includes(context,a,b,pm_type_incl_type)) then tno=a return - elseif(pm_typ_includes(context,b,a,pm_typ_incl_typ,einfo)) then + elseif(pm_type_includes(context,b,a,pm_type_incl_type)) then tno=b return endif - args(1)=pm_typ_new_any + args(1)=pm_type_new_any args(2)=0 args(3)=a args(4)=b - tno=pm_new_typ(context,args) - end function pm_typ_combine + tno=pm_new_type(context,args) + end function pm_type_union !========================================== - ! Create new polymorphic type: @etype + ! Create new polymorphic type: *etype !========================================== - function pm_new_poly_typ(context,etyp) result(tno) + function pm_new_poly_type(context,etyp) result(tno) type(pm_context),pointer:: context integer,intent(in):: etyp integer:: tno + integer,dimension(2):: args + args(1)=pm_type_new_poly + args(2)=etyp + tno=pm_new_basic_type(context,args) + end function pm_new_poly_type + + + !================================================ + ! Create new polymorphic value type: *etype=vtyp + ! - assumes that vtyp conforms to etyp + !================================================ + function pm_new_poly_val_type(context,etyp,vtyp) result(tno) + type(pm_context),pointer:: context + integer,intent(in):: etyp,vtyp + integer:: tno integer,dimension(3):: args - args(1)=pm_typ_new_poly - args(2)=0 - args(3)=etyp - tno=pm_new_basic_typ(context,args) - end function pm_new_poly_typ + integer:: recur +!!$ write(*,*) 'New poly val: ',trim(pm_type_as_string(context,etyp)),' : ',& +!!$ trim(pm_type_as_string(context,vtyp)) + args(1)=pm_type_new_poly + args(2)=etyp + recur=-1 + args(3)=pm_type_identify_recursive(context,vtyp,etyp,recur) + tno=pm_new_basic_type(context,args) + if(recur>=0) then + call pm_type_set_recursive_ref(context,recur,tno) + endif +!!$ write(*,*) 'Poly type is:',tno + end function pm_new_poly_val_type + !========================================== ! Create new type-value type: !========================================== - function pm_new_type_typ(context,etyp) result(tno) + function pm_new_type_type(context,etyp) result(tno) type(pm_context),pointer:: context integer,intent(in):: etyp integer:: tno integer,dimension(3):: args - args(1)=pm_typ_new_type + args(1)=pm_type_new_type args(2)=0 args(3)=etyp - tno=pm_new_basic_typ(context,args) - end function pm_new_type_typ + tno=pm_new_basic_type(context,args) + end function pm_new_type_type !=============================================== ! Create new includes: type inc type !================================================ - function pm_new_includes_typ(context,etyp,mtyp) result(tno) + function pm_new_includes_type(context,etyp,mtyp) result(tno) type(pm_context),pointer:: context integer,intent(in):: etyp,mtyp integer:: tno integer,dimension(4):: args - args(1)=pm_typ_new_includes + args(1)=pm_type_new_includes args(2)=0 args(3)=etyp args(4)=mtyp - tno=pm_new_basic_typ(context,args) - end function pm_new_includes_typ + tno=pm_new_basic_type(context,args) + end function pm_new_includes_type + + !============================================== + ! Create new compile time name value type + !============================================== + function pm_new_name_type(context,name) result(tno) + type(pm_context),pointer:: context + integer,intent(in):: name + integer:: tno + integer,dimension(2):: args + args(1)=pm_type_new_single_name + if(pm_name_stem(context,name)==sym_distr_tag) then + args(1)=ior(args(1),pm_type_has_distributed) + endif + args(2)=name + tno=pm_new_type(context,args) + end function pm_new_name_type + + function pm_name_type_from_literal_string(context,tno,modname) result(tno2) + type(pm_context),pointer:: context + integer,intent(in):: tno,modname + integer:: tno2 + type(pm_ptr):: str + integer:: i,ic,name + character(len=1):: c + character(len=300):: strchars + str=pm_type_val(context,tno) + if(pm_debug_checks) then + if(pm_fast_vkind(str)/=pm_string) then + write(*,*) 'vkind=',pm_fast_vkind(str),pm_type_as_string(context,tno) + call pm_panic('Type to literal string') + endif + endif + do i=0,pm_fast_esize(str) + c=str%data%s(str%offset+i) + ic=iachar(c) + if(.not.(c=='_'.or.ic>=iachar('a').and.ic<=iachar('z').or.& + ic>=iachar('A').and.ic<=iachar('Z').or.& + i>0.and.ic>=iachar('0').and.ic<=iachar('9'))) then + tno2=-1 + return + endif + enddo + name=pm_type_name(context,tno) + if(str%data%s(str%offset)=='_') then + if(pm_fast_esize(str)<1) then + tno2=-1 + return + endif + strchars=pm_name_as_string(context,name) + name=pm_lname_entry(context,modname,trim(strchars(2:))) + endif + tno2=pm_new_name_type(context,name) + contains + include 'fesize.inc' + include 'fvkind.inc' + end function pm_name_type_from_literal_string !========================================== ! Create new compile time value type !========================================== - function pm_new_value_typ(context,val) result(tno) + function pm_new_fix_value_type(context,val,vindex) result(tno) type(pm_context),pointer:: context type(pm_ptr),intent(in):: val + integer,intent(in),optional:: vindex integer:: tno integer,dimension(3):: args - args(1)=pm_typ_new_value - args(2)=pm_set_add(context,context%vcache,val) + args(1)=pm_type_new_fix_value + if(present(vindex)) then + args(2)=vindex + else + args(2)=pm_set_add(context,context%names,val) + endif args(3)=pm_fast_typeof(val) - tno=pm_new_basic_typ(context,args,val) + if(args(3)==pm_string) args(3)=pm_string_type + tno=pm_new_basic_type(context,args,val) + contains + include 'ftypeof.inc' + end function pm_new_fix_value_type + + function pm_fix_value_type_from_literal(context,tno) result(tno2) + type(pm_context),pointer:: context + integer,intent(in):: tno + integer:: tno2 + integer:: args(3) + type(pm_ptr):: tv + tv=pm_type_vect(context,tno) + args(1)=pm_type_new_fix_value + args(2)=pm_tv_name(tv) + args(3)=pm_tv_arg(tv,1) + tno2=pm_new_basic_type(context,args,pm_type_val(context,tno)) + end function pm_fix_value_type_from_literal + + !========================================== + ! Create new compile time value type + !========================================== + function pm_new_literal_value_type(context,val,vindex,typ) result(tno) + type(pm_context),pointer:: context + type(pm_ptr),intent(in):: val + integer,intent(in),optional:: vindex,typ + integer:: tno + integer,dimension(3):: args + args(1)=pm_type_new_literal_value + if(present(vindex)) then + args(2)=vindex + else + args(2)=pm_set_add(context,context%names,val) + endif + if(present(typ)) then + args(3)=typ + else + args(3)=pm_fast_typeof(val) + if(args(3)==pm_string.or.args(3)==pm_int32) args(3)=pm_string_type + endif + tno=pm_new_basic_type(context,args,val) contains include 'ftypeof.inc' - end function pm_new_value_typ + end function pm_new_literal_value_type !============================================== - ! Create new compile time name value type + ! Create new pending error type !============================================== - function pm_new_name_typ(context,name) result(tno) + function pm_new_error_type(context,val) result(tno) type(pm_context),pointer:: context - integer,intent(in):: name + type(pm_ptr),intent(in):: val integer:: tno integer,dimension(2):: args - args(1)=pm_typ_new_single_name - if(pm_name_stem(context,name)==sym_distr_tag) then - args(1)=ior(args(1),pm_typ_has_distributed) - endif - args(2)=name - tno=pm_new_typ(context,args) - end function pm_new_name_typ + args(1)=pm_type_new_error + args(2)=pm_set_add(context,context%names,val) + tno=pm_new_basic_type(context,args,val) + end function pm_new_error_type + + !============================================== + ! Create new pending error type from a string + !============================================== + function pm_error_type_from_string(context,str) result(tno) + type(pm_context),pointer:: context + character(len=*):: str + integer:: tno + tno=pm_new_error_type(context,pm_new_string(context,str)) + end function pm_error_type_from_string + !============================================= ! Create new compile time proc value type !============================================= - function pm_new_proc_typ(context,name) result(tno) + function pm_new_proc_type(context,name) result(tno) type(pm_context),pointer:: context integer,intent(in):: name integer:: tno integer,dimension(2):: args - args(1)=pm_typ_new_proc + args(1)=pm_type_new_proc args(2)=name - tno=pm_new_typ(context,args) - end function pm_new_proc_typ + tno=pm_new_type(context,args) + end function pm_new_proc_type !========================================== ! Create internal vector type ^^(T) !========================================== - function pm_new_vect_typ(context,tno) result(tno2) + function pm_new_vect_type(context,tno) result(tno2) type(pm_context),pointer:: context integer,intent(in):: tno integer:: tno2 integer,dimension(3):: args - args(1)=pm_typ_new_vect + args(1)=pm_type_new_vect args(2)=0 args(3)=tno - tno2=pm_new_typ(context,args) - end function pm_new_vect_typ + tno2=pm_new_type(context,args) + end function pm_new_vect_type !================================================= ! Change the value associated with a type ! (used for user and value types) !================================================= - subroutine pm_typ_set_val(context,tno,val) + subroutine pm_type_set_val(context,tno,val) type(pm_context),pointer:: context integer:: tno type(pm_ptr),intent(in):: val call pm_dict_set_val(context,context%tcache,int(tno,pm_ln),val) - end subroutine pm_typ_set_val + end subroutine pm_type_set_val !=================================== ! Return the kind of a given type !=================================== - function pm_typ_kind(context,tno) result(kind) + function pm_type_kind(context,tno) result(kind) type(pm_context),pointer:: context integer,intent(in):: tno integer:: kind if(tno<=0) then kind=0 else - kind=pm_tv_kind(pm_typ_vect(context,tno)) + kind=pm_tv_kind(pm_type_vect(context,tno)) endif - end function pm_typ_kind + end function pm_type_kind !========================================= ! Return flags for a given type !========================================= - function pm_typ_flags(context,tno) result(flags) + function pm_type_flags(context,tno) result(flags) type(pm_context),pointer:: context integer,intent(in):: tno integer:: flags integer:: tno2 type(pm_ptr):: tv - if(tno==0) then - flags=pm_typ_has_generic + if(tno<=0) then + flags=pm_type_has_generic return else - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) flags=pm_tv_flags(tv) tno2=tno - do while(iand(flags,pm_typ_kind_mask)==pm_typ_is_user) + do while(iand(flags,pm_type_kind_mask)==pm_type_is_user) tv=pm_dict_val(context,context%tcache,int(tno2,pm_ln)) tno2=tv%offset - if(tno2/=0) then - tv=pm_typ_vect(context,tno2) - flags=pm_tv_flags(tv) + if(tno2==tno) then + flags=pm_type_is_recursive + exit + elseif(tno2/=0) then + tv=pm_type_vect(context,tno2) + flags=ior(iand(pm_type_is_recursive,flags),pm_tv_flags(tv)) else - flags=pm_typ_has_generic + flags=pm_type_has_generic + exit endif enddo endif contains include 'fvkind.inc' - end function pm_typ_flags + end function pm_type_flags !================================================= ! Return number of leaves associated with a type !================================================= - function pm_typ_needs_storage(context,tno) result(ok) + function pm_type_needs_storage(context,tno) result(ok) type(pm_context),pointer:: context integer,intent(in):: tno logical:: ok - ok=iand(pm_typ_flags(context,tno),pm_typ_has_storage)/=0 - end function pm_typ_needs_storage + ok=iand(pm_type_flags(context,tno),pm_type_has_storage)/=0 + end function pm_type_needs_storage !================================================= ! Return number of leaves associated with a type !================================================= - function pm_typ_num_leaves(context,tno) result(n) + function pm_type_num_leaves(context,tno) result(n) + type(pm_context),pointer:: context + integer,intent(in):: tno + integer:: n + n=pm_type_flags(context,tno)/pm_type_leaves + end function pm_type_num_leaves + + !================================================= + ! Return number of arguments associated with a type + !================================================= + function pm_type_numargs(context,tno) result(n) type(pm_context),pointer:: context integer,intent(in):: tno integer:: n - n=pm_typ_flags(context,tno)/pm_typ_leaves - end function pm_typ_num_leaves + n=pm_fast_esize(pm_type_vect(context,tno))-1 + contains + include 'fesize.inc' + end function pm_type_numargs !================================================= ! Return argument #n of type tno !================================================= - function pm_typ_arg(context,tno,n) result(tno2) + function pm_type_arg(context,tno,n) result(tno2) type(pm_context),pointer:: context integer,intent(in):: tno,n integer:: tno2 type(pm_ptr):: tv - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) tno2=pm_tv_arg(tv,n) - end function pm_typ_arg + end function pm_type_arg !================================================= ! Return name associated with type tno !================================================= - function pm_typ_name(context,tno) result(name) + function pm_type_name(context,tno) result(name) type(pm_context),pointer:: context integer,intent(in):: tno integer:: name type(pm_ptr):: tv - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) name=pm_tv_name(tv) - end function pm_typ_name + end function pm_type_name + + !===================================================== + ! Is type tuple with when? + !==============================---=================== + function pm_type_has_when(context,tno) result(ok) + type(pm_context),pointer:: context + integer,intent(in):: tno + logical:: ok + type(pm_ptr):: tv + tv=pm_type_vect(context,tno) + ok=iand(pm_tv_flags(tv),pm_type_is_when)/=0 + end function pm_type_has_when + + !===================================================== + ! Return amp locs for tuple type + !==============================---=================== + function pm_type_amp(context,tno) result(amp) + type(pm_context),pointer:: context + integer,intent(in):: tno + integer:: amp + type(pm_ptr):: tv + tv=pm_type_vect(context,tno) + amp=pm_tv_name(tv) + end function pm_type_amp !===================================================== ! Return name of element #n associated with type tno !==============================---=================== - function pm_typ_elem_name(context,tno,n) result(name) + function pm_type_elem_name(context,tno,n) result(name) type(pm_context),pointer:: context integer,intent(in):: tno,n integer:: name,kind type(pm_ptr):: tv,namev - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) if(pm_debug_checks) then kind=pm_tv_kind(tv) - if(kind/=pm_typ_is_struct.and.kind/=pm_typ_is_rec) then + if(kind/=pm_type_is_rec) then write(*,*) 'tno=',tno,'kind=',kind - call pm_panic('typ_elem_name not struct/rec') + call pm_panic('typ_elem_name not rec') endif endif name=pm_tv_name(tv) namev=pm_name_val(context,name) name=namev%data%i(namev%offset+n) - end function pm_typ_elem_name + end function pm_type_elem_name !========================================== ! Look up type and return number ! (returns zero if not found) !========================================== - function pm_typ_lookup(context,arr) result(tno) + function pm_type_lookup(context,arr) result(tno) type(pm_context),pointer:: context integer,dimension(:):: arr integer:: tno tno=pm_ivect_lookup(context,context%tcache, & arr,size(arr)) - end function pm_typ_lookup + end function pm_type_lookup !=============================================================== ! Look up user type and return type number it is defined to be !=============================================================== - function pm_user_typ_lookup(context,arr) result(tno) + function pm_user_type_lookup(context,arr) result(tno) type(pm_context),pointer:: context integer,dimension(:):: arr integer:: tno @@ -694,50 +895,50 @@ function pm_user_typ_lookup(context,arr) result(tno) else tno=-1 endif - end function pm_user_typ_lookup + end function pm_user_type_lookup !==================================================== ! Lookup parameterless user type with given name !==================================================== - function pm_user_typ_lookup_by_name(context,name) result(tno) + function pm_user_type_lookup_by_name(context,mod,name) result(tno) type(pm_context),pointer:: context - integer,intent(in):: name + integer,intent(in):: mod,name integer:: tno integer:: arr(2) - arr(1)=pm_typ_new_user - arr(2)=name - tno=pm_user_typ_lookup(context,arr) - end function pm_user_typ_lookup_by_name + arr(1)=pm_type_new_user + arr(2)=pm_name2(context,-mod,name) + tno=pm_user_type_lookup(context,arr) + end function pm_user_type_lookup_by_name !==================================================== ! Get type number of body of user type definition !==================================================== - function pm_user_typ_body(context,typ) result(tno) + function pm_user_type_body(context,typ) result(tno) type(pm_context),pointer:: context integer,intent(in):: typ integer:: tno type(pm_ptr):: v v=pm_dict_val(context,context%tcache,int(typ,pm_ln)) tno=v%offset - end function pm_user_typ_body + end function pm_user_type_body !============================================== ! Set the body of a user type declaration !============================================== - subroutine pm_user_typ_set_body(context,typ,tno) + subroutine pm_user_type_set_body(context,typ,tno) type(pm_context),pointer:: context integer,intent(in):: typ,tno - call pm_typ_set_val(context,typ,& + call pm_type_set_val(context,typ,& pm_fast_typeno(context,tno)) contains include 'ftypeno.inc' - end subroutine pm_user_typ_set_body + end subroutine pm_user_type_set_body !======================================================= ! If basic numeric type return name, else return -1 ! (mainly used for casting) !======================================================= - function pm_typ_numeric_name(context,typ) result(name) + function pm_type_numeric_name(context,typ) result(name) type(pm_context),pointer:: context integer,intent(in):: typ integer:: name,tno @@ -747,13 +948,13 @@ function pm_typ_numeric_name(context,typ) result(name) name=-1 return endif - tv=pm_typ_vect(context,typ) - if(pm_tv_kind(tv)==pm_typ_is_basic) then + tv=pm_type_vect(context,typ) + if(pm_tv_kind(tv)==pm_type_is_basic) then name=pm_tv_name(tv) - elseif(pm_tv_kind(tv)==pm_typ_is_user) then - tno=pm_user_typ_body(context,typ) - tv=pm_typ_vect(context,tno) - if(pm_tv_kind(tv)==pm_typ_is_basic) then + elseif(pm_tv_kind(tv)==pm_type_is_user) then + tno=pm_user_type_body(context,typ) + tv=pm_type_vect(context,tno) + if(pm_tv_kind(tv)==pm_type_is_basic) then name=pm_tv_name(tv) else name=-1 @@ -762,65 +963,70 @@ function pm_typ_numeric_name(context,typ) result(name) name=-1 endif if(tno=pm_logical) name=-1 - end function pm_typ_numeric_name + end function pm_type_numeric_name !=============================================== ! Value associate with value or const type !=============================================== - function pm_typ_val(context,typ) result(v) + function pm_type_val(context,typ) result(v) type(pm_context),pointer:: context integer,intent(in):: typ type(pm_ptr):: v v=pm_dict_val(context,context%tcache,int(typ,pm_ln)) - end function pm_typ_val + end function pm_type_val !=============================================== ! Strip off non-storage elements of a type - ! including one-element structs/recs !=============================================== - recursive function pm_typ_strip_to_basic(context,typ) result(typ2) + recursive function pm_type_strip_to_basic(context,typ) result(typ2) type(pm_context),pointer:: context integer,intent(in):: typ integer:: typ2 type(pm_ptr):: tv integer:: kind - tv=pm_typ_vect(context,typ) + if(typ==0) then + typ2=0 + return + endif + tv=pm_type_vect(context,typ) kind=pm_tv_kind(tv) select case(kind) - case(pm_typ_is_all,pm_typ_is_vect,pm_typ_is_enveloped,pm_typ_is_param) - typ2=pm_typ_strip_to_basic(context,pm_tv_arg(tv,1)) - case(pm_typ_is_user) - typ2=pm_user_typ_body(context,typ) + case(pm_type_is_all,pm_type_is_vect,& + pm_type_is_param,& + pm_type_is_fix_value,pm_type_is_literal_value) + typ2=pm_type_strip_to_basic(context,pm_tv_arg(tv,1)) + case(pm_type_is_user) + typ2=pm_user_type_body(context,typ) case default typ2=typ end select - end function pm_typ_strip_to_basic + end function pm_type_strip_to_basic !============================================== ! Get mode from type (default private) !============================================== - function pm_typ_get_mode(context,typ) result(mode) + function pm_type_get_mode(context,typ) result(mode) type(pm_context),pointer:: context integer,intent(in):: typ integer:: mode integer:: tk type(pm_ptr):: tv if(typ<=0) then - mode=sym_mirrored + mode=sym_invar return endif - tv=pm_typ_vect(context,typ) - if(pm_tv_kind(tv)==pm_typ_is_par_kind) then + tv=pm_type_vect(context,typ) + if(pm_tv_kind(tv)==pm_type_is_par_kind) then mode=iand(pm_tv_name(tv),mode_mask) else - mode=sym_coherent + mode=sym_private endif - end function pm_typ_get_mode + end function pm_type_get_mode !========================================================================= ! Strip mode information, mode, from type typ yielding unmoded type typ2 !========================================================================= - function pm_typ_strip_mode(context,typ,mode) result(typ2) + function pm_type_strip_mode(context,typ,mode) result(typ2) type(pm_context),pointer:: context integer,intent(in):: typ integer,intent(out):: mode @@ -829,109 +1035,77 @@ function pm_typ_strip_mode(context,typ,mode) result(typ2) type(pm_ptr):: tv if(typ<=0) then typ2=typ - mode=merge(sym_coherent,sym_mirrored,typ==0) + mode=merge(sym_private,sym_invar,typ==0) return endif - tv=pm_typ_vect(context,typ) - if(pm_tv_kind(tv)==pm_typ_is_par_kind) then + tv=pm_type_vect(context,typ) + if(pm_tv_kind(tv)==pm_type_is_par_kind) then mode=iand(pm_tv_name(tv),mode_mask) typ2=pm_tv_arg(tv,1) else - mode=sym_coherent - typ2=typ - endif - end function pm_typ_strip_mode - - !========================================================================== - ! Strip mode information, mode, from type typ yielding unmoded type typ2 - ! Return in cond whether mode indicates a conditional context - !========================================================================== - function pm_typ_strip_mode_and_cond(context,typ,mode,cond) result(typ2) - type(pm_context),pointer:: context - integer,intent(in):: typ - integer,intent(out):: mode - logical,intent(out):: cond - integer:: typ2 - integer:: tk - type(pm_ptr):: tv - if(typ<=0) then - typ2=typ - mode=merge(sym_coherent,sym_mirrored,typ==0) - cond=.false. - return - endif - tv=pm_typ_vect(context,typ) - if(pm_tv_kind(tv)==pm_typ_is_par_kind) then - mode=pm_tv_name(tv) - typ2=pm_tv_arg(tv,1) - cond=mode==sym_partial - else - mode=sym_coherent + mode=sym_private typ2=typ - cond=.false. endif - end function pm_typ_strip_mode_and_cond + end function pm_type_strip_mode !============================================= ! Add mode information to an unmoded type !============================================= - function pm_typ_add_mode(context,typ,mode,iscond,istyp) result(typ2) + function pm_type_add_mode(context,typ,mode,istype) result(typ2) type(pm_context),pointer:: context integer,intent(in):: typ,mode - logical,intent(in):: iscond - logical,intent(in),optional:: istyp + logical,intent(in),optional:: istype integer:: typ2,mode2,typ3 integer:: array(3) if(typ<0) then typ2=typ return endif - typ3=pm_typ_strip_mode(context,typ,mode2) - if(mode2/=sym_coherent) then - write(*,*) trim(sym_names(mode2)) - call pm_panic('add-mode to moded type') + typ3=pm_type_strip_mode(context,typ,mode2) + if(pm_debug_checks) then + if(mode2/=sym_private) then + write(*,*) trim(sym_names(mode2)) + call pm_panic('add-mode to moded type') + endif endif - if(mode==sym_coherent.and..not.(iscond.or.present(istyp))) then + if(mode==sym_private.and..not.present(istype)) then typ2=typ else - array(1)=pm_typ_new_par_kind - array(2)=merge(sym_partial,mode,iscond) + array(1)=pm_type_new_par_kind + array(2)=mode array(3)=typ - typ2=pm_new_typ(context,array) + typ2=pm_new_type(context,array) endif - end function pm_typ_add_mode - + end function pm_type_add_mode !======================================================== ! Replace mode information in a (possibly) moded type !======================================================== - function pm_typ_replace_mode(context,typ1,mode,iscond) result(typ2) + function pm_type_replace_mode(context,typ1,mode) result(typ2) type(pm_context),pointer:: context integer,intent(in):: typ1,mode - logical,intent(in):: iscond integer:: typ2 integer:: array(3),typ type(pm_ptr):: tv - if(typ1<=0) then typ2=typ1 return endif - tv=pm_typ_vect(context,typ1) - if(pm_tv_kind(tv)==pm_typ_is_par_kind) then + tv=pm_type_vect(context,typ1) + if(pm_tv_kind(tv)==pm_type_is_par_kind) then typ=pm_tv_arg(tv,1) else typ=typ1 endif - if(mode==sym_coherent.and..not.iscond) then + if(mode==sym_private) then typ2=typ else - array(1)=pm_typ_new_par_kind - array(2)=merge(sym_partial,mode,iscond) + array(1)=pm_type_new_par_kind + array(2)=mode array(3)=typ - typ2=pm_new_typ(context,array) + typ2=pm_new_type(context,array) endif - end function pm_typ_replace_mode + end function pm_type_replace_mode !============================================================================================= @@ -940,68 +1114,85 @@ end function pm_typ_replace_mode ! Error codes: ! combined_mode=-1,-2... ! Shared distributed value not allowed for position -combined_mode - ! combined_mode=-1001,-1002,... - ! Partial value not allowed in position -(combined_mode+1000) - ! shared_ok -- permissible to have an argumnet with 'shared' mode - ! complete -- cannot have an argument mode associated with a conditional context + ! shared_ok -- permissible to have an argument with 'shared' mode !============================================================================================ - function pm_typ_combine_modes(context,array,shared_ok,complete,cond,unlabelled)& - result(combined_mode) + function pm_type_combine_modes(context,array,is_cond,shared_ok) result(combined_mode) type(pm_context),pointer:: context integer,intent(in),dimension(:):: array - logical,intent(in):: shared_ok,complete,cond,unlabelled + logical,intent(in):: is_cond,shared_ok integer:: combined_mode integer:: i,mode,cmode,tno - if(cond) then - combined_mode=sym_partial - return - endif - !cmode=merge(sym_shared,sym_mirrored,shared_ok) - cmode=sym_mirrored + cmode=sym_invar do i=1,size(array) - tno=pm_typ_strip_mode(context,array(i),mode) - if(complete) then - if(mode==sym_partial) then - combined_mode=-i-1000 - elseif(mode==sym_coherent& - .and.unlabelled) then - combined_mode=-i-2000 - return - endif - endif + tno=pm_type_strip_mode(context,array(i),mode) if(mode==sym_shared.and..not.shared_ok) then - if(iand(pm_typ_flags(context,tno),pm_typ_has_distributed)/=0) then - combined_mode=-i - return - endif + combined_mode=-i + return endif cmode=min(cmode,mode) enddo - if(cmode==sym_chan) cmode=sym_coherent + if(cmode=sym_joint) then + mixed_mode=cmin + elseif(cmax>=sym_joint) then + mixed_mode=sym_joint + else + mixed_mode=sym_private + endif + end function pm_type_mix_modes + !=================================== ! Does mode1 include mode2 ? !=================================== function pm_mode_includes(mode1,mode2) result(ok) integer,intent(in):: mode1,mode2 logical:: ok - if(mode1==mode2) then - ok=.true. - elseif(mode1==sym_private) then - ok=mode2>=sym_partial.and.mode2=sym_mirrored - elseif(mode1==sym_complete) then - ok=mode2>sym_partial.and.mode2=sym_private.and.mode2<=sym_invar + case(sym_global) + ok=mode2>=sym_invar + case(sym_complete) + ok=mode2>=sym_chan.and.mode2/=sym_uniform.and.mode2/=sym_joint + case(sym_connected) + ok=mode2>sym_private.or.mode2==sym_global& + .or.mode2==sym_complete + case(sym_individual) + ok=mode2>=sym_private.and.mode2=sym_mirrored) mode3=mode2 - if(iscond) mode3=-2 - case(sym_complete) - mode3=mode1 - if(mode1/=mode2.and.iscond) mode3=-2 - case(sym_partial) - mode3=mode1 - case(sym_coherent) - mode3=mode1 - if(mode1/=mode2.and.iscond) mode3=-2 - case(sym_mirrored) - if(mode2>=sym_mirrored) mode3=mode1 - if(mode1/=mode2.and.iscond) mode3=-2 - case(sym_shared) - if(mode2>=sym_mirrored) mode3=mode1 - if(mode1/=mode2.and.iscond) mode3=-2 - end select - endif - end function pm_typ_convert_mode - !========================================================== ! Remove both mode information and internal vector type !========================================================== - function pm_typ_strip_mode_and_vect(context,tno) result(tno2) + function pm_type_strip_mode_and_vect(context,tno) result(tno2) type(pm_context),pointer:: context integer,intent(in):: tno integer:: tno2 type(pm_ptr):: tv integer:: mode - tno2=pm_typ_strip_mode(context,tno,mode) - tv=pm_typ_vect(context,tno2) - if(pm_tv_kind(tv)==pm_typ_is_vect) then - tno2=pm_typ_strip_mode(context,pm_tv_arg(tv,1),mode) + tno2=pm_type_strip_mode(context,tno,mode) + tv=pm_type_vect(context,tno2) + if(pm_tv_kind(tv)==pm_type_is_vect) then + tno2=pm_type_strip_mode(context,pm_tv_arg(tv,1),mode) endif - end function pm_typ_strip_mode_and_vect + end function pm_type_strip_mode_and_vect !============================================================================= ! Check if two concrete types equal (ignoring modes and vector type wrappers) !============================================================================= - function pm_typ_equal(context,tno1,tno2) result(ok) + function pm_type_equal(context,tno1,tno2) result(ok) type(pm_context),pointer:: context integer,intent(in):: tno1,tno2 logical:: ok type(pm_ptr):: tv1,tv2 integer:: typ1,typ2,tk1,tk2 - if(tno1==tno2) then - ok=.true. - else - tv1=pm_typ_vect(context,tno1) - tv2=pm_typ_vect(context,tno2) + typ1=tno1 + typ2=tno2 + tv1=pm_type_vect(context,typ1) + tv2=pm_type_vect(context,typ2) + tk1=pm_tv_kind(tv1) + tk2=pm_tv_kind(tv2) + do while(tk1==pm_type_is_par_kind.or.tk1==pm_type_is_vect) + typ1=pm_tv_arg(tv1,1) + tv1=pm_type_vect(context,typ1) tk1=pm_tv_kind(tv1) + enddo + do while(tk2==pm_type_is_par_kind.or.tk2==pm_type_is_vect) + typ2=pm_tv_arg(tv2,1) + tv2=pm_type_vect(context,typ2) tk2=pm_tv_kind(tv2) - typ1=tno1 - typ2=tno2 - if(tk1==pm_typ_is_par_kind.or.tk1==pm_typ_is_vect) then - typ1=pm_tv_arg(tv1,1) - endif - if(tk2==pm_typ_is_par_kind.or.tk2==pm_typ_is_vect) then - typ2=pm_tv_arg(tv2,1) - endif - ok=typ1==typ2 - if(.not.ok) then - tv1=pm_typ_vect(context,typ1) - tv2=pm_typ_vect(context,typ2) - tk1=pm_tv_kind(tv1) - tk2=pm_tv_kind(tv2) - if(tk1==pm_typ_is_par_kind.or.tk1==pm_typ_is_vect) then - typ1=pm_tv_arg(tv1,1) - endif - if(tk2==pm_typ_is_par_kind.or.tk2==pm_typ_is_vect) then - typ2=pm_tv_arg(tv2,1) - endif - ok=typ1==typ2 - endif - endif - end function pm_typ_equal + enddo + ok=tno1==tno2 + if(.not.ok) ok=pm_type_includes(context,tno1,tno2,pm_type_incl_equiv) + end function pm_type_equal + + !=========================================================================================== + ! Check if two concrete types are the same record (ignoring modes and vector type wrappers) + !============================================================================================ + function pm_type_same_rec(context,tno1,tno2) result(ok) + type(pm_context),pointer:: context + integer,intent(in):: tno1,tno2 + logical:: ok + type(pm_ptr):: tv1,tv2 + integer:: typ1,typ2,tk1,tk2 + typ1=tno1 + typ2=tno2 + tv1=pm_type_vect(context,typ1) + tv2=pm_type_vect(context,typ2) + tk1=pm_tv_kind(tv1) + tk2=pm_tv_kind(tv2) + do while(tk1==pm_type_is_par_kind.or.tk1==pm_type_is_vect) + typ1=pm_tv_arg(tv1,1) + tv1=pm_type_vect(context,typ1) + tk1=pm_tv_kind(tv1) + enddo + do while(tk2==pm_type_is_par_kind.or.tk2==pm_type_is_vect) + typ2=pm_tv_arg(tv2,1) + tv2=pm_type_vect(context,typ2) + tk2=pm_tv_kind(tv2) + enddo + if(tk1/=pm_type_is_rec.and.tk1/=pm_type_is_tuple.or.tk1/=tk2) then + ok=.false. + else + ok=pm_tv_name(tv1)==pm_tv_name(tv2).and.pm_tv_numargs(tv1)==pm_tv_numargs(tv2) + endif + end function pm_type_same_rec + !=================================================================== ! Given a struct/rec template and type, return type parameters !================================================================== - function pm_typ_extract_params(context,templ,typ,params) result(ok) + function pm_type_extract_params(context,templ,typ,params) result(ok) type(pm_context),pointer:: context integer,intent(in):: templ,typ integer,intent(inout),dimension(:):: params - type(pm_typ_einfo):: einfo logical:: ok integer:: ubase integer,dimension(max_user_nesting):: user ubase=1 - ok=pm_test_typ_includes(context,templ,typ,& - pm_typ_incl_val+pm_typ_incl_extract,einfo,params,1,user,ubase) - end function pm_typ_extract_params + ok=pm_test_type_includes(context,templ,typ,& + pm_type_incl_val+pm_type_incl_extract,params,1,user,ubase) + end function pm_type_extract_params !====================================== ! Does supertype include subtype? !====================================== - function pm_typ_includes(context,supertype,subtype,& - mode,einfo) result(ok) + function pm_type_includes(context,supertype,subtype,& + mode) result(ok) type(pm_context),pointer:: context integer,intent(in):: supertype,subtype integer,intent(in):: mode - type(pm_typ_einfo),intent(out):: einfo logical:: ok integer:: ubase integer,dimension(max_user_nesting):: user,params - if(pm_typ_extra_debug) then - write(*,*) 'CHECK',trim(pm_typ_as_string(context,supertype)),'>>',& - trim(pm_typ_as_string(context,subtype)) + if(pm_type_extra_debug) then + write(*,*) 'CHECK',trim(pm_type_as_string(context,supertype)),'>>',& + trim(pm_type_as_string(context,subtype)) endif ubase=1 ! This deals with rare problem of *(..T..) where T is struct/rec parameter - if(iand(mode,pm_typ_incl_indirect)/=0) then - if(iand(pm_typ_flags(context,supertype),pm_typ_has_params)/=0) then + if(iand(mode,pm_type_incl_indirect)/=0) then + if(iand(pm_type_flags(context,supertype),pm_type_has_params)/=0) then params=-1 endif endif - einfo%kind=pm_typ_err_none - einfo%typ1=supertype - einfo%typ2=subtype - ok=pm_test_typ_includes(context,supertype,subtype,& - mode,einfo,params,1,user,ubase) - if(pm_typ_extra_debug) then - write(*,*) 'CHECKED ',ok,trim(pm_typ_as_string(context,supertype)),'>>',& - trim(pm_typ_as_string(context,subtype)) + ok=pm_test_type_includes(context,supertype,subtype,& + mode,params,1,user,ubase) + if(pm_type_extra_debug) then + write(*,*) 'CHECKED ',ok,trim(pm_type_as_string(context,supertype)),'>>',& + trim(pm_type_as_string(context,subtype)) endif - end function pm_typ_includes + end function pm_type_includes !====================================================== ! Does supertype include subtype? @@ -1175,13 +1343,12 @@ end function pm_typ_includes ! user(ubase:) maintains a stack of active user types to ! prevent runaway recursion !====================================================== - recursive function pm_test_typ_includes(context,supertype,subtype,& - mode,einfo,params,base,user,ubase)& + recursive function pm_test_type_includes(context,supertype,subtype,& + mode,params,base,user,ubase)& result(ok) type(pm_context),pointer:: context integer,intent(in):: supertype,subtype integer,intent(in):: mode - type(pm_typ_einfo),intent(out):: einfo integer,dimension(:),intent(inout):: params integer,intent(in):: base integer,dimension(:),intent(inout):: user @@ -1192,11 +1359,11 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& integer:: i,j,tk,uk,nt,nu logical:: has_d - if(pm_typ_extra_debug) then + if(pm_type_extra_debug) then write(*,*) '==================' write(*,*) 'Test incl',supertype,subtype - write(*,*) trim(pm_typ_as_string(context,supertype)),' ',& - trim(pm_typ_as_string(context,subtype)) + write(*,*) trim(pm_type_as_string(context,supertype)),' ',& + trim(pm_type_as_string(context,subtype)) write(*,*) 'base=',base write(*,*) '==================' endif @@ -1209,16 +1376,16 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& if(p==0) then ok=.true. else - t=pm_typ_vect(context,p) + t=pm_type_vect(context,p) tk=pm_tv_kind(t) - if(tk==pm_typ_is_user) then + if(tk==pm_type_is_user) then r=pm_dict_val(context,context%tcache,int(p,pm_ln)) - ok=pm_test_typ_includes(context,int(r%offset),q,& - mode,einfo,params,base,user,ubase) - elseif(tk==pm_typ_is_any) then + ok=pm_test_type_includes(context,int(r%offset),q,& + mode,params,base,user,ubase) + elseif(tk==pm_type_is_any) then do i=1,pm_tv_numargs(t) - if(pm_test_typ_includes(context,pm_tv_arg(t,i),q,& - mode,einfo,params,base,user,ubase)) then + if(pm_test_type_includes(context,pm_tv_arg(t,i),q,& + mode,params,base,user,ubase)) then ok=.true. return endif @@ -1237,27 +1404,27 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& return endif - t=pm_typ_vect(context,p) - u=pm_typ_vect(context,q) + t=pm_type_vect(context,p) + u=pm_type_vect(context,q) uk=pm_tv_kind(u) tk=pm_tv_kind(t) - if(tk==pm_typ_is_includes) then - if(uk==pm_typ_is_includes) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + if(tk==pm_type_is_includes) then + if(uk==pm_type_is_includes) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) if(ok) then - ok=ok.and.pm_test_typ_includes(context,& + ok=ok.and.pm_test_type_includes(context,& pm_tv_arg(u,2),pm_tv_arg(t,2),& - pm_typ_incl_equiv,einfo,params,base,user,ubase) + pm_type_incl_equiv,params,base,user,ubase) endif else - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),q,& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) if(ok) then - ok=ok.and.pm_test_typ_includes(context,& + ok=ok.and.pm_test_type_includes(context,& q,pm_tv_arg(t,2),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) endif endif return @@ -1266,36 +1433,61 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& ! Cases where the second type needs to be checked first select case(uk) - case(pm_typ_is_proc) + case(pm_type_is_proc) if(p==pm_proc) then ok=.true. return endif - case(pm_typ_is_single_name) + case(pm_type_is_single_name) if(p==pm_name) then ok=.true. return endif - case(pm_typ_is_value) + case(pm_type_is_fix_value) select case(tk) - case(pm_typ_is_const) - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,einfo,& + case(pm_type_is_fix) + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,& params,base,user,ubase) return - case(pm_typ_is_value) + case(pm_type_is_fix_value) ok=pm_tv_name(t)==pm_tv_name(u) return - case(pm_typ_is_basic) - ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),mode,einfo,& + case(pm_type_is_basic) + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),mode,& params,base,user,ubase) return end select - case(pm_typ_is_const) - ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),mode,einfo,& - params,base,user,ubase) - return - case(pm_typ_is_user) - if(tk/=pm_typ_is_user) then + case(pm_type_is_literal_value) + if(tk==pm_type_is_literal) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,& + params,base,user,ubase) + return + elseif(tk==pm_type_is_literal_value) then + nt=pm_tv_name(t) + ok=nt==pm_tv_name(u) + if(ok.and.nt==0) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,& + params,base,user,ubase) + endif + return + end if + case(pm_type_is_fix,pm_type_is_literal) + if(tk==uk.or.tk==pm_type_is_fix) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),mode,& + params,base,user,ubase) + return + elseif(tk/=pm_type_is_user) then + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),mode,& + params,base,user,ubase) + return + endif + case(pm_type_is_user) + if(tk/=pm_type_is_user) then + if(iand(mode,pm_type_incl_extract)/=0) then + if(iand(pm_tv_flags(u),pm_type_is_recursive)/=0) then + goto 10 + endif + endif do i=2,ubase,2 if(user(i)==p.and.user(i+1)==q) then ok=.true. @@ -1308,120 +1500,119 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& user(ubase+1)=p user(ubase+2)=q r=pm_dict_val(context,context%tcache,int(q,pm_ln)) - ok=pm_test_typ_includes(context,p,int(r%offset),& - mode,einfo,params,base,user,ubase+2) + ok=pm_test_type_includes(context,p,int(r%offset),& + mode,params,base,user,ubase+2) return endif - case(pm_typ_is_any) + case(pm_type_is_any) do i=1,pm_tv_numargs(u) - if(.not.pm_test_typ_includes(context,p,pm_tv_arg(u,i),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase)) then + if(.not.pm_test_type_includes(context,p,pm_tv_arg(u,i),& + mode,params,base,user,ubase)) then ok=.false. return endif enddo ok=.true. return - case(pm_typ_is_all) + case(pm_type_is_all) do i=1,pm_tv_numargs(u) - if(pm_test_typ_includes(context,p,pm_tv_arg(u,i),& - mode,einfo,params,base,user,ubase)) then + if(pm_test_type_includes(context,p,pm_tv_arg(u,i),& + mode,params,base,user,ubase)) then ok=.true. return endif enddo ok=.false. return - case(pm_typ_is_except) - if(tk==pm_typ_is_except) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase).and.& - pm_test_typ_includes(context,pm_tv_arg(u,2),pm_tv_arg(t,2),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + case(pm_type_is_except) + if(tk==pm_type_is_except) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + mode,params,base,user,ubase).and.& + pm_test_type_includes(context,pm_tv_arg(u,2),pm_tv_arg(t,2),& + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) return else - ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) return endif - case(pm_typ_is_includes) - ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + case(pm_type_is_includes) + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& + mode,params,base,user,ubase) return - case(pm_typ_is_undef_result) + case(pm_type_is_undef_result) ok=.false. return - case(pm_typ_is_par_kind) + case(pm_type_is_par_kind) nu=pm_tv_name(u) - if(tk==pm_typ_is_par_kind) then + if(tk==pm_type_is_par_kind) then nt=pm_tv_name(t) - if(iand(mode,pm_typ_incl_val)/=0) then + if(iand(mode,pm_type_incl_val)/=0) then ok=pm_mode_includes(nt,nu) if(ok) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + mode,params,base,user,ubase) endif else if(nt==nu) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + mode,params,base,user,ubase) else ok=pm_mode_includes(nt,nu) endif endif return else - ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& + mode,params,base,user,ubase) return endif - case(pm_typ_is_param) - ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) - return -!!$ case(pm_typ_is_vect) -!!$ if(iand(pm_typ_flags(context,p),pm_typ_has_vect)==0) then -!!$ ok=pm_test_typ_includes(context,p,pm_tv_arg(u,1),& -!!$ mode,einfo,params,base,user,ubase) -!!$ return -!!$ endif - case(pm_typ_is_bottom) - ok=.true. + case(pm_type_is_param) + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& + mode,params,base,user,ubase) return - end select - - select case(tk) - case(pm_typ_is_basic) - ok=.false. - case(pm_typ_is_dref) - if(tk/=uk) then - ok=.false. - return - endif - nt=pm_tv_name(t) - nu=pm_tv_name(u) - if(nt==pm_dref_is_any) then - if(nu/=pm_dref_is_any.and.iand(mode,pm_typ_incl_typ)/=0) then - ok=.true. - return - endif - elseif(.not.(nt==nu.or.& - (nt==pm_dref_is_dot.and.nu>0).or.& - (nt==pm_dref_is_any_slice.and.(nu==pm_dref_is_slice.or.& - nu==pm_dref_is_shared_slice)).or.& - nt==pm_dref_is_shared.and.nu==pm_dref_is_ref)) then - ok=.false. - return + case(pm_type_is_gated) + if(test_gated_type(context,q)) then + ok=pm_test_type_includes(context,p,pm_tv_arg(u,pm_tv_numargs(u)),& + mode,params,base,user,ubase) + else + ok=.true. endif - do i=1,pm_tv_numargs(t) - if(.not.pm_test_typ_includes(context,pm_tv_arg(t,i),& - pm_tv_arg(u,i),mode,einfo,params,base,user,ubase)) then + return + case(pm_type_is_dref) + if(tk==pm_type_is_dref) then + nt=pm_tv_name(t) + nu=pm_tv_name(u) + if(nt/=0.and.nt/=nu) then ok=.false. return endif - enddo + do i=1,pm_tv_numargs(t) + if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),& + pm_tv_arg(u,i),mode,params,base,user,ubase)) then + ok=.false. + return + endif + enddo + ok=.true. + else + ok=pm_test_type_includes(context,p,pm_tv_arg(u,1),& + mode,params,base,user,ubase) + endif + case(pm_type_is_bottom) ok=.true. - case(pm_typ_is_struct,pm_typ_is_rec) + return + end select + +10 continue + + ! Now do tests that look at 1st type first + select case(tk) + case(pm_type_is_basic) + ok=.false. + case(pm_type_is_dref) + ok=.false. + case(pm_type_is_rec) if(tk/=uk) then ok=.false. return @@ -1431,53 +1622,71 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& return endif do i=1,pm_tv_numargs(t) - if(.not.pm_test_typ_includes(context,pm_tv_arg(t,i),& - pm_tv_arg(u,i),mode,einfo,params,base,user,ubase)) then + if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),& + pm_tv_arg(u,i),mode,params,base,user,ubase)) then ok=.false. - einfo%kind=ior(einfo%kind,pm_typ_err_elem) - einfo%name=pm_tv_name(t) - einfo%index=i - einfo%typ1=pm_tv_arg(t,i) - einfo%typ2=pm_tv_arg(u,i) return endif enddo ok=.true. - case(pm_typ_is_array) - if(uk/=pm_typ_is_array) then + case(pm_type_is_array) + if(uk/=pm_type_is_array) then ok=.false. else if(.not.(pm_tv_name(t)==pm_tv_name(u).or.pm_tv_name(t)==0)) then ok=.false. else - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase).and.& - pm_test_typ_includes(context,pm_tv_arg(t,2),pm_tv_arg(u,2),& - mode,einfo,params,base,user,ubase) + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + mode,params,base,user,ubase).and.& + pm_test_type_includes(context,pm_tv_arg(t,2),pm_tv_arg(u,2),& + mode,params,base,user,ubase) + endif + endif + case(pm_type_is_poly) + if(uk/=tk) then + ok=.false. + else + ok=pm_test_type_includes(context,pm_tv_name(t),pm_tv_name(u),& + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) + if(pm_tv_numargs(t)>0.and.pm_tv_numargs(u)>0.and.iand(mode,pm_type_incl_equiv)==0) then + do i=1,pm_tv_numargs(u) + do j=1,pm_tv_numargs(t) + ok=pm_test_type_includes(context,pm_tv_arg(t,j),pm_tv_arg(u,i),& + mode,params,base,user,ubase) + if(ok) exit + enddo + if(.not.ok) exit + end do endif endif - case(pm_typ_is_type,pm_typ_is_poly) + case(pm_type_is_type) if(uk/=tk) then ok=.false. else - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) endif - case(pm_typ_is_tuple,pm_typ_is_vtuple) - if(uk/=pm_typ_is_tuple.and.uk/=pm_typ_is_vtuple) then + case(pm_type_is_tuple,pm_type_is_vtuple) + if(uk/=pm_type_is_tuple.and.uk/=pm_type_is_vtuple) then ok=.false. - elseif(tk==pm_typ_is_tuple.and.uk==pm_typ_is_vtuple) then + elseif(tk==pm_type_is_tuple.and.uk==pm_type_is_vtuple) then ok=.false. elseif(pm_tv_name(t)/=pm_tv_name(u)) then ok=.false. + elseif(iand(pm_tv_flags(t),pm_type_is_when)/=0.and.iand(pm_tv_flags(u),pm_type_is_when)==0) then + !( when) does not include ( ) + ok=.false. + elseif(iand(pm_tv_flags(t),pm_type_is_yield+pm_type_is_list)/=& + iand(pm_tv_flags(u),pm_type_is_yield+pm_type_is_list)) then + ok=.false. else nt=pm_tv_numargs(t) nu=pm_tv_numargs(u) - if(nt>nu.and.uk/=pm_typ_is_vtuple) then + if(nt>nu.and.uk/=pm_type_is_vtuple) then ok=.false. return endif - if(nu>nt.and.tk/=pm_typ_is_vtuple) then + if(nu>nt.and.tk/=pm_type_is_vtuple) then ok=.false. return endif @@ -1496,16 +1705,16 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& endif endif do i=j,min(nt,nu) - if(.not.pm_test_typ_includes(context,pm_tv_arg(t,i),& - pm_tv_arg(u,i),mode,einfo,params,base,user,ubase)) then + if(.not.pm_test_type_includes(context,pm_tv_arg(t,i),& + pm_tv_arg(u,i),mode,params,base,user,ubase)) then ok=.false. return endif enddo if(nu>nt) then do i=nt+1,nu - if(.not.pm_test_typ_includes(context,pm_tv_arg(t,nt),& - pm_tv_arg(u,i),mode,einfo,params,base,& + if(.not.pm_test_type_includes(context,pm_tv_arg(t,nt),& + pm_tv_arg(u,i),mode,params,base,& user,ubase)) then ok=.false. return @@ -1513,8 +1722,8 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& enddo else do i=nu+1,nt - if(.not.pm_test_typ_includes(context,pm_tv_arg(t,nt),& - pm_tv_arg(u,i),mode,einfo,params,base,& + if(.not.pm_test_type_includes(context,pm_tv_arg(t,nt),& + pm_tv_arg(u,i),mode,params,base,& user,ubase)) then ok=.false. return @@ -1523,17 +1732,17 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& endif ok=.true. endif - case(pm_typ_is_user) - if(uk==pm_typ_is_user) then + case(pm_type_is_user) + if(uk==pm_type_is_user) then ! Check P(p1,p2) < Q(q1,q2) <=> p11) then ok=.false. else - ok=pm_test_typ_includes(context,& + ok=pm_test_type_includes(context,& pm_tv_arg(t,1),pm_tv_arg(u,1),& - pm_typ_incl_typ+pm_typ_incl_nomatch,& - einfo,params,base,user,ubase) + pm_type_incl_type+pm_type_incl_nomatch,& + params,base,user,ubase) endif - case(pm_typ_is_proc_sig) - if(uk/=pm_typ_is_proc_sig) then + case(pm_type_is_proc_sig) + if(uk/=pm_type_is_proc_sig) then ok=.false. return endif @@ -1608,116 +1835,96 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& ok=.false. return endif - ok=pm_test_typ_includes(context,& + ok=pm_test_type_includes(context,& pm_tv_arg(u,1),pm_tv_arg(t,1),& - pm_typ_incl_typ+pm_typ_incl_nomatch,& - einfo,params,base,user,ubase).and.& - pm_test_typ_includes(context,& + pm_type_incl_type+pm_type_incl_nomatch,& + params,base,user,ubase).and.& + pm_test_type_includes(context,& pm_tv_arg(t,2),pm_tv_arg(u,2),& - pm_typ_incl_typ+pm_typ_incl_nomatch,& - einfo,params,base,user,ubase) - case(pm_typ_is_par_kind) + pm_type_incl_type+pm_type_incl_nomatch,& + params,base,user,ubase) + case(pm_type_is_par_kind) ! Most cases catered for by uk switch - remaining case - ok=iand(mode,pm_typ_incl_val)/=0.and.& - pm_mode_includes(pm_tv_name(t),sym_coherent).and.& - pm_test_typ_includes(context,pm_tv_arg(t,1),q,& - mode,einfo,params,base,user,ubase) - case(pm_typ_is_undef_result) + ok=iand(mode,pm_type_incl_val)/=0.and.& + pm_mode_includes(pm_tv_name(t),sym_private).and.& + pm_test_type_includes(context,pm_tv_arg(t,1),q,& + mode,params,base,user,ubase) + case(pm_type_is_undef_result) ok=.false. - case(pm_typ_is_contains) - if(uk==pm_typ_is_contains) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + case(pm_type_is_contains) + if(uk==pm_type_is_contains) then + ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) else - ok=pm_typ_contains_elem(context,pm_tv_arg(t,1),q,& - ior(mode,pm_typ_incl_nomatch),einfo,params,base,user,ubase) + ok=pm_type_contains_elem(context,pm_tv_arg(t,1),q,& + ior(mode,pm_type_incl_nomatch),params,base,user,ubase) endif - case(pm_typ_is_has) - if(uk==pm_typ_is_has) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + case(pm_type_is_fix_value,pm_type_is_literal_value) + ok=.false. + case(pm_type_is_fix) + if(pm_tv_name(t)>0) then + ! fix? + ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& + mode,params,base,user,ubase) else - i=ubase+1 - r=pm_typ_vect(context,pm_tv_arg(t,1)) - if(pm_tv_kind(r)==pm_typ_is_interface) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),q,& - mode,einfo,params,base,user,ubase) - if(ok) return - elseif(pm_tv_kind(r)==pm_typ_is_proc.and.& - pm_tv_kind(u)==pm_typ_is_proc) then - do i=1,pm_tv_numargs(u) - if(pm_proc_typ_conforms(context,pm_tv_arg(t,1),& - pm_tv_arg(u,i))) then - ok=.true. - return - endif - enddo - endif - call pm_indirect_include(context,pm_tv_arg(t,1),q,user,& - size(user),i,einfo,j,s) - ok=s==pm_elem_found - if(ok) then - ! This test does parameter checking in correct context - ! (indirect_include checks in isolated context) - ok=pm_test_typ_includes(context,& - pm_tv_arg(t,1),j,& - mode,einfo,params,base,user,ubase) - endif - endif - case(pm_typ_is_value) - if(uk/=pm_typ_is_value) then ok=.false. - else - ok=pm_tv_name(t)==pm_tv_name(u) endif - case(pm_typ_is_const) - if(uk/=pm_typ_is_const.and.uk/=pm_typ_is_value) then - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),q,& - mode,einfo,params,base,user,ubase) - if(iand(pm_typ_flags(context,q),pm_typ_has_storage)/=0) ok=.false. - else - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) - endif - case(pm_typ_is_interface,pm_typ_is_enveloped) - if(uk==pm_typ_is_interface.or.uk==pm_typ_is_enveloped) then - ok=pm_tv_name(t)==pm_tv_name(u) + case(pm_type_is_literal) + if(tk==uk) then + ok=pm_tv_arg(t,1)==0.or.& + pm_tv_arg(t,1)==pm_tv_arg(u,1) + elseif(pm_tv_name(t)>0) then + ! literal? + ok=pm_tv_arg(t,1)==q else ok=.false. endif - case(pm_typ_is_except) - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),q,& - mode,einfo,params,base,user,ubase) - if(ok) then - ok=.not.pm_test_typ_includes(context,pm_tv_arg(t,2),q,& - mode,einfo,params,base,user,ubase) - endif - case(pm_typ_is_params) + case(pm_type_is_params) nt=pm_tv_name(t) if(base+nt>size(params)) then call pm_panic('Program too complex - Excessive type nesting') endif params(base:base+nt)=-1 - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),q,& - mode,einfo,params,base+nt,user,ubase) - case(pm_typ_is_param) - ok=pm_test_typ_includes(context,pm_tv_arg(t,1),q,& - mode,einfo,params,base,user,ubase) - if(ok.and.iand(mode,pm_typ_incl_extract)/=0) then - if(iand(mode,pm_typ_incl_nomatch)/=0) return + ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& + mode,params,base+nt,user,ubase) + case(pm_type_is_param) + ok=pm_test_type_includes(context,pm_tv_arg(t,1),q,& + mode,params,base,user,ubase) + if(ok.and.iand(mode,pm_type_incl_extract)/=0) then + if(iand(mode,pm_type_incl_nomatch)/=0) return nt=pm_tv_name(t) if(params(nt)==-1) then params(nt)=q else - params(nt)=pm_typ_combine(context,params(nt),q) + params(nt)=pm_type_union(context,params(nt),q) endif endif - case(pm_typ_is_amp,pm_typ_is_vect) + case(pm_type_is_vect,pm_type_is_uninitialised) ok=tk==uk - if(ok) ok=pm_test_typ_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) - case(pm_typ_is_bottom) + if(ok) ok=pm_test_type_includes(context,pm_tv_arg(t,1),pm_tv_arg(u,1),& + mode,params,base,user,ubase) + case(pm_type_is_gated) + if(test_gated_type(context,p)) then + ok=pm_test_type_includes(context,pm_tv_arg(t,pm_tv_numargs(t)),q,& + mode,params,base,user,ubase) + else + ok=.false. + endif + case(pm_type_is_bottom) ok=.false. + case(pm_type_is_category) + select case(p) + case(pm_a_rec_type) + ok=uk==pm_type_is_rec + case(pm_a_unique_type) + ok=uk==pm_type_is_single_name + case(pm_a_poly_type) + ok=uk==pm_type_is_poly + case(pm_a_basic_type) + ok=uk==pm_type_is_basic + case default + call pm_panic('test-includes,category') + end select case default write(*,*) 'Type=',p write(*,*) 'Kind=',pm_tv_kind(t) @@ -1725,7 +1932,7 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& do i=1,pm_tv_numargs(t) write(*,*) 'Arg=',pm_tv_arg(t,i) enddo - call pm_panic('pm_test_typ_includes bad type kind') + call pm_panic('pm_test_type_includes bad type kind') end select contains @@ -1734,22 +1941,22 @@ recursive function pm_test_typ_includes(context,supertype,subtype,& include 'fisnull.inc' include 'ftypeno.inc' - end function pm_test_typ_includes + end function pm_test_type_includes ! Does type correspond to only one concrete type - recursive function pm_typ_is_concrete(context,tno) result(ok) + recursive function pm_type_is_concrete(context,tno) result(ok) type(pm_context),pointer:: context integer,intent(in):: tno logical:: ok - ok=iand(pm_typ_flags(context,tno),pm_typ_has_generic)==0 + ok=iand(pm_type_flags(context,tno),pm_type_has_generic)==0 contains include 'fisnull.inc' - end function pm_typ_is_concrete + end function pm_type_is_concrete ! Does a type directly include itself (not as element of ! embedded struct/rec or array) - recursive function pm_typ_is_recur(context,rno,tno) result(ok) + recursive function pm_type_is_recur(context,rno,tno) result(ok) type(pm_context),pointer:: context integer,intent(in):: rno,tno logical:: ok @@ -1758,31 +1965,30 @@ recursive function pm_typ_is_recur(context,rno,tno) result(ok) integer:: j ok=.false. if(tno==0) return - tv=pm_typ_vect(context,tno) - if(pm_tv_kind(tv)==pm_typ_is_any.or.& - pm_tv_kind(tv)==pm_typ_is_all) then + tv=pm_type_vect(context,tno) + if(pm_tv_kind(tv)==pm_type_is_any.or.& + pm_tv_kind(tv)==pm_type_is_all) then do j=1,pm_tv_numargs(tv) tno2=pm_tv_arg(tv,j) if(tno2==rno) then ok=.true. return - elseif(pm_typ_is_recur(context,rno,tno2)) then + elseif(pm_type_is_recur(context,rno,tno2)) then ok=.true. return endif enddo endif - end function pm_typ_is_recur + end function pm_type_is_recur ! Does a type contain an element (structure/rec component, ! array domain or values, applied recursively) of a given ! type? - recursive function pm_typ_contains_elem(context,p,q,& - mode,einfo,params,base,user,ubase) result(ok) + recursive function pm_type_contains_elem(context,p,q,& + mode,params,base,user,ubase) result(ok) type(pm_context),pointer:: context integer,intent(in):: p,q integer,intent(in):: mode - type(pm_typ_einfo),intent(out):: einfo integer,dimension(:),intent(inout):: params integer,intent(in):: base integer,dimension(:),intent(inout):: user @@ -1790,7 +1996,7 @@ recursive function pm_typ_contains_elem(context,p,q,& type(pm_ptr):: u logical:: ok integer:: i,k,uk - if(pm_test_typ_includes(context,p,q,mode,einfo,& + if(pm_test_type_includes(context,p,q,mode,& params,base,user,ubase)) then ok=.true. return @@ -1799,348 +2005,541 @@ recursive function pm_typ_contains_elem(context,p,q,& ok=.false. return endif - u=pm_typ_vect(context,q) + u=pm_type_vect(context,q) uk=pm_tv_kind(u) select case(uk) - case(pm_typ_is_all) + case(pm_type_is_all) do i=1,pm_tv_numargs(u) - if(pm_typ_contains_elem(context,p,pm_tv_arg(u,i),& - mode,einfo,params,base,user,ubase)) then + if(pm_type_contains_elem(context,p,pm_tv_arg(u,i),& + mode,params,base,user,ubase)) then ok=.true. return endif enddo ok=.false. - case(pm_typ_is_any) + case(pm_type_is_any) do i=1,pm_tv_numargs(u) - if(.not.pm_typ_contains_elem(context,p,pm_tv_arg(u,i),& - mode,einfo,params,base,user,ubase)) then + if(.not.pm_type_contains_elem(context,p,pm_tv_arg(u,i),& + mode,params,base,user,ubase)) then ok=.false. return endif enddo ok=.true. - case(pm_typ_is_except) - ok=pm_typ_contains_elem(context,p,pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + case(pm_type_is_except) + ok=pm_type_contains_elem(context,p,pm_tv_arg(u,1),& + mode,params,base,user,ubase) if(ok) then - ok=.not.pm_typ_includes(context,pm_tv_arg(u,2),& - p,pm_typ_incl_typ,einfo) + ok=.not.pm_type_includes(context,pm_tv_arg(u,2),& + p,pm_type_incl_type) endif - case(pm_typ_is_array) - if(pm_typ_contains_elem(context,p,pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase)) then + case(pm_type_is_array) + if(pm_type_contains_elem(context,p,pm_tv_arg(u,1),& + mode,params,base,user,ubase)) then ok=.true. return - elseif(pm_typ_contains_elem(context,p,pm_tv_arg(u,2),& - mode,einfo,params,base,user,ubase)) then + elseif(pm_type_contains_elem(context,p,pm_tv_arg(u,2),& + mode,params,base,user,ubase)) then ok=.true. return else ok=.false. endif - case(pm_typ_is_struct,pm_typ_is_rec,& - pm_typ_is_tuple,pm_typ_is_vtuple) + case(pm_type_is_rec,pm_type_is_tuple,pm_type_is_vtuple) do i=1,pm_tv_numargs(u) - if(pm_typ_contains_elem(context,p,pm_tv_arg(u,i),& - mode,einfo,params,base,user,ubase)) then + if(pm_type_contains_elem(context,p,pm_tv_arg(u,i),& + mode,params,base,user,ubase)) then ok=.true. return endif enddo ok=.false. - case(pm_typ_is_dref) - ok=pm_typ_contains_elem(context,p,pm_tv_arg(u,3),& - mode,einfo,params,base,user,ubase) + case(pm_type_is_dref) + ok=pm_type_contains_elem(context,p,pm_tv_arg(u,3),& + mode,params,base,user,ubase) if(.not.ok) then i=pm_tv_arg(u,2) - k=pm_typ_kind(context,i) - if(k==pm_typ_is_par_kind) then - u=pm_typ_vect(context,i) + k=pm_type_kind(context,i) + if(k==pm_type_is_par_kind) then + u=pm_type_vect(context,i) i=pm_tv_arg(u,1) - k=pm_typ_kind(context,i) + k=pm_type_kind(context,i) endif - if(k==pm_typ_is_dref) then - ok=pm_typ_contains_elem(context,p,i,& - mode,einfo,params,base,user,ubase) + if(k==pm_type_is_dref) then + ok=pm_type_contains_elem(context,p,i,& + mode,params,base,user,ubase) endif endif - case(pm_typ_is_par_kind,pm_typ_is_vect,& - pm_typ_is_enveloped,pm_typ_is_interface,& - pm_typ_is_contains,pm_typ_is_has,& - pm_typ_is_params,pm_typ_is_param) - ok=pm_typ_contains_elem(context,p,pm_tv_arg(u,1),& - mode,einfo,params,base,user,ubase) + case(pm_type_is_par_kind,pm_type_is_vect,& + pm_type_is_contains,pm_type_is_has,& + pm_type_is_params,pm_type_is_param) + ok=pm_type_contains_elem(context,p,pm_tv_arg(u,1),& + mode,params,base,user,ubase) + case(pm_type_is_gated) + if(test_gated_type(context,q)) then + ok=pm_type_contains_elem(context,p,pm_tv_arg(u,pm_tv_numargs(u)),& + mode,params,base,user,ubase) + else + ok=.true. + endif case default ok=.false. end select - end function pm_typ_contains_elem + end function pm_type_contains_elem + + recursive function pm_type_intersects(context,tno1,tno2,user,userbase) result(ok) + type(pm_context),pointer:: context + integer,intent(in):: tno1,tno2,userbase + integer,intent(inout):: user(:) + logical:: ok + integer:: tk1,tk2 + type(pm_ptr):: tv1,tv2,r + integer:: n1,n2,i,j + + if(tno1==tno2) then + ok=.true. + return + endif + if(tno1==0.or.tno2==0) then + ok=.true. + return + endif + if(pm_type_includes(context,tno2,tno1,pm_type_incl_type)) then + ok=.true. + return + endif + if(pm_type_includes(context,tno1,tno2,pm_type_incl_type)) then + ok=.true. + return + endif + if(pm_type_is_concrete(context,tno1).or.pm_type_is_concrete(context,tno2)) then + ok=.false. + return + endif + tv1=pm_type_vect(context,tno1) + tv2=pm_type_vect(context,tno2) + tk1=pm_tv_kind(tv1) + tk2=pm_tv_kind(tv2) + n1=pm_tv_numargs(tv1) + n2=pm_tv_numargs(tv2) + + select case(tk2) + case(pm_type_is_user) + if(tk1/=pm_type_is_user) then + do i=2,userbase,2 + if(user(i)==tno1.and.user(i+1)==tno2) then + ok=.true. + return + endif + enddo + if(userbase+2>size(user)) then + call pm_panic('Program too complex - nested type defs') + endif + user(userbase+1)=tno1 + user(userbase+2)=tno2 + r=pm_dict_val(context,context%tcache,int(tno2,pm_ln)) + ok=pm_type_intersects(context,tno1,int(r%offset),user,userbase+2) + return + endif + return + case(pm_type_is_any) + if(tk1==pm_type_is_any) then + ok=.false. + do i=1,n1 + do j=1,n2 + if(i/=j) then + if(pm_type_intersects(context,pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& + user,userbase)) then + ok=.true. + return + endif + endif + enddo + enddo + else + ok=.false. + do j=1,n2 + if(pm_type_intersects(context,tno1,pm_tv_arg(tv2,j),& + user,userbase)) then + ok=.true. + return + endif + enddo + endif + return + case(pm_type_is_all) + if(tk1==pm_type_is_all) then + ok=.true. + do i=1,n1 + do j=1,n2 + if(i/=j) then + if(.not.pm_type_intersects(context,pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& + user,userbase)) then + ok=.false. + return + endif + endif + enddo + enddo + else + ok=.true. + do j=1,n2 + if(.not.pm_type_intersects(context,tno1,pm_tv_arg(tv2,j),& + user,userbase)) then + ok=.false. + return + endif + enddo + endif + return + case(pm_type_is_contains,pm_type_is_category,pm_type_is_bottom) + ok=.true. + return + case(pm_type_is_gated) + if(test_gated_type(context,tno2)) then + ok=pm_type_intersects(context,tno1,pm_tv_arg(tv2,pm_tv_numargs(tv2)),& + user,userbase) + else + ok=.true. + endif + return + case(pm_type_is_par_kind,pm_type_is_vect,pm_type_is_has,& + pm_type_is_params,pm_type_is_param) + ok=pm_type_intersects(context,pm_tv_arg(tv2,1),tno2,user,userbase) + return + case(pm_type_is_except) + if(tk1==pm_type_is_except) then + if(pm_type_intersects(context,pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& + user,userbase)) then + if(pm_type_includes(context,pm_tv_arg(tv2,2),pm_tv_arg(tv1,1),pm_type_incl_type)) then + ok=.false. + return + endif + if(pm_type_includes(context,pm_tv_arg(tv1,2),pm_tv_arg(tv2,1),pm_type_incl_type)) then + ok=.false. + return + endif + ok=.true. + return + else + ok=.false. + endif + else + if(pm_type_intersects(context,tno1,pm_tv_arg(tv2,1),& + user,userbase)) then + if(pm_type_includes(context,pm_tv_arg(tv2,2),tno1,pm_type_incl_type)) then + ok=.false. + return + endif + ok=.true. + else + ok=.false. + endif + endif + return + end select + + + select case(tk1) + case(pm_type_is_user) + do i=2,userbase,2 + if(user(i)==tno1.and.user(i+1)==tno2) then + ok=.true. + return + endif + enddo + if(userbase+2>size(user)) then + call pm_panic('Program too complex - nested type defs') + endif + user(userbase+1)=tno1 + user(userbase+2)=tno2 + r=pm_dict_val(context,context%tcache,int(tno1,pm_ln)) + ok=pm_type_intersects(context,int(r%offset),tno2,user,userbase+2) + case(pm_type_is_any) + ok=.false. + do i=1,n1 + if(pm_type_intersects(context,tno1,pm_tv_arg(tv1,i),& + user,userbase)) then + ok=.true. + return + endif + enddo + case(pm_type_is_all) + ok=.true. + do i=1,n1 + if(pm_type_intersects(context,tno1,pm_tv_arg(tv1,i),& + user,userbase)) then + ok=.true. + return + endif + enddo + case(pm_type_is_except) + if(pm_type_intersects(context,pm_tv_arg(tv1,1),tno2,& + user,userbase)) then + if(pm_type_includes(context,pm_tv_arg(tv2,2),tno1,pm_type_incl_type)) then + ok=.false. + return + endif + ok=.true. + else + ok=.false. + endif + case(pm_type_is_contains,pm_type_is_category,pm_type_is_bottom) + ok=.true. + case(pm_type_is_par_kind,pm_type_is_vect,pm_type_is_has,& + pm_type_is_params,pm_type_is_param) + ok=pm_type_intersects(context,pm_tv_arg(tv1,1),tno2,user,userbase) + case(pm_type_is_gated) + if(test_gated_type(context,tno1)) then + ok=pm_type_intersects(context,pm_tv_arg(tv1,pm_tv_numargs(tv1)),tno2,& + user,userbase) + else + ok=.true. + endif + case default + if(tk1/=tk2) then + ok=.false. + return + endif + if(pm_tv_name(tv1)/=pm_tv_name(tv2)) then + ok=.false. + return + endif + if(n1/=n2) then + ok=.false. + return + endif + do i=1,n1 + if(.not.pm_type_intersects(context,pm_tv_arg(tv1,i),pm_tv_arg(tv2,i),& + user,userbase)) then + ok=.false. + return + endif + enddo + ok=.true. + end select + end function pm_type_intersects + function test_gated_type(context,tno) result(ok) + type(pm_context),pointer:: context + integer,intent(in):: tno + logical:: ok + integer:: i + type(pm_ptr):: tv + integer::stack(max_user_nesting) + tv=pm_type_vect(context,tno) + do i=1,pm_tv_numargs(tv)-1,2 + if(.not.pm_type_intersects(context,pm_tv_arg(tv,i),pm_tv_arg(tv,i+1),stack,1)) then + ok=.false. + return + endif + enddo + ok=.true. + end function test_gated_type + !=============================================== ! Perform enveloping conversions if possible ! Returns -1 if not possible + ! Set converted_to_poly if a poly conversion has + ! been performed and the value needs boxing !============================================== - function pm_typ_convert(context,partyp,argtyp,dopoly) result(ctyp) + function pm_type_convert(context,partyp,argtyp,doliteral,doproc,dopoly,converted_to_poly) result(ctyp) type(pm_context),pointer:: context integer,intent(in):: partyp,argtyp - logical,intent(in):: dopoly + logical,intent(in):: doliteral,doproc,dopoly + logical,intent(out),optional:: converted_to_poly integer:: ctyp - integer:: tk,ptyp + integer:: tk,ptyp,atyp,pmode,amode type(pm_ptr):: tv +!!$ write(*,*) 'Convert',trim(pm_type_as_string(context,partyp)),& +!!$ '::',trim(pm_type_as_string(context,argtyp)),doliteral,doproc ctyp=-1 - ptyp=partyp - if(partyp<=0.or.argtyp<=0) then + if(partyp<0.or.argtyp<0) then return endif - tk=pm_typ_kind(context,ptyp) - do while(tk==pm_typ_is_user) - ptyp=pm_user_typ_body(context,ptyp) - tk=pm_typ_kind(context,ptyp) + if(present(converted_to_poly)) converted_to_poly=.false. + ptyp=partyp + atyp=pm_type_strip_mode(context,argtyp,amode) + tk=pm_type_kind(context,ptyp) + if(tk==pm_type_is_par_kind) then + if(.not.pm_mode_includes(pm_type_name(context,ptyp),amode)) return + ptyp=pm_type_arg(context,ptyp,1) + tk=pm_type_kind(context,ptyp) + endif + do while(tk==pm_type_is_user) + ptyp=pm_user_type_body(context,ptyp) + tk=pm_type_kind(context,ptyp) + enddo + if(tk==pm_type_is_param) then + ptyp=pm_type_arg(context,ptyp,1) + tk=pm_type_kind(context,ptyp) + endif + do while(tk==pm_type_is_user) + ptyp=pm_user_type_body(context,ptyp) + tk=pm_type_kind(context,ptyp) enddo - if(tk==pm_typ_is_interface) then - ctyp=pm_interface_typ_convert(context,ptyp,argtyp) + if(doliteral.and.pm_type_kind(context,atyp)==pm_type_is_literal_value) then + ctyp=pm_literal_type_convert(context,ptyp,atyp) endif - if(ctyp<0.and.tk==pm_typ_is_proc) then - ctyp=pm_proc_typ_convert(context,ptyp,argtyp) + if(ctyp<0.and.doproc.and.tk==pm_type_is_proc) then + ctyp=pm_proc_type_convert(context,ptyp,atyp) endif - if(ctyp<0.and.dopoly.and.tk==pm_typ_is_poly) then - ctyp=pm_poly_typ_convert(context,ptyp,argtyp) + if(ctyp<0.and.dopoly.and.tk==pm_type_is_poly) then + ctyp=pm_poly_type_convert(context,ptyp,atyp,converted_to_poly) endif - end function pm_typ_convert + ctyp=pm_type_add_mode(context,ctyp,amode) + !write(*,*) 'To:',trim(pm_type_as_string(context,ctyp)) + end function pm_type_convert + !================================================================ - ! Autoconversion to broader poly type - ! Returns -1 if not possible + ! Autoconversion of a literal type !================================================================ - function pm_poly_typ_convert(context,partyp,argtyp) result(ctyp) + function pm_literal_type_convert(context,partyp,argtyp) result(ctyp) type(pm_context),pointer:: context integer,intent(in):: partyp,argtyp integer:: ctyp - type(pm_ptr):: tv1,tv2 - type(pm_typ_einfo):: einfo - ctyp=-1 - tv1=pm_typ_vect(context,partyp) - tv2=pm_typ_vect(context,argtyp) - if(pm_tv_kind(tv1)==pm_typ_is_poly.and.pm_tv_kind(tv2)==pm_typ_is_poly) then - if(pm_typ_includes(context,pm_tv_arg(tv1,1),pm_tv_arg(tv2,1),& - pm_typ_incl_typ,einfo)) then + integer:: tk + + ctyp=pm_type_for_var(context,pm_type_arg(context,argtyp,1),-1) + tk=pm_type_kind(context,partyp) + if(tk==pm_type_is_fix) then + if(pm_type_includes(context,pm_type_arg(context,partyp,1),ctyp,& + pm_type_incl_val)) then + ctyp=pm_new_fix_value_type(context,& + pm_type_val(context,argtyp),pm_type_name(context,argtyp)) + endif + elseif(tk==pm_type_is_fix_value) then + if(pm_type_name(context,partyp)==pm_type_name(context,argtyp)) then ctyp=partyp endif + elseif(tk==pm_type_is_literal.or.tk==pm_type_is_literal_value) then + ctyp=argtyp endif - end function pm_poly_typ_convert - - !================================================================ - ! Autoconversion to interface type, yielding enveloped type - ! Returns -1 if not possible - !================================================================ - function pm_interface_typ_convert(context,partyp,argtyp) result(ctyp) + end function pm_literal_type_convert + + !========================================================= + ! Convert a moded literal type to a moded non-literal type + !========================================================= + function pm_type_strip_literal(context,typ) result(ctyp) type(pm_context),pointer:: context - integer,intent(in):: partyp,argtyp + integer,intent(in):: typ integer:: ctyp - integer,dimension(4):: args - integer:: tno + integer:: tno,tk,mode type(pm_ptr):: tv - tv=pm_typ_vect(context,partyp) - tno=partyp - if(pm_tv_kind(tv)==pm_typ_is_user) then - tno=pm_user_typ_body(context,partyp) - tv=pm_typ_vect(context,tno) - endif - if(pm_tv_kind(tv)==pm_typ_is_interface) then - args(1)=pm_typ_new_enveloped - args(2)=pm_tv_name(tv) - args(3)=argtyp - args(4)=tno - ctyp=pm_new_typ(context,args) - else - ctyp=-1 + ctyp=typ + if(typ<=0) return + tno=pm_type_strip_mode(context,typ,mode) + tv=pm_type_vect(context,tno) + tk=pm_tv_kind(tv) + if(tk==pm_type_is_literal_value.or.tk==pm_type_is_fix_value) then + ctyp=pm_type_add_mode(context,pm_tv_arg(tv,1),mode) endif - end function pm_interface_typ_convert + end function pm_type_strip_literal - !=============================================================== - ! Check if type q conforms to interface p - ! - if q is also an interface then add information that q:p - !=============================================================== - recursive function pm_interface_typ_conforms(context,p,q,einfo,except) result(ok) + !================================================================ + ! Autoconversion to broader poly type or from + ! monomorphic to polymorphic type + ! Returns -1 if not possible + !================================================================ + function pm_poly_type_convert(context,partyp,argtyp,converted_to_poly) result(ctyp) type(pm_context),pointer:: context - integer,intent(in):: p,q - type(pm_typ_einfo),intent(out):: einfo - integer,intent(in),optional:: except - logical:: ok - integer:: s,tk,uk,i,j,k,nt,nu,elem,err,name - type(pm_ptr):: t,u,r,names1,names2 - integer,dimension(max_user_nesting):: params - logical:: ok2 - t=pm_typ_vect(context,p) - u=pm_typ_vect(context,q) - tk=pm_tv_kind(t) - uk=pm_tv_kind(u) - - select case(uk) - case(pm_typ_is_user) - r=pm_dict_val(context,context%tcache,int(q,pm_ln)) - ok=pm_interface_typ_conforms(context,p,int(r%offset),& - einfo,except) - case(pm_typ_is_any) - do i=1,pm_tv_numargs(u) - if(present(except)) then - if(pm_typ_includes(context,except,pm_tv_arg(u,i),& - pm_typ_incl_typ,einfo)) cycle - endif - if(.not.pm_interface_typ_conforms(context,p,pm_tv_arg(u,i),& - einfo,except)) then - ok=.false. - endif - enddo - ok=.true. - case(pm_typ_is_all) - do i=1,pm_tv_numargs(u) - if(pm_interface_typ_conforms(context,p,pm_tv_arg(u,i),& - einfo,except)) then - ok=.true. - endif - enddo - ok=.false. - case(pm_typ_is_except) - if(present(except)) then - ok=pm_interface_typ_conforms(context,p,pm_tv_arg(u,i),& - einfo,pm_typ_combine(context,pm_tv_arg(u,2),except)) - else - ok=pm_interface_typ_conforms(context,p,pm_tv_arg(u,i),& - einfo,pm_tv_arg(u,2)) - endif - case(pm_typ_is_param,pm_typ_is_params,& - pm_typ_is_enveloped,pm_typ_is_contains,pm_typ_is_has,& - pm_typ_is_vect) - ok=pm_interface_typ_conforms(context,p,pm_tv_arg(u,1),& - einfo,except) - case(pm_typ_is_interface) - names1=pm_name_val(context,pm_tv_name(t)) - names2=pm_name_val(context,pm_tv_name(u)) - - ! Check consistency with any shadowing elements - outer: do i=1,pm_fast_esize(names1) - nt=names1%data%i(names1%offset+i) - do j=1,pm_fast_esize(names2) - nu=names2%data%i(names2%offset+j) - if(nt==nu.or.(nt==-nu.and.nt>0)) then - if(pm_typ_includes(context,& - pm_tv_arg(t,i+1),pm_tv_arg(u,j+1),& - pm_typ_incl_typ,einfo)) then - cycle outer - else - einfo%kind=pm_typ_err_interface_nesting - einfo%typ1=p - einfo%typ2=q - einfo%vtyp1=pm_tv_arg(t,i+1) - einfo%vtyp2=pm_tv_arg(u,j+1) - einfo%vname=abs(nt) - ok=.false. - return - endif - elseif(nt==-nu.and.nt<0) then - einfo%kind=pm_typ_err_interface_inconsistent - einfo%typ1=p - einfo%typ2=q - ok=.false. - return - endif - enddo - einfo%kind=pm_typ_err_interface_elem - einfo%typ1=p - einfo%typ2=q - einfo%vname=abs(nt) - return - enddo outer - ok=.true. - case(pm_typ_is_rec,pm_typ_is_struct) - ok=.true. - names1=pm_name_val(context,pm_tv_name(t)) - einfo%vtyp1=p - einfo%vtyp2=q - do i=1,pm_fast_esize(names1) - nt=names1%data%i(names1%offset+i) - einfo%vname=abs(nt) - uk=1 - elem=pm_typ_find_elem(context,q,abs(nt),nt<0,& - params,uk,size(params),s,einfo) - if(elem==0) then - if(einfo%kind/=pm_typ_err_elem_clash) then - einfo%kind=merge(pm_typ_err_interface_write,& - pm_typ_err_interface,nt<0) + integer,intent(in):: partyp,argtyp + logical,intent(out),optional:: converted_to_poly + integer:: ctyp + type(pm_ptr):: tv1,tv2 + ctyp=-1 + tv1=pm_type_vect(context,partyp) + tv2=pm_type_vect(context,argtyp) + if(present(converted_to_poly)) converted_to_poly=.false. + if(pm_tv_kind(tv1)==pm_type_is_poly) then + if(pm_tv_kind(tv2)==pm_type_is_poly) then + if(pm_type_includes(context,pm_tv_name(tv1),pm_tv_name(tv2),& + pm_type_incl_type)) then + if(pm_tv_numargs(tv2)>0) then + call remake(pm_tv_numargs(tv2)) + else + ctyp=partyp endif - ok=.false. - return endif - ok=pm_typ_includes(context,& - pm_tv_arg(t,i+1),s,& - pm_typ_incl_typ,einfo) - if(.not.ok) then - einfo%kind=pm_typ_err_interface_mismatch - einfo%typ1=pm_tv_arg(t,i+1) - einfo%typ2=s - return + else + if(pm_type_includes(context,pm_tv_name(tv1),argtyp,& + pm_type_incl_type)) then + ctyp=pm_new_poly_val_type(context,pm_tv_name(tv1),argtyp) + if(present(converted_to_poly)) converted_to_poly=.true. endif - enddo - case default - einfo%kind=pm_typ_err_interface_bad_typ - einfo%vtyp1=q - ok=.false. - end select + endif + endif contains - include 'fesize.inc' - include 'ftypeof.inc' - include 'ftypeno.inc' - include 'ftiny.inc' - end function pm_interface_typ_conforms + subroutine remake(n) + integer,intent(in)::n + integer,dimension(n+2):: a + integer:: i,recur + a(1)=pm_type_new_poly + a(2)=pm_tv_name(tv1) + recur=-1 + do i=3,n+2 + a(i)=pm_tv_arg(tv2,i-2) + if(iand(pm_type_flags(context,a(i)),& + pm_type_has_poly+pm_type_is_recursive)/=0) then + if(recur<0) then + recur=pm_type_new_recursive_ref(context) + endif + a(i)=pm_type_move_recursive(context,a(i),recur) + endif + enddo + ctyp=pm_new_type(context,a) + if(recur>0) call pm_type_set_recursive_ref(context,recur,ctyp) + end subroutine remake + end function pm_poly_type_convert + !========================================== ! Autoconversion to proc signature type ! Returns -1 if not possible !========================================== - function pm_proc_typ_convert(context,ptyp,argtyp) result(ctyp) + function pm_proc_type_convert(context,ptyp,argtyp) result(ctyp) type(pm_context),pointer:: context integer,intent(in):: ptyp,argtyp integer:: ctyp type(pm_ptr):: tv,tv2 integer:: i,tno integer,dimension(3):: arr - tv=pm_typ_vect(context,ptyp) - tv2=pm_typ_vect(context,argtyp) - if(pm_tv_kind(tv)/=pm_typ_is_proc.or.& - pm_tv_kind(tv2)/=pm_typ_is_proc) then + tv=pm_type_vect(context,ptyp) + tv2=pm_type_vect(context,argtyp) + if(pm_tv_kind(tv)/=pm_type_is_proc.or.& + pm_tv_kind(tv2)/=pm_type_is_proc) then ctyp=-1 return endif tno=pm_tv_arg(tv,1) do i=1,pm_tv_numargs(tv2) - if(pm_proc_typ_conforms(context,tno,& + if(pm_proc_type_conforms(context,tno,& pm_tv_arg(tv2,i))) then - arr(1)=pm_typ_new_proc + arr(1)=pm_type_new_proc arr(2)=-abs(pm_tv_name(tv2)) arr(3)=tno - ctyp=pm_new_typ(context,arr) + ctyp=pm_new_type(context,arr) return endif enddo ctyp=-1 return - end function pm_proc_typ_convert + end function pm_proc_type_convert !=========================================== ! Check that two proc_sig types conform !=========================================== - function pm_proc_typ_conforms(context,tno,tno2) result(ok) + function pm_proc_type_conforms(context,tno,tno2) result(ok) type(pm_context),pointer:: context integer,intent(in):: tno,tno2 logical:: ok type(pm_ptr):: tv,tv2,tv_res,tv_res2 - type(pm_typ_einfo):: einfo integer:: i,tno_res,tno_res2 - tv=pm_typ_vect(context,tno) - tv2=pm_typ_vect(context,tno2) + tv=pm_type_vect(context,tno) + tv2=pm_type_vect(context,tno2) if(pm_tv_name(tv)/=pm_tv_name(tv2)) then @@ -2148,507 +2547,605 @@ function pm_proc_typ_conforms(context,tno,tno2) result(ok) return endif - if(.not.pm_typ_includes(context,pm_tv_arg(tv2,1),& - pm_tv_arg(tv,1),pm_typ_incl_typ,einfo)) then + if(.not.pm_type_includes(context,pm_tv_arg(tv2,1),& + pm_tv_arg(tv,1),pm_type_incl_type)) then ok=.false. return endif tno_res=pm_tv_arg(tv,2) tno_res2=pm_tv_arg(tv2,2) - tv_res=pm_typ_vect(context,tno_res) - tv_res2=pm_typ_vect(context,tno_res2) - if(pm_tv_kind(tv_res2)==pm_typ_is_undef_result) then + tv_res=pm_type_vect(context,tno_res) + tv_res2=pm_type_vect(context,tno_res2) + if(pm_tv_kind(tv_res2)==pm_type_is_undef_result) then ok=pm_tv_numargs(tv_res)==pm_tv_name(tv_res2) return else - if(.not.pm_typ_includes(context,tno_res,& - tno_res2,pm_typ_incl_equiv,einfo)) then + if(.not.pm_type_includes(context,tno_res,& + tno_res2,pm_type_incl_equiv)) then ok=.false. return endif endif ok=.true. - end function pm_proc_typ_conforms + end function pm_proc_type_conforms !================================================================= ! Find element "name" in type "tno" ! If change is true then element must be able to be modified ! Returns - ! offset==0 Error -- details in einfo + ! offset==0 Error ! offset>0 This is the offset of the element in the type - ! offset<0 Nested offsets detailed in stack(old_top:top) + ! offset<0 Returns dref rather than sub-element ! If offset/=0 then etype returns the type of the element !================================================================= - recursive function pm_typ_find_elem(context,tno,name,change,& - stack,top,maxstack,etype,einfo) result(offset) + recursive function pm_type_find_elem(context,value_type,name_type,change,etype) result(offset) type(pm_context),pointer:: context - integer,intent(in):: tno,name + integer,intent(in):: value_type,name_type logical,intent(in):: change - integer,dimension(:),intent(inout):: stack - integer,intent(inout):: top - integer,intent(in):: maxstack integer,intent(out):: etype - type(pm_typ_einfo),intent(out):: einfo - integer:: offset,ptype,mode - type(pm_ptr):: tv,tv2,nameset,info - integer:: tk,i,key(2),tno2,name2 - integer(pm_ln):: j - logical:: found + integer:: offset,ptype,mode,nametype,tno + type(pm_ptr):: tv,nameval,names + integer:: tk,i,name + + nametype=pm_type_strip_mode(context,name_type,mode) + tno=pm_type_strip_mode(context,value_type,mode) + tk=pm_type_kind(context,nametype) + if(tk==pm_type_is_literal_value.or.tk==pm_type_is_fix_value) then + tv=pm_type_vect(context,tno) + tk=pm_tv_kind(tv) + nameval=pm_type_val(context,nametype) + offset=nameval%data%ln(nameval%offset) + if(tk==pm_type_is_rec) then + if(offset<=0.or.offset>pm_type_numargs(context,tno)) then + offset=0 + elseif(change) then + names=pm_name_val(context,pm_tv_name(tv)) + if(names%data%i(names%offset+offset)>0) offset=0 + endif + if(offset/=0) etype=pm_type_arg(context,tno,offset) + elseif(tk==pm_type_is_tuple.or.tk==pm_type_is_dref) then + if(offset<=0.or.offset>pm_type_numargs(context,tno)) then + offset=0 + else + etype=pm_type_arg(context,tno,offset) + endif + return + else + offset=0 + endif + if(offset>0) etype=pm_type_add_mode(context,etype,mode) + return + endif + name=pm_type_name(context,nametype) if(tno<0) then offset=0 return endif if(tno==0) then offset=0 - einfo%kind=pm_typ_err_elem_bad_typ endif - einfo%kind=0 - einfo%typ1=tno - einfo%name=name - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) tk=pm_tv_kind(tv) select case(tk) - case(pm_typ_is_all) + case(pm_type_is_all) do i=1,pm_tv_numargs(tv) - offset=pm_typ_find_elem(context,pm_tv_arg(tv,i),name,change,& - stack,top,maxstack,etype,einfo) + offset=pm_type_find_elem(context,pm_tv_arg(tv,i),nametype,change,etype) if(offset/=0) return enddo offset=0 - einfo%kind=pm_typ_err_elem_not_found return - case(pm_typ_is_dref) - offset=pm_typ_find_elem(context,& - pm_typ_strip_mode(context,pm_tv_arg(tv,1),mode),& - name,change,stack,top,& - maxstack,etype,einfo) - if(offset==0) then - return + case(pm_type_is_literal_value) + offset=pm_type_find_elem(context,pm_tv_arg(tv,1),nametype,change,etype) + tv=pm_type_vect(context,etype) + if(pm_tv_kind(tv)==pm_type_is_fix_value) then + etype=pm_new_literal_value_type(context,& + pm_type_val(context,etype),pm_type_name(context,etype)) else - offset=offset+pm_typ_dref_offset - endif - call push(pm_typ_new_dref) - call push(name) - call push(pm_typ_add_mode(context,etype,mode,.false.)) - call push(tno) - do i=3,pm_tv_numargs(tv) - call push(pm_tv_arg(tv,i)) - enddo - etype=pm_new_typ(context,stack(top-pm_tv_numargs(tv)-1:top)) - top=top-pm_tv_numargs(tv)-2 - case(pm_typ_is_struct,pm_typ_is_rec) - if(change.and.tk==pm_typ_is_rec) then - einfo%kind=pm_typ_err_elem_not_found - offset=0 - return + etype=pm_new_literal_value_type(context,& + pm_null_obj,0,etype) endif - call elem_offset(context,tv,name,change,offset,etype) - if(offset>0) return - if(offset<0) then - call indirect_offset(context,tv,name,stack,& - maxstack,top,change,etype,ptype,einfo) - if(einfo%kind==0) then - offset=-top - return - else - offset=0 - return - endif - else - einfo%kind=pm_typ_err_elem_not_found - offset=0 - endif - case(pm_typ_is_enveloped) - tno2=pm_tv_arg(tv,2) - tv2=pm_typ_vect(context,tno2) - nameset=pm_name_val(context,pm_tv_name(tv2)) - found=.false. - do i=1,pm_fast_esize(nameset) - name2=nameset%data%i(nameset%offset+i) - if(name==abs(name2)) then - found=.true. - exit - endif - enddo - if(.not.found) then - einfo%kind=pm_typ_err_elem_not_in_interface - einfo%typ1=tno2 - offset=0 - return - endif - offset=pm_typ_find_elem(context,pm_tv_arg(tv,1),& - name,change,stack,top,maxstack,etype,einfo) + case(pm_type_is_rec) + call pm_type_elem_offset(context,tv,name,change,offset,etype) case default - einfo%kind=pm_typ_err_elem_bad_typ offset=0 return end select - contains - include 'ftypeof.inc' - include 'fesize.inc' - subroutine push(j) - integer:: j - top=top+1 - stack(top)=j - end subroutine push - end function pm_typ_find_elem + if(offset>0) etype=pm_type_add_mode(context,etype,mode) + end function pm_type_find_elem + !================================================================ ! Find offset and type for named element in struct/rec type ! Returns offset and type of element - ! If no such element offset=0 (or offset=-1 if embedded structs exist) - recursive subroutine elem_offset(context,tv,name,change,offset,etyp) + ! If no such element offset=0 + !================================================================ + subroutine pm_type_elem_offset(context,tv,name,change,offset,etyp) type(pm_context),pointer:: context type(pm_ptr),intent(in):: tv integer,intent(in):: name logical,intent(in):: change integer,intent(out):: offset,etyp - integer:: j,hi,lo + integer:: j integer:: name2 type(pm_ptr):: nv offset=0 etyp=0 nv=pm_name_val(context,pm_tv_name(tv)) do j=1,pm_fast_esize(nv) - if(abs(nv%data%i(nv%offset+j))==name) then + name2=nv%data%i(nv%offset+j) + if(abs(name2)==name) then + if(change.and.name2>0) then + offset=0 + return + endif etyp=pm_tv_arg(tv,j) - offset=j+1 + offset=j return endif enddo - if(iand(pm_tv_flags(tv),pm_typ_has_embedded)/=0) offset=-1 contains include 'fesize.inc' - end subroutine elem_offset + end subroutine pm_type_elem_offset - ! Find offsets to an embedded element "name" of tno - recursive subroutine indirect_offset(context,tv,name,stack,& - maxstack,top,change,etype,ptype,einfo) + !================================================================ + ! Concrete only version of a type (used/usable only for returns from builtin functions) + !================================================================ + recursive function pm_type_as_concrete(context,tno,params,isstatic,iserr) result(tno2) type(pm_context),pointer:: context - type(pm_ptr),intent(in):: tv - integer,intent(in):: name - integer,intent(inout):: top - integer,intent(in):: maxstack - integer,dimension(maxstack),intent(inout):: stack - logical,intent(in):: change - integer,intent(out):: etype,ptype - type(pm_typ_einfo),intent(out):: einfo - type(pm_ptr):: nv,tv2 - integer:: i - integer:: n,offset,new_etype,new_ptype,found_below,tk2 - integer:: name2 - logical:: found,clash_below - name2=pm_tv_name(tv) - nv=pm_name_val(context,name2) - found=.false. - found_below=0 - clash_below=.false. - do i=1,pm_fast_esize(nv) - n=nv%data%i(nv%offset+i) - if(n<0) then - new_ptype=pm_tv_arg(tv,i) - tv2=pm_typ_vect(context,new_ptype) - tk2=pm_tv_kind(tv2) - if(tk2/=pm_typ_is_struct.and.tk2/=pm_typ_is_rec) cycle - call elem_offset(context,tv2,name,change,offset,new_etype) - if(offset>0) then - if(top+4>maxstack) then - call pm_panic('Structure embedding too complex') - endif - if(found) then - einfo%kind=pm_typ_err_elem_clash - einfo%vtyp1=new_ptype - einfo%vtyp2=ptype - return - endif - call push(i+1) - call push(-n) - call push(offset) - call push(name) - etype=new_etype - ptype=new_ptype - found=.true. - elseif(offset<0.and..not.found) then - if(top+2>maxstack) then - call pm_panic('Internal limit reached - Structure embedding too complex') - endif - call push(i+1) - call push(-n) - call indirect_offset(context,tv2,name,stack,& - maxstack,top,change,new_etype,new_ptype,einfo) - if(einfo%kind==0) then - if(found_below>0) then - einfo%kind=pm_typ_err_elem_clash - einfo%vtyp1=new_ptype - einfo%vtyp2=ptype - else - etype=new_etype - ptype=new_ptype - endif - found_below=found_below+1 - elseif(einfo%kind==pm_typ_err_elem_clash) then - clash_below=.true. - top=top-2 - return - else ! Not found - top=top-2 - endif - endif + integer,intent(in):: tno + integer,dimension(:),intent(in):: params + logical,intent(out):: isstatic + logical,intent(out),optional:: iserr + integer:: tno2 + type(pm_ptr):: tv + integer:: tk,nt + isstatic=.true. + if(present(iserr)) iserr=.false. + tv=pm_type_vect(context,tno) + tk=pm_tv_kind(tv) + select case(tk) + case(pm_type_is_basic,pm_type_is_single_name,& + pm_type_is_proc,pm_type_is_fix_value,pm_type_is_fix,& + pm_type_is_undef_result,pm_type_is_poly) + tno2=tno + case(pm_type_is_user) + tno2=pm_user_type_body(context,tno) + case(pm_type_is_any,pm_type_is_all,pm_type_is_contains) + if(present(iserr)) then + iserr=.true. + isstatic=.true. + else + call pm_panic('cant make concrete') endif - enddo - if(clash_below.and..not.found) then - return - elseif(found_below>1.and.found) then - einfo%kind=0 - elseif(.not.found.and.found_below==0) then - einfo%kind=pm_typ_err_elem_not_found - endif + case default + call remake(pm_tv_numargs(tv)) + end select contains - include 'fesize.inc' - subroutine push(j) - integer,intent(in):: j - top=top+1 - stack(top)=j - end subroutine push - end subroutine indirect_offset + recursive subroutine remake(n) + integer,intent(in):: n + integer,dimension(n+2):: a + integer:: i + a(1)=iand(pm_tv_flags(tv),not(pm_type_has_generic)) + a(2)=pm_tv_name(tv) + if(present(iserr)) then + do i=1,n + a(i+2)=pm_type_as_concrete(context,pm_tv_arg(tv,i),params,isstatic,iserr) + if(iserr) return + enddo + else + do i=1,n + a(i+2)=pm_type_as_concrete(context,pm_tv_arg(tv,i),params,isstatic) + enddo + endif + tno2=pm_new_type(context,a) + end subroutine remake + end function pm_type_as_concrete + - ! Check that tno includes an embedded (use..) element of tno2 - recursive subroutine pm_indirect_include(context,tno,tno2,stack,& - maxstack,top,einfo,tno_match,status) + recursive function pm_type_replace(context,tno,oldtype,newtype) result(tno2) type(pm_context),pointer:: context - integer,intent(in):: tno,tno2 - integer,intent(inout):: top - integer,intent(in):: maxstack - integer,dimension(maxstack),intent(inout):: stack - type(pm_typ_einfo):: einfo - integer,intent(out):: tno_match - integer,intent(out):: status - - integer:: base,base2,tno_match1 - base=top - ! Check for match via 'use' element - if(test_indirect_include(context,+1,tno,tno2,stack,& - maxstack,base,top,einfo,tno_match)) then - base2=top - tno_match1=tno_match - ! Check for match in reverse order - if(test_indirect_include(context,-1,tno,tno2,stack,& - maxstack,base2,top,einfo,tno_match)) then - if(any(stack(base+1:base2)/=stack(base2+1:top))) then - ! Clashing elements - push error details onto stack - status=pm_elem_clash - if(top+3>maxstack) call pm_panic('Program too complex (indirect include)') - stack(top+1)=base - stack(top+2)=base2 - stack(top+3)=tno_match1 - top=top+3 - else - top=base2 - status=pm_elem_found - endif - else - call pm_panic('indirect_include') - endif + integer,intent(in):: tno,oldtype,newtype + integer:: tno2 + type(pm_ptr):: tv + integer:: tk,oldtyp,newtyp + if(pm_type_kind(context,oldtype)==pm_type_is_dref) then + oldtyp=pm_type_arg(context,oldtype,1) + newtyp=pm_type_arg(context,newtype,1) else - status=pm_elem_not_found + oldtyp=oldtype + newtyp=newtype endif - end subroutine pm_indirect_include + if(tno==oldtyp) then + tno2=newtyp + return + endif + tv=pm_type_vect(context,tno) + tk=pm_tv_kind(tv) + select case(tk) + case(pm_type_is_array) + tno2=pm_new_arr_type(context,pm_tv_name(tv),& + pm_type_replace(context,pm_tv_arg(tv,1),oldtyp,newtyp),& + pm_tv_arg(tv,2),pm_tv_arg(tv,3)) + !!! Dref should be only be overall type (arg(1)?) + case(pm_type_is_rec,pm_type_is_tuple,pm_type_is_dref) + call remake(pm_tv_numargs(tv)) + case default + tno2=tno + end select + contains + recursive subroutine remake(n) + integer,intent(in):: n + integer,dimension(n+2):: a + integer:: i,etyp + logical:: changed + a(1)=pm_tv_flags(tv) + a(2)=pm_tv_name(tv) + changed=.false. + do i=1,n + etyp=pm_tv_arg(tv,i) + a(i+2)=pm_type_replace(context,etyp,oldtyp,newtyp) + changed=changed.or.a(i+2)/=etyp + enddo + if(changed) then + tno2=pm_new_type(context,a) + else + tno2=tno + endif + end subroutine remake + end function pm_type_replace - ! Does the actual work for pm_indirect_include - recursive function test_indirect_include(context,dir,tno,tno2,stack,& - maxstack,base,top,einfo,tno_match) result(ok) + !================================================================ + ! Create a new type with with all fix values converted + ! to base type and mode changed to new_mode + !================================================================ + recursive function pm_type_for_var(context,tno,new_mode) result(typ) type(pm_context),pointer:: context - integer,intent(in):: tno,tno2 - integer,intent(inout):: top - integer,intent(in):: dir,maxstack,base - integer,dimension(maxstack),intent(inout):: stack - type(pm_typ_einfo):: einfo - integer,intent(out):: tno_match - logical:: ok - type(pm_ptr):: tv,name - integer:: i,j,start,finish,tk - integer:: n - if(tno2==0) return - tv=pm_typ_vect(context,tno2) + integer,intent(in):: tno,new_mode + integer:: typ + type(pm_ptr):: tv + integer:: tk + typ=tno + tv=pm_type_vect(context,tno) + if(iand(pm_tv_flags(tv),pm_type_has_fix)==0) return tk=pm_tv_kind(tv) select case(tk) - case(pm_typ_is_par_kind) - ok=test_indirect_include(context,dir,tno,pm_tv_arg(tv,1),stack,& - maxstack,base,top,einfo,tno_match) - return - case(pm_typ_is_any) - do i=1,pm_tv_numargs(tv) - if(.not.test_indirect_include(context,dir,tno,pm_tv_arg(tv,i),stack,& - maxstack,base,top,einfo,tno_match)) then - ok=.false. - return - endif - enddo - ok=.true. + case(pm_type_is_par_kind) + if(new_mode>0) then + typ=pm_type_add_mode(context,pm_type_for_var(context,pm_tv_arg(tv,1),new_mode),new_mode) + endif + case(pm_type_is_user) + typ=pm_user_type_body(context,tno) + case(pm_type_is_rec) + call remake(pm_tv_numargs(tv)) + case(pm_type_is_fix_value) + typ=pm_tv_arg(tv,1) + end select + contains + recursive subroutine remake(n) + integer,intent(in):: n + integer,dimension(n+2):: a + integer:: i + a(1)=iand(pm_tv_flags(tv),not(pm_type_has_fix)) + a(2)=pm_tv_name(tv) + do i=1,n + a(i+2)=pm_type_for_var(context,pm_tv_arg(tv,i),new_mode) + enddo + typ=pm_new_type(context,a) + end subroutine remake + end function pm_type_for_var + + !================================================================ + ! Combine two types for the same variable - must be the same type + ! except for poly values which are merged + !================================================================ + recursive function pm_type_combine(context,tno,tno2,ok,added) result(typ) + type(pm_context),pointer:: context + integer,intent(in):: tno,tno2 + logical,intent(out):: ok,added + integer:: typ + type(pm_ptr):: tv,tv2 + integer:: tk,tk2 + +!!$ write(*,*) 'combine types: ',trim(pm_type_as_string(context,tno)),' with ',& +!!$ trim(pm_type_as_string(context,tno2)) + + ok=.true. + added=.false. + if(tno<=0) then + typ=tno2 return - case(pm_typ_is_all) - do i=1,pm_tv_numargs(tv) - if(test_indirect_include(context,dir,tno,pm_tv_arg(tv,i),stack,& - maxstack,base,top,einfo,tno_match)) then - ok=.true. - return - endif - enddo + endif + typ=tno + if(tno2<=0.or.tno==tno2) return + if(pm_type_includes(context,tno,tno2,pm_type_incl_val)) return + tv=pm_type_vect(context,tno) + tv2=pm_type_vect(context,tno2) + + if(iand(pm_tv_flags(tv),pm_type_has_poly)==0.or.& + iand(pm_tv_flags(tv2),pm_type_has_poly)==0) then ok=.false. return - case(pm_typ_is_except) - if(test_indirect_include(context,dir,tno,pm_tv_arg(tv,1),stack,& - maxstack,base,top,einfo,tno_match)) then - ok=.not.test_indirect_include(context,dir,tno,pm_tv_arg(tv,2),stack,& - maxstack,base,top,einfo,tno_match) + endif + + tk=pm_tv_kind(tv) + tk2=pm_tv_kind(tv2) + select case(tk2) + case(pm_type_is_par_kind) + if(tk==pm_type_is_par_kind) then + typ=pm_type_add_mode(context,pm_type_combine(context,pm_tv_arg(tv,1),pm_tv_arg(tv2,1),ok,added),pm_tv_name(tv2)) else - ok=.false. + typ=pm_type_add_mode(context,pm_type_combine(context,tno,pm_tv_arg(tv2,1),ok,added),pm_tv_name(tv2)) + return endif + case(pm_type_is_user) + typ=pm_type_combine(context,tno,pm_user_type_body(context,tno2),ok,added) return - case(pm_typ_is_struct,pm_typ_is_rec) - continue + end select + + select case(tk) + case(pm_type_is_par_kind) + typ=pm_type_add_mode(context,pm_type_combine(context,& + pm_tv_arg(tv,1),tno2,ok,added),pm_tv_name(tv)) + case(pm_type_is_user) + typ=pm_type_combine(context,pm_user_type_body(context,tno),tno2,ok,added) + case(pm_type_is_rec,pm_type_is_array,pm_type_is_tuple,pm_type_is_vtuple) + if(tk/=tk2.or.pm_tv_name(tv)/=pm_tv_name(tv2)) then + ok=.false. + typ=-1 + return + endif + call remake(pm_tv_numargs(tv)) + case(pm_type_is_poly) + if(tk/=tk2.or.pm_tv_name(tv)/=pm_tv_name(tv2)) then + ok=.false. + typ=-1 + return + endif + call combine_poly(pm_tv_numargs(tv),pm_tv_numargs(tv2)) +!!$ write(*,*) 'Combined to: ',trim(pm_type_as_string(context,typ)),ok case default + typ=-1 ok=.false. - return end select + contains + + recursive subroutine remake(n) + integer,intent(in):: n + integer,dimension(n+2):: a + integer:: i + a(1)=pm_tv_flags(tv) + a(2)=pm_tv_name(tv) + do i=1,n + a(i+2)=pm_type_combine(context,pm_tv_arg(tv,i),pm_tv_arg(tv2,i),ok,added) + if(.not.ok) then + typ=-1 + return + endif + enddo + typ=pm_new_type(context,a) + end subroutine remake + + recursive subroutine combine_poly(n,n2) + integer,intent(in):: n,n2 + integer,dimension(n+n2+2):: a + logical,dimension(n):: mask + integer:: i,j,m,recur,typ2 + logical:: elem_added,elem_ok + +!!$ write(*,*) 'combine_poly',trim(pm_type_as_string(context,tno)),'<>',trim(pm_type_as_string(context,tno2)) +!!$ + a(1)=pm_type_new_poly + a(2)=pm_tv_name(tv) + do j=1,n + a(2+j)=pm_tv_arg(tv,j) + enddo + + ! Merge the two lists of concrete types + m=2+n + mask=.false. + outer:do i=1,n2 + do j=1,n + if(.not.mask(j)) then +!!$ write(*,*) 'Combining #',i,j + typ2=pm_type_combine(context,a(2+j),pm_tv_arg(tv2,i),elem_ok,elem_added) + if(elem_ok) then + added=added.or.elem_added + mask(j)=.true. + cycle outer + endif + endif + enddo + added=.true. + m=m+1 + a(m)=pm_tv_arg(tv2,i) + enddo outer + +!!$ write(*,*) 'combine poly',m,added +!!$ + ! Nothing added so just return + if(.not.added) then + typ=tno + return + endif + + ! Handle the merging of recursive poly types + recur=-1 + do i=3,m + if(iand(pm_type_flags(context,a(i)),& + pm_type_has_poly+pm_type_is_recursive)/=0) then + if(recur<0) then + recur=pm_type_new_recursive_ref(context) + endif + a(i)=pm_type_move_recursive(context,a(i),recur) + endif + enddo + + ! Create new type + typ=pm_new_type(context,a(1:m)) + if(recur>0) call pm_type_set_recursive_ref(context,recur,typ) + end subroutine combine_poly - ok=.false. - if(iand(pm_tv_flags(tv),pm_typ_has_embedded)/=0) then - if(top+2>maxstack) call pm_panic('Program too complex (nested embeds)') - top=top+2 - if(dir>0) then - start=1 - finish=pm_tv_numargs(tv) - else - start=pm_tv_numargs(tv) - finish=1 - endif - name=pm_name_val(context,pm_tv_name(tv)) - outer: do i=start,finish,dir - n=name%data%i(name%offset+i) - stack(top-1)=i+1 - stack(top)=n - if(n<0) then - if(pm_typ_includes(context,tno,pm_tv_arg(tv,i),& - pm_typ_incl_indirect,einfo)) then - ! Check that this element is not shadowed by name - do j=base+2,top-2,2 - if(stack(j)==n) cycle outer - enddo - tno_match=pm_tv_arg(tv,i) - ok=.true. - return - endif - endif - enddo outer - do i=start,finish,dir - n=name%data%i(name%offset+i) - stack(top-1)=i+1 - stack(top)=n - if(n<0) then - if(test_indirect_include(context,dir,tno,pm_tv_arg(tv,i),stack,& - maxstack,base,top,einfo,tno_match)) then - ok=.true. - return - endif - endif - enddo - top=top-2 - endif - end function test_indirect_include + end function pm_type_combine - ! Concrete only version of a type (used/usable only for returns from builtin functions) - recursive function pm_typ_as_concrete(context,tno,params,isstatic,iserr) result(tno2) + !============================================= + ! Create new (incomplete) recursive reference + !============================================= + function pm_type_new_recursive_ref(context) result(tno) type(pm_context),pointer:: context - integer,intent(in):: tno - integer,dimension(:),intent(in):: params - logical,intent(out):: isstatic - logical,intent(out),optional:: iserr - integer:: tno2 + integer:: tno + integer,dimension(2):: arr + arr(1)=pm_type_is_user+pm_type_is_recursive + arr(2)=-pm_dict_size(context,context%tcache) + tno=pm_new_basic_type(context,arr,& + val=pm_fast_typeno(context,0)) + contains + include 'ftypeno.inc' + end function pm_type_new_recursive_ref + + !============================================== + ! Make recursive reference point to given type + !============================================== + subroutine pm_type_set_recursive_ref(context,typ,tno) + type(pm_context),pointer:: context + integer,intent(in):: typ,tno +!!$ write(*,*) 'Set recursive',typ,tno + call pm_type_set_val(context,typ,& + pm_fast_typeno(context,tno)) + contains + include 'ftypeno.inc' + end subroutine pm_type_set_recursive_ref + + !================================================================ + ! Create a new type with with all fix values converted + ! to base type and mode changed to new_mode + !================================================================ + recursive function pm_type_move_recursive(context,tno,recur) result(typ) + type(pm_context),pointer:: context + integer,intent(in):: tno,recur + integer:: typ type(pm_ptr):: tv - integer:: tk,nt - isstatic=.true. - if(present(iserr)) iserr=.false. - tv=pm_typ_vect(context,tno) + integer:: tk + typ=tno + if(tno<=0) return + tv=pm_type_vect(context,tno) + if(iand(pm_tv_flags(tv),pm_type_is_recursive)==0) return tk=pm_tv_kind(tv) select case(tk) - case(pm_typ_is_basic,pm_typ_is_single_name,& - pm_typ_is_proc,pm_typ_is_value,pm_typ_is_const,& - pm_typ_is_undef_result,pm_typ_is_poly) - tno2=tno - case(pm_typ_is_user) - tno2=pm_user_typ_body(context,tno) - case(pm_typ_is_any,pm_typ_is_all,pm_typ_is_contains) - if(present(iserr)) then - iserr=.true. - isstatic=.true. - else - call pm_panic('cant make concrete') - endif - case default + case(pm_type_is_par_kind) + typ=pm_type_add_mode(context,& + pm_type_move_recursive(context,pm_tv_arg(tv,1),recur),pm_tv_name(tv)) + case(pm_type_is_user) + typ=recur + case(pm_type_is_rec,pm_type_is_array,pm_type_is_tuple,pm_type_is_vtuple) call remake(pm_tv_numargs(tv)) end select contains - subroutine remake(n) + recursive subroutine remake(n) integer,intent(in):: n integer,dimension(n+2):: a integer:: i - a(1)=tk + a(1)=pm_tv_flags(tv) a(2)=pm_tv_name(tv) - if(present(iserr)) then - do i=1,n - a(i+2)=pm_typ_as_concrete(context,pm_tv_arg(tv,i),params,isstatic,iserr) - if(iserr) return - enddo - else - do i=1,n - a(i+2)=pm_typ_as_concrete(context,pm_tv_arg(tv,i),params,isstatic) - enddo - endif - tno2=pm_new_typ(context,a) + do i=1,n + a(i+2)=pm_type_move_recursive(context,pm_tv_arg(tv,i),recur) + enddo + typ=pm_new_type(context,a) end subroutine remake - end function pm_typ_as_concrete + end function pm_type_move_recursive + - recursive function pm_typ_remove_params(context,tno,params) result(tno2) + !================================================================ + ! Create a new type with with all fix values converted + ! to base type and mode changed to new_mode + !================================================================ + recursive function pm_type_identify_recursive(context,tno,etyp,recur) result(typ) type(pm_context),pointer:: context - integer,intent(in):: tno - integer,dimension(:),intent(in):: params - integer:: tno2 + integer,intent(in):: tno,etyp + integer,intent(inout):: recur + integer:: typ type(pm_ptr):: tv - integer:: tk,argnum - tv=pm_typ_vect(context,tno) + integer:: tk + typ=tno + if(tno<=0) return + tv=pm_type_vect(context,tno) + if(iand(pm_tv_flags(tv),pm_type_has_poly)==0) return tk=pm_tv_kind(tv) - if(tk==pm_typ_is_user) then - tno2=pm_user_typ_body(context,tno) - elseif(tk==pm_typ_is_param) then - argnum=pm_tv_name(tv) - if(params(argnum)>=0) then - tno2=params(argnum) - else - tno2=pm_tv_arg(tv,1) - endif - elseif(iand(pm_tv_flags(tv),pm_typ_has_params)/=0) then + select case(tk) + case(pm_type_is_par_kind) + typ=pm_type_add_mode(context,& + pm_type_identify_recursive(context,pm_tv_arg(tv,1),etyp,recur),pm_tv_name(tv)) + case(pm_type_is_rec,pm_type_is_array,pm_type_is_tuple,pm_type_is_vtuple) call remake(pm_tv_numargs(tv)) - else - tno2=tno - endif + case(pm_type_is_poly) + if(pm_tv_name(tv)==etyp) then + if(recur<0) then + recur=pm_type_new_recursive_ref(context) + endif + typ=recur +!!$ write(*,*) 'Made recur',typ + endif + end select contains - subroutine remake(n) + recursive subroutine remake(n) integer,intent(in):: n integer,dimension(n+2):: a integer:: i - a(1)=tk + a(1)=pm_tv_flags(tv) a(2)=pm_tv_name(tv) do i=1,n - a(i+2)=pm_typ_remove_params(context,pm_tv_arg(tv,i),params) + a(i+2)=pm_type_identify_recursive(context,pm_tv_arg(tv,i),etyp,recur) enddo - tno2=pm_new_typ(context,a) + typ=pm_new_type(context,a) +!!$ write(*,*) 'remade to',typ,a end subroutine remake - end function pm_typ_remove_params + end function pm_type_identify_recursive + !================================================================ + ! Strip all poly types in a given types down to just the constaint + ! with no membership information + !================================================================ + recursive function pm_type_strip_poly(context,tno) result(typ) + type(pm_context),pointer:: context + integer,intent(in):: tno + integer:: typ + type(pm_ptr):: tv + integer:: tk,arr(2) + typ=tno + if(tno<=0) return + tv=pm_type_vect(context,tno) + if(iand(pm_tv_flags(tv),pm_type_has_poly)==0) return + tk=pm_tv_kind(tv) + select case(tk) + case(pm_type_is_par_kind) + typ=pm_type_add_mode(context,& + pm_type_strip_poly(context,pm_tv_arg(tv,1)),pm_tv_name(tv)) + case(pm_type_is_user) + typ=pm_user_type_body(context,tno) + case(pm_type_is_rec,pm_type_is_array,pm_type_is_tuple,pm_type_is_vtuple) + call remake(pm_tv_numargs(tv)) + case(pm_type_is_poly) + arr(1)=pm_type_new_poly + arr(2)=pm_tv_name(tv) + typ=pm_new_type(context,arr) + end select + contains + recursive subroutine remake(n) + integer,intent(in):: n + integer,dimension(n+2):: a + integer:: i + a(1)=pm_tv_flags(tv) + a(2)=pm_tv_name(tv) + do i=1,n + a(i+2)=pm_type_strip_poly(context,pm_tv_arg(tv,i)) + enddo + typ=pm_new_type(context,a) + end subroutine remake + end function pm_type_strip_poly - ! Get vector of integer representation of type - function pm_typ_vect(context,tno) result(typ) + !================================================================ + ! Get vector-of-integer representation of type + !================================================================ + function pm_type_vect(context,tno) result(typ) type(pm_context),pointer:: context integer,intent(in):: tno type(pm_ptr):: typ,dict @@ -2658,34 +3155,42 @@ function pm_typ_vect(context,tno) result(typ) if(pm_debug_level>0) then if(t<1.or.t>pm_dict_size(context,dict)) then write(*,*) 'tno=',t,tno,pm_dict_size(context,dict) - call pm_panic('pm_typ_vect') + call pm_panic('pm_type_vect') endif endif typ=pm_dict_key(context,dict,t) - end function pm_typ_vect + end function pm_type_vect + !================================================================ ! Type kind from integer type vector + !================================================================ function pm_tv_kind(typ) result(k) type(pm_ptr),intent(in):: typ integer:: k - k=iand(typ%data%i(typ%offset),pm_typ_kind_mask) + k=iand(typ%data%i(typ%offset),pm_type_kind_mask) end function pm_tv_kind - ! Type kind from integer type vector + !================================================================ + ! Type flags from integer type vector + !================================================================ function pm_tv_flags(typ) result(k) type(pm_ptr),intent(in):: typ integer:: k k=typ%data%i(typ%offset) end function pm_tv_flags - ! Name from integer type vector + !================================================================ + ! Type name field from integer type vector + !================================================================ function pm_tv_name(typ) result(name) type(pm_ptr),intent(in):: typ integer:: name name=typ%data%i(typ%offset+1_pm_p) end function pm_tv_name - ! Argument m from integer type vector + !================================================================ + ! Type argument m from integer type vector + !================================================================ function pm_tv_arg(typ,m) result(arg) type(pm_ptr),intent(in):: typ integer,intent(in):: m @@ -2697,8 +3202,10 @@ function pm_tv_arg(typ,m) result(arg) endif arg=typ%data%i(typ%offset+m+1) end function pm_tv_arg - - ! Number of arguments in integer type vector + + !================================================================ + ! Number of type arguments from integer type vector + !================================================================ function pm_tv_numargs(typ) result(num) type(pm_ptr),intent(in):: typ integer:: num @@ -2707,28 +3214,31 @@ function pm_tv_numargs(typ) result(num) include 'fesize.inc' end function pm_tv_numargs + !================================================================ ! Display type as user-readable string - function pm_typ_as_string(context,tno,distr) result(str) + !================================================================ + function pm_type_as_string(context,tno) result(str) type(pm_context),pointer:: context integer,intent(in):: tno - logical,intent(in),optional:: distr - character(len=256):: str + character(len=2048):: str integer:: n str='' if(tno==0) then str='any' else n=1 - call typ_to_str(context,tno,str,n,tuple=.false.,distr=distr) + call pm_type_to_string(context,tno,str,n) endif - end function pm_typ_as_string + end function pm_type_as_string - recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) + recursive subroutine pm_type_to_string(context,typno,str,n,infix,noequiv,tuple_start) type(pm_context),pointer:: context integer,intent(in):: typno - character(len=256),intent(inout):: str + character(len=1024),intent(inout):: str integer,intent(inout):: n - logical,intent(in),optional:: distr,tuple,noequiv + !logical,intent(in),optional:: distr,tuple,noequiv + logical,intent(in),optional:: noequiv,infix + integer,intent(in),optional:: tuple_start type(pm_ptr):: tv,tv2,nv,nv2 integer:: tk,narg,tno2 integer:: name,name2 @@ -2738,68 +3248,63 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) character(len=1),parameter:: close_square = ']' integer:: i,j,istart,tno,tk2 type(pm_ptr):: amps - logical:: ok + logical:: ok,isfix if(n>len(str)-10) return tno=typno +!!$ if(add_char('{'//trim(pm_int_as_string(tno))//'}')) return if(tno==0) then if(add_char('any')) return return endif if(tno<0) then - if(add_char('*Internal error(<0)*')) return + if(add_char('*Internal-error(<0)*')) return return endif if(tno>pm_dict_size(context,context%heap%tcache)) then - if(add_char('*Internal error(>size)*')) return + if(add_char('*Internal-error(>size)*')) return return endif - tv=pm_typ_vect(context,tno) + tv=pm_type_vect(context,tno) tk=pm_tv_kind(tv) nv=pm_dict_val(context,context%tcache,int(tno,pm_ln)) narg=pm_tv_numargs(tv) select case(tk) - case(pm_typ_is_user,pm_typ_is_basic) + case(pm_type_is_user,pm_type_is_basic,pm_type_is_category) name=pm_tv_name(tv) if(name<0) then - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + if(iand(pm_tv_flags(tv),pm_type_is_recursive)/=0) then + if(add_char('{RECURSE}')) return + return + endif + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) return endif name=pm_name_stem(context,name) if(name>=sym_dim1.and.name<=sym_dim7.and.narg==name-sym_dim1+1) then - if(present(distr)) then - if(.not.distr) return - endif - if(present(tuple)) then - tno2=pm_tv_arg(tv,1) - ok=.true. - do i=2,narg - ok=ok.and.pm_tv_arg(tv,i)==tno2 - enddo - else - ok=.false. - endif - if(ok) then - call pm_name_string(context,name,str(n:)) - n=len_trim(str)+1 - if(narg==1) then - if(add_char('(')) return - else - if(add_char('_of(')) return - endif - call typ_to_str(context,pm_tv_arg(tv,1),str,n) - if(add_char(')')) return - else - if(add_char('[')) return - do i=1,narg-1 - call typ_to_str(context,pm_tv_arg(tv,i),str,n) - if(add_char(',')) return - enddo - call typ_to_str(context,pm_tv_arg(tv,narg),str,n) - if(add_char(']')) return + isfix=pm_type_includes(context,& + pm_user_type_lookup_by_name(context,sym_pm_system,sym_fix_tuple),& + tno,pm_type_incl_type) + if(isfix) then + if(add_char('fix')) return endif + if(add_char('[')) return + do i=1,narg-1 + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,isfix) + if(add_char(',')) return + enddo + call pm_type_to_string(context,pm_tv_arg(tv,narg),str,n,isfix) + if(add_char(']')) return elseif(name==sym_pm_ref_type) then - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) else + if(name==sym_range.and.narg==2) then + if(pm_tv_arg(tv,1)/=pm_tv_arg(tv,2)) then + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) + if(add_char('..')) return + call pm_type_to_string(context,pm_tv_arg(tv,2),str,n,infix) + return + endif + endif call pm_name_string(context,name,str(n:)) n=len_trim(str)+1 if(n>len(str)-10) return @@ -2807,20 +3312,20 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) if(narg>0) then if(add_char('(')) return do i=1,narg-1 - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,infix) if(add_char(',')) return enddo - call typ_to_str(context,pm_tv_arg(tv,narg),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,narg),str,n,infix) if(add_char(')')) return endif - if(tk==pm_typ_is_user.and.(pm_opts%show_members)) then + if(tk==pm_type_is_user.and.(pm_opts%show_members)) then nv2=pm_dict_val(context,context%tcache,int(tno,pm_ln)) tno2=int(nv2%offset) if(tno2>0.and.tno20.and..not.present(noequiv)) then if(show_equiv(int(name),tno2,tno)) return endif - if(tk==pm_typ_is_struct) then - if(add_char('struct ')) return - else - if(add_char('rec ')) return - endif + if(add_char('rec ')) return call pm_name_string(context,name,str(n:)) n=len_trim(str)+1 if(n>len(str)-10) return @@ -2881,7 +3394,7 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) do i=1,narg name=nv%data%i(nv%offset+i) if(name<0) then - if(add_char('use ')) return + if(add_char('var ')) return name=-name endif nv2=pm_name_val(context,name) @@ -2895,23 +3408,13 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) n=len_trim(str)+1 if(n>len(str)-10) return if(add_char(':')) return - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,infix) if(ilen(str)-10) return - if(iand(pm_tv_flags(tv),pm_typ_has_distributed)/=0) then - if(add_char('*distr*')) return + if(pm_opts%show_details) then + if(iand(pm_tv_flags(tv),pm_type_has_distributed)/=0) then + if(add_char('*distr*')) return + endif endif - case(pm_typ_is_dref) + case(pm_type_is_dref) if(pm_opts%show_all_ref) then if(pm_tv_name(tv)==pm_dref_is_dot) then if(add_char('^.(')) return @@ -2951,35 +3456,59 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) if(add_char('(')) return endif do i=1,pm_tv_numargs(tv)-1 - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,infix) if(add_char(',')) return enddo - call typ_to_str(context,pm_tv_arg(tv,pm_tv_numargs(tv)),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,pm_tv_numargs(tv)),str,n,infix) if(add_char(')')) return else - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) endif - case(pm_typ_is_array) + case(pm_type_is_array) name=pm_tv_name(tv) if(name==sym_var) then if(add_char('varray(')) return elseif(name==sym_const) then if(add_char('farray(')) return - else + elseif(name==0) then if(add_char('array(')) return + else + if(add_char('array'//trim(pm_int_as_string(name))//'(')) return endif - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) if(add_char(',')) return - call typ_to_str(context,pm_tv_arg(tv,2),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,2),str,n,infix) if(add_char(')')) return - case(pm_typ_is_poly) + case(pm_type_is_poly) if(add_char('*')) return - call bracket(1,pm_typ_is_includes,pm_typ_is_all,pm_typ_is_any,pm_typ_is_except) - case(pm_typ_is_value) - if(add_char('''')) return + call bracket(0,pm_type_is_includes,pm_type_is_all,pm_type_is_any,pm_type_is_except) + if(pm_opts%show_details) then + if(add_char('{')) return + do i=1,pm_tv_numargs(tv) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,infix) + if(i0) then if(add_char('$')) return @@ -3041,15 +3583,15 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) if(pm_opts%show_variants) then if(add_char(' -- {')) return do i=1,pm_tv_numargs(tv)-1 - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,infix) if(add_char(',')) return enddo - call typ_to_str(context,pm_tv_arg(tv,pm_tv_numargs(tv)),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,pm_tv_numargs(tv)),str,n,infix) if(add_char('}')) return endif elseif(name==0) then if(add_char('proc')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) else if(add_char('proc ')) return nv2=pm_name_val(context,-name) @@ -3062,54 +3604,125 @@ recursive subroutine typ_to_str(context,typno,str,n,distr,tuple,noequiv) endif n=len_trim(str)+1 if(n>len(str)-10) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) endif - case(pm_typ_is_proc_sig) + case(pm_type_is_proc_sig) name=pm_tv_name(tv) if(name/=sym_proc) then if(add_char(trim(pm_name_as_string(context,name)))) return + istart=7 + else + istart=2 + endif + if(pm_opts%show_hidden) then + istart=1 + elseif(pm_opts%show_details) then + do i=1,istart + if(pm_type_arg(context,pm_tv_arg(tv,1),i)/=0) then + if(add_char('^')) return + istart=1 + exit + endif + enddo endif - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,tuple_start=istart) if(add_char('->')) return - call typ_to_str(context,pm_tv_arg(tv,2),str,n) - case(pm_typ_is_undef_result) + call pm_type_to_string(context,pm_tv_arg(tv,2),str,n,infix) + if(iand(pm_tv_flags(tv),pm_type_is_yield)/=0) then + if(add_char('yield(')) return + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) + if(add_char(')')) return + endif + case(pm_type_is_undef_result) name=pm_tv_name(tv) if(add_char('(')) return - do i=1,name-1 - if(add_char('_,')) return - enddo - if(add_char('_')) return - if(add_char(')')) return - case(pm_typ_is_amp) - if(add_char('&')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) - case(pm_typ_is_vect) - if(add_char('^^(')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) + if(name>0) then + do i=1,name-1 + if(add_char('_,')) return + enddo + if(add_char('_')) return + endif if(add_char(')')) return - case(pm_typ_is_par_kind) + case(pm_type_is_vect) + if(pm_opts%show_details) then + if(add_char('^^(')) return + endif + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) + if(pm_opts%show_details) then + if(add_char(')')) return + endif + case(pm_type_is_par_kind) name=pm_tv_name(tv) if(add_char(trim(sym_names(name)))) return if(add_char(' ')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n) - case(pm_typ_is_param,pm_typ_is_params) - if(add_char('$')) return - call typ_to_str(context,pm_tv_arg(tv,1),str,n,noequiv=.true.) - case(pm_typ_is_type) + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) + case(pm_type_is_params) + if(pm_opts%show_details) then + if(add_char('[[=')) return + if(add_char(trim(pm_int_as_string(pm_tv_name(tv))))) return + if(add_char('::')) return + endif + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,noequiv=.true.) + if(pm_opts%show_details) then + if(add_char('=]]')) return + endif + case(pm_type_is_param) + if(pm_opts%show_details) then + if(add_char('<<')) return + if(add_char(trim(pm_int_as_string(pm_tv_name(tv))))) return + if(add_char('--')) return + endif + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,noequiv=.true.) + if(pm_opts%show_details) then + if(add_char('>>')) return + endif + case(pm_type_is_gated) + if(pm_opts%show_details) then + if(add_char('{')) return + if(.not.test_gated_type(context,tno)) then + if(add_char('~')) return + endif + call pm_type_to_string(context,pm_tv_arg(tv,pm_tv_numargs(tv)),str,n,noequiv=.true.) + if(add_char(':')) return + do i=1,pm_tv_numargs(tv)-2,2 + if(no_intersect(pm_tv_arg(tv,i),pm_tv_arg(tv,i+1))) then + if(add_char('~')) return + endif + call pm_type_to_string(context,pm_tv_arg(tv,i),str,n,noequiv=.true.) + if(add_char('^')) return + call pm_type_to_string(context,pm_tv_arg(tv,i+1),str,n,noequiv=.true.) + if(i')) return - case(pm_typ_is_bottom) + case(pm_type_is_uninitialised) + if(pm_opts%show_details) then + if(add_char('UNINIT:')) return + endif + call pm_type_to_string(context,pm_tv_arg(tv,1),str,n,infix) + case(pm_type_is_bottom) if(add_char(' _ ')) return case default - if(add_char('?')) return - write(str(n:n+3),'(i4)') tk - n=len_trim(str)+1 + if(add_char('*Internal-error(kind='//& + trim(pm_int_as_string(tk))//')*')) return end select contains include 'fvkind.inc' include 'fisnull.inc' include 'ftiny.inc' + include 'fesize.inc' function add_char(c) result(term) character(len=*),intent(in):: c @@ -3133,219 +3746,111 @@ end function add_char ! is equal to one of tk1..tk4 subroutine bracket(i,tk1,tk2,tk3,tk4) integer,intent(in):: i,tk1,tk2,tk3,tk4 - integer:: tk - tk=pm_typ_kind(context,pm_tv_arg(tv,i)) + integer:: tno,tk + if(i==0) then + tno=pm_tv_name(tv) + else + tno=pm_tv_arg(tv,i) + endif + tk=pm_type_kind(context,tno) if(tk==tk1.or.tk==tk2.or.tk==tk3.or.tk==tk4) then if(add_char('(')) return - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,tno,str,n,infix) if(add_char(')')) return else - call typ_to_str(context,pm_tv_arg(tv,i),str,n) + call pm_type_to_string(context,tno,str,n,infix) endif end subroutine bracket function show_equiv(name,templ,typ) result(ok) integer,intent(in):: name,templ,typ logical:: ok - integer,dimension(pm_max_typ_args):: params + integer,dimension(pm_max_type_args):: params integer:: i,m,name2 logical:: tuple params=-1 - ok=pm_typ_extract_params(context,templ,typ,params) + +!!$ if(add_char('<%')) return +!!$ call pm_type_to_string(context,templ,str,n,infix) +!!$ if(add_char('%>')) return +!!$ +!!$ ok=.false. +!!$ return + + ok=pm_type_extract_params(context,templ,typ,params) if(ok) then m=0 - do i=1,pm_max_typ_args + do i=1,pm_max_type_args if(params(i)>0) m=i enddo name2=pm_name_stem(context,name) tuple=name2>=sym_dim1.and.name2<=sym_dim7 - if(.not.tuple) then - call pm_name_string(context,name,str(n:)) - endif - n=len_trim(str)+1 - if(n>len(str)-10) return - if(m>0) then - if(add_char(merge('[','(',tuple))) return - do i=1,m - if(params(i)>0) then - call typ_to_str(context,params(i),str,n) - endif - if(ilen(str)-10) return + if(m>0) then + isfix=tuple.and.iand(pm_tv_flags(tv),& + pm_type_has_storage+pm_type_has_fix)==pm_type_has_fix + if(isfix) isfix=pm_type_includes(context,& + pm_user_type_lookup_by_name(context,sym_pm_system,sym_fix_tuple),& + tno,pm_type_incl_val) + if(isfix) then + if(add_char('fix')) return + endif + if(add_char(merge('[','(',tuple))) return + if(tuple) m=m-1 + do i=1,m + if(params(i)>0) then + call pm_type_to_string(context,params(i),str,n,isfix) + endif + if(i0) then + v%data%ptr(v%offset+2:v%offset+i+1)=& + arg(3)%data%ptr(arg(3)%offset+2:arg(3)%offset+i+1) + endif + v%data%ptr(v%offset+i+2:v%offset+i+jj)=& + arg(4)%data%ptr(arg(4)%offset+2:arg(4)%offset+jj) + if(i=0) then newve=pm_assign_new(context,newve,1_pm_ln,pm_long,n+4_pm_ln,.false.) newve%data%ln(newve%offset)=m @@ -10424,7 +10489,7 @@ function pm_arglist_type(context,tkind,tname,args,nargs) result(tno) t(2)=tname do i=1,nargs tno=pm_fast_typeof(args(i)) - if(tno>=pm_struct_type.and.tno<=pm_array_type) then + if(tno>=pm_rec_type.and.tno<=pm_array_type) then tno=args(i)%data%ptr(args(i)%offset+1_pm_p)%offset endif t(i+2)=tno @@ -10443,7 +10508,7 @@ function pm_arg_type(arg) result(tno) type(pm_ptr),intent(in):: arg integer(pm_i16):: tno tno=pm_fast_typeof(arg) - if(tno>=pm_struct_type.and.tno<=pm_elemref_type) then + if(tno>=pm_rec_type.and.tno<=pm_elemref_type) then tno=arg%data%ptr(arg%offset+1_pm_p)%offset endif contains @@ -10462,7 +10527,7 @@ subroutine runtime_error(context,func,pc,ve,noexit,errmesg) call mesg_q_flush() endif if(pm_opts%colour) then - call mesg_q_mess(pm_error_start//'Runtime error: '//pm_error_end//trim(errmesg)) + call mesg_q_mess(pm_opts%error_start//'Runtime error: '//pm_error_end//trim(errmesg)) else call mesg_q_mess('Runtime error: '//trim(errmesg)) endif diff --git a/src/vmdefs.f90 b/src/vmdefs.f90 index 89cec67..714635a 100644 --- a/src/vmdefs.f90 +++ b/src/vmdefs.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2020 +! Copyright (c) Tim Bellerby, 2024 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -35,7 +35,7 @@ module pm_vmdefs integer,parameter:: pm_max_stack=2**14-1 - integer,parameter:: pm_ext_mult=2**15/(pm_max_stack+1) + integer,parameter:: pm_ext_mult=2**15/(pm_max_args+1) integer,parameter:: pm_jump_offset=pm_ext_mult*2**14 integer,parameter:: op_call=0 @@ -109,8 +109,10 @@ module pm_vmdefs integer,parameter:: op_check_logical = op_misc + 25 integer,parameter:: op_chan_array_elem = op_misc + 26 integer,parameter:: op_chan_array_vect = op_misc + 27 + integer,parameter:: op_list_concat = op_misc + 28 + integer,parameter:: op_list_splice = op_misc + 29 - integer,parameter:: op_misc2=op_chan_array_vect + integer,parameter:: op_misc2=op_list_splice integer,parameter:: op_array_get_elem = op_misc2 + 1 integer,parameter:: op_array_set_elem = op_misc2 + 2 @@ -123,7 +125,7 @@ module pm_vmdefs integer,parameter:: op_iota = op_misc2 + 9 integer,parameter:: op_indices = op_misc2 + 10 integer,parameter:: op_get_key = op_misc2 + 11 - integer,parameter:: op_get_key2 = op_misc2 + 12 + integer,parameter:: op_present = op_misc2 + 12 integer,parameter:: op_export_array = op_misc2 + 13 integer,parameter:: op_miss_arg = op_misc2 + 14 integer,parameter:: op_default = op_misc2 + 15 @@ -135,8 +137,9 @@ module pm_vmdefs integer,parameter:: op_redim = op_misc2 + 21 integer,parameter:: op_wshare = op_misc2 + 22 integer,parameter:: op_block_cyclic = op_misc2 + 23 + integer,parameter:: op_array_set_multi_elem = op_misc2 + 24 - integer,parameter:: op_misc3 = op_block_cyclic + integer,parameter:: op_misc3 = op_array_set_multi_elem integer,parameter:: op_get_esize = op_misc3 + 1 integer,parameter:: op_pack = op_misc3 + 2 @@ -240,7 +243,8 @@ module pm_vmdefs integer,parameter:: op_nullify = first_assign_op + 6 integer,parameter:: op_assign = first_assign_op + 7 integer,parameter:: op_fill = first_assign_op + 8 - integer,parameter:: last_assign_op = first_assign_op+8 + integer,parameter:: op_number = first_assign_op + 9 + integer,parameter:: last_assign_op = first_assign_op+9 integer,parameter:: op_eq = last_assign_op +1 integer,parameter:: op_ne = last_assign_op +2 @@ -287,7 +291,8 @@ module pm_vmdefs integer,parameter:: op_i32_i = op_start_i+33 integer,parameter:: op_i64_i = op_start_i+34 integer,parameter:: op_offset_i = op_start_i+35 - integer,parameter:: op_stop_i = op_start_i+35 + integer,parameter:: op_fmt_i = op_start_i+36 + integer,parameter:: op_stop_i = op_start_i+36 integer,parameter:: op_start_ln=op_stop_i integer,parameter:: op_add_ln=op_start_ln+1 @@ -323,7 +328,8 @@ module pm_vmdefs integer,parameter:: op_i32_ln = op_start_ln+33 integer,parameter:: op_i64_ln = op_start_ln+34 integer,parameter:: op_offset_ln = op_start_ln + 35 - integer,parameter:: op_stop_ln = op_start_ln+35 + integer,parameter:: op_fmt_ln = op_start_ln + 36 + integer,parameter:: op_stop_ln = op_start_ln+36 integer,parameter:: op_start_offset=op_stop_ln integer,parameter:: op_add_offset=op_start_offset+1 @@ -359,7 +365,8 @@ module pm_vmdefs integer,parameter:: op_i32_offset = op_start_offset+33 integer,parameter:: op_i64_offset = op_start_offset+34 integer,parameter:: op_long_offset = op_start_offset+35 - integer,parameter:: op_stop_offset = op_start_offset+35 + integer,parameter:: op_fmt_offset = op_start_offset+36 + integer,parameter:: op_stop_offset = op_start_offset+36 integer,parameter:: op_start_i8=op_stop_offset integer,parameter:: op_add_i8=op_start_i8+1 @@ -503,7 +510,8 @@ module pm_vmdefs integer,parameter:: op_i32_i64 = op_start_i64+33 integer,parameter:: op_long_i64 = op_start_i64+34 integer,parameter:: op_offset_i64 = op_start_i64+35 - integer,parameter:: op_stop_i64 = op_start_i64+35 + integer,parameter:: op_fmt_i64 = op_start_i64+36 + integer,parameter:: op_stop_i64 = op_start_i64+36 integer,parameter:: op_start_r =op_stop_i64 integer,parameter:: op_add_r=op_start_r+1 @@ -550,7 +558,9 @@ module pm_vmdefs integer,parameter:: op_r64_r = op_start_r+44 integer,parameter:: op_complex_r = op_start_r+45 integer,parameter:: op_complex2_r = op_start_r+46 - integer,parameter:: op_stop_r = op_start_r+46 + integer,parameter:: op_fmt_r = op_start_r+47 + integer,parameter:: op_fmt_dp_r = op_start_r+48 + integer,parameter:: op_stop_r = op_start_r+48 integer,parameter:: op_start_d =op_stop_r integer,parameter:: op_add_d=op_start_d+1 @@ -597,7 +607,9 @@ module pm_vmdefs integer,parameter:: op_r64_d= op_start_d+44 integer,parameter:: op_complex_d = op_start_d+45 integer,parameter:: op_complex2_d = op_start_d+46 - integer,parameter:: op_stop_d = op_start_d+46 + integer,parameter:: op_fmt_d = op_start_d+47 + integer,parameter:: op_fmt_dp_d = op_start_d+48 + integer,parameter:: op_stop_d = op_start_d+48 integer,parameter:: op_start_c =op_stop_d integer,parameter:: op_add_c=op_start_c+1 @@ -693,6 +705,44 @@ module pm_vmdefs integer,parameter:: num_op=op_stop_comp + integer,parameter:: last_fold=-1 + integer,parameter:: op_add_fold=-1 + integer,parameter:: op_sub_fold=-2 + integer,parameter:: op_mult_fold=-3 + integer,parameter:: op_divide_fold=-4 + integer,parameter:: op_div_fold=-5 + integer,parameter:: op_mod_fold=-6 + integer,parameter:: op_pow_fold=-7 + integer,parameter:: op_uminus_fold=-8 + integer,parameter:: op_eq_fold=-9 + integer,parameter:: op_ne_fold=-10 + integer,parameter:: op_gt_fold=-11 + integer,parameter:: op_ge_fold=-12 + integer,parameter:: op_string_fold=-13 + integer,parameter:: op_max_fold = -14 + integer,parameter:: op_min_fold = -15 + integer,parameter:: op_abs_fold = -16 + integer,parameter:: op_band_fold = -17 + integer,parameter:: op_bor_fold = -18 + integer,parameter:: op_bxor_fold = -19 + integer,parameter:: op_bshift_fold = -20 + integer,parameter:: op_bnot_fold = -21 + integer,parameter:: op_pdiff_fold = -22 + integer,parameter:: op_sign_fold = -23 + integer,parameter:: op_modulo_fold = -24 + integer,parameter:: op_and_fold = -25 + integer,parameter:: op_or_fold = -26 + integer,parameter:: op_except_fold = -27 + integer,parameter:: op_concat_fold = -28 + integer,parameter:: op_num_elems_fold = -29 + integer,parameter:: op_type_include_fold = -30 + integer,parameter:: op_same_type_fold = -31 + integer,parameter:: op_same_rec_fold = -32 + integer,parameter:: first_fold=-32 + integer,parameter:: op_clone_var = -33 + integer,parameter:: op_error_type = -34 + integer,parameter:: min_op=op_error_type + integer,dimension(0:num_op):: op_flags integer,parameter:: op_is_call=1 integer,parameter:: op_is_jump=2 @@ -702,20 +752,24 @@ module pm_vmdefs integer,parameter:: op_2_blocks=32 integer,parameter:: op_prints_out=64 integer,parameter:: op_is_comm=128 - integer,parameter:: op_is_send=256 - integer,parameter:: op_is_recv=512 - integer,parameter:: op_is_sync_recv=1024 + integer,parameter:: op_is_send=256+op_is_comm + integer,parameter:: op_is_recv=512+op_is_comm + integer,parameter:: op_is_sync_recv=1024+op_is_comm integer,parameter:: op_is_arith=2048 integer,parameter:: op_is_file=4096 integer,parameter:: op_precedes_loop=8192 - integer,parameter:: op_is_sync=16384 + integer,parameter:: op_is_sync=16384+op_is_comm integer,parameter:: op_is_fixed=32768 - integer,parameter:: op_sets_cstack=65536 + integer,parameter:: op_sets_cstack=65536+op_is_comm + integer,parameter:: op_has_comm_block=131072+op_1_block + integer,parameter:: op_has_loop_block=262144+op_1_block + integer,parameter:: op_allocates=524288 integer,parameter:: op_is_gate_and_jump=op_is_gate+op_is_jump integer,parameter:: op_is_comm_1_block=op_is_comm+op_1_block integer,parameter:: op_is_jump_1_block=op_is_jump+op_1_block integer,parameter:: op_is_recv_1_block=op_is_sync_recv+op_1_block + integer,parameter:: op_allocates_and_takes_type=op_allocates+op_takes_type data op_flags(op_call) /op_is_call/ @@ -734,9 +788,9 @@ module pm_vmdefs data op_flags(op_skip_comms) /op_is_jump/ data op_flags(op_struct) /op_takes_type/ data op_flags(op_rec) /op_takes_type/ - data op_flags(op_array) /op_takes_type/ - data op_flags(op_array_noinit) /op_takes_type/ - data op_flags(op_var_array) /op_takes_type/ + data op_flags(op_array) /op_allocates_and_takes_type/ + data op_flags(op_array_noinit) /op_allocates_and_takes_type/ + data op_flags(op_var_array) /op_allocates_and_takes_type/ data op_flags(op_get_dom) /0/ data op_flags(op_elem) /0/ data op_flags(op_elem_ref) /0/ @@ -781,6 +835,8 @@ module pm_vmdefs data op_flags(op_extract_first) /0/ data op_flags(op_chan_array_elem) /0/ data op_flags(op_chan_array_vect) /0/ + data op_flags(op_list_concat) /0/ + data op_flags(op_list_splice) /0/ data op_flags(op_array_get_elem) /0/ data op_flags(op_array_set_elem) /0/ @@ -793,7 +849,7 @@ module pm_vmdefs data op_flags(op_iota) /0/ data op_flags(op_indices) /0/ data op_flags(op_get_key) /0/ - data op_flags(op_get_key2) /0/ + data op_flags(op_present) /0/ data op_flags(op_export_array) /0/ data op_flags(op_miss_arg) /0/ data op_flags(op_default) /0/ @@ -805,6 +861,7 @@ module pm_vmdefs data op_flags(op_redim) /0/ data op_flags(op_wshare) /0/ data op_flags(op_block_cyclic) /0/ + data op_flags(op_array_set_multi_elem) /0/ data op_flags(op_pack) /0/ data op_flags(op_dref) /0/ data op_flags(op_dref_elem) /0/ @@ -904,6 +961,7 @@ module pm_vmdefs data op_flags(op_nullify) /0/ data op_flags(op_assign) /0/ data op_flags(op_fill) /0/ + data op_flags(op_number) /0/ data op_flags(op_eq) /op_is_arith/ data op_flags(op_ne) /op_is_arith/ @@ -1016,6 +1074,7 @@ module pm_vmdefs data op_flags(op_i16_offset) /op_is_arith/ data op_flags(op_i32_offset) /op_is_arith/ data op_flags(op_i64_offset) /op_is_arith/ + data op_flags(op_long_offset) /op_is_arith/ data op_flags(op_add_i8) /op_is_arith/ data op_flags(op_sub_i8) /op_is_arith/ @@ -1310,11 +1369,11 @@ module pm_vmdefs data op_flags(op_if_shared) /op_2_blocks/ data op_flags(op_if_shared_node) /op_2_blocks/ data op_flags(op_if_restart) /op_2_blocks/ - data op_flags(op_loop) /op_1_block/ - data op_flags(op_comm_loop) /op_1_block/ - data op_flags(op_comm_block) /op_1_block/ - data op_flags(op_comm_proc) /op_1_block/ - data op_flags(op_comm_inline) /op_1_block/ + data op_flags(op_loop) /op_has_loop_block/ + data op_flags(op_comm_loop) /op_has_loop_block/ + data op_flags(op_comm_block) /op_has_comm_block/ + data op_flags(op_comm_proc) /op_has_comm_block/ + data op_flags(op_comm_inline) /op_has_comm_block/ data op_flags(op_allocate) /0/ data op_flags(op_deallocate) /0/ data op_flags(op_set_extent) /0/ ! Obsolete @@ -1322,7 +1381,7 @@ module pm_vmdefs data op_flags(op_nested_loop) /op_precedes_loop/ data op_flags(op_blocked_loop) /op_precedes_loop/ data op_flags(op_over) /op_1_block/ - data op_flags(op_comm_loop_par) /op_1_block/ + data op_flags(op_comm_loop_par) /op_has_loop_block/ data op_flags(op_inline_shared) /op_1_block/ data op_flags(op_assign_farray) /0/ data op_flags(op_init_farray) /0/ @@ -1392,6 +1451,7 @@ module pm_vmdefs integer,parameter:: v_is_array_par_vect=2048 integer,parameter:: v_is_array_par_dom=4096 integer,parameter:: v_is_farray=8192 + integer,parameter:: v_extra_flags=16384 ! Variable group types (compiling only) integer,parameter:: v_is_var_array=0 @@ -1402,6 +1462,12 @@ module pm_vmdefs integer,parameter:: v_is_storageless=5 integer,parameter:: v_is_tuple=6 + ! Variable access flags + integer,parameter:: acc_read=1 + integer,parameter:: acc_write=2 + integer,parameter:: acc_alloc=4 + integer,parameter:: acc_mult=8 + integer,parameter:: shared_op_flag=-32767 contains @@ -1409,7 +1475,7 @@ module pm_vmdefs subroutine set_op_names integer:: i if(allocated(op_names)) return - allocate(op_names(0:num_op+1)) + allocate(op_names(min_op:num_op+1)) op_names='??' op_names(op_call)='call' op_names(op_comm_call)='comm_call' @@ -1474,6 +1540,8 @@ subroutine set_op_names op_names(op_extract_first)='extract_first' op_names(op_chan_array_elem)='chan_array_elem' op_names(op_chan_array_vect)='chan_array_vect' + op_names(op_list_concat)='list_concat' + op_names(op_list_splice)='list_splice' op_names(op_array_get_elem)='array_get_elem' op_names(op_array_set_elem)='array_set_elem' @@ -1486,7 +1554,7 @@ subroutine set_op_names op_names(op_iota)='iota' op_names(op_indices)='indices' op_names(op_get_key)='get_key' - op_names(op_get_key2)='get_key2' + op_names(op_present)='present' op_names(op_export_array)='export_array' op_names(op_miss_arg)='miss_arg' op_names(op_default)='default' @@ -1498,6 +1566,7 @@ subroutine set_op_names op_names(op_redim)='redim' op_names(op_wshare)='wshare' op_names(op_block_cyclic)='block_cyclic' + op_names(op_array_set_multi_elem)='array_set_multi_elem' op_names(op_pack)='pack' op_names(op_dref)='dref' op_names(op_dref_elem)='dref_elem' @@ -1522,9 +1591,9 @@ subroutine set_op_names op_names(op_this_node)='this_node' op_names(op_this_nnode)='this_nnode' - op_names(op_shared_node)='shared_node' - op_names(op_shared_nnode)='shared_nnode' - op_names(op_is_shared)='is_shared' + op_names(op_shared_node)='shrd_node' + op_names(op_shared_nnode)='shrd_nnode' + op_names(op_is_shared)='is_shrd' op_names(op_is_par)='is_par' op_names(op_push_node_grid)='push_node_grid' op_names(op_push_node_split)='push_node_split' @@ -1538,8 +1607,8 @@ subroutine set_op_names op_names(op_push_node_back)='push_node_back' op_names(op_sys_node)='sys_node' op_names(op_sys_nnode)='sys_nnode' - op_names(op_this_node)='this_node' - op_names(op_this_nnode)='sys_nnode' +!!$ op_names(op_this_node)='this_node' +!!$ op_names(op_this_nnode)='sys_nnode' op_names(op_reduce_ve)='reduce_ve' op_names(op_start_loop_sync)='start_loop_sync' op_names(op_broadcast_val)='broadcast_val' @@ -1568,9 +1637,9 @@ subroutine set_op_names op_names(op_isend_reply)='isend_reply' op_names(op_do_at)='do_at' op_names(op_root_node)='root_node' - op_names(op_bcast_shared_offset)='bcast_shared_offset' - op_names(op_bcast_shared_grid)='bcast_shared_grid' - op_names(op_broadcast_shared)='broadcast_shared' + op_names(op_bcast_shared_offset)='bcast_shrd_offset' + op_names(op_bcast_shared_grid)='bcast_shrd_grid' + op_names(op_broadcast_shared)='broadcast_shrd' op_names(op_isend_grid)='isend_grid' op_names(op_irecv_grid)='irecv_grid' op_names(op_recv_grid)='recv_grid' @@ -1597,6 +1666,7 @@ subroutine set_op_names op_names(op_nullify)='nullify' op_names(op_assign)='assign' op_names(op_fill)='fill' + op_names(op_number)='number' op_names(op_eq)='eq' op_names(op_ne)='ne' @@ -1622,6 +1692,7 @@ subroutine set_op_names op_names(op_gt_i)='gt_i' op_names(op_ge_i)='ge_i' op_names(op_string_i)='string_i' + op_names(op_fmt_i)='fmt_i' op_names(op_max_i)='max_i' op_names(op_min_i)='min_i' op_names(op_assign_i)='assign_i' @@ -1656,6 +1727,7 @@ subroutine set_op_names op_names(op_gt_ln)='gt_ln' op_names(op_ge_ln)='ge_ln' op_names(op_string_ln)='string_ln' + op_names(op_fmt_ln)='fmt_ln' op_names(op_max_ln)='max_ln' op_names(op_min_ln)='min_ln' op_names(op_assign_ln)='assign_ln' @@ -1690,6 +1762,7 @@ subroutine set_op_names op_names(op_gt_offset)='gt_offset' op_names(op_ge_offset)='ge_offset' op_names(op_string_offset)='string_offset' + op_names(op_fmt_offset)='fmt_offset' op_names(op_max_offset)='max_offset' op_names(op_min_offset)='min_offset' op_names(op_assign_offset)='assign_offset' @@ -1709,6 +1782,7 @@ subroutine set_op_names op_names(op_i16_offset)='i16_offset' op_names(op_i32_offset)='i32_offset' op_names(op_i64_offset)='i64_offset' + op_names(op_long_offset)='long_offset' op_names(op_add_i8)='add_i8' op_names(op_sub_i8)='sub_i8' @@ -1845,8 +1919,9 @@ subroutine set_op_names op_names(op_i8_i64)='i8_i64' op_names(op_i16_i64)='i16_i64' op_names(op_i32_i64)='i32_i64' - op_names(op_offset_i8)='offset_i64' - op_names(op_long_i8)='long_i64' + op_names(op_offset_i64)='offset_i64' + op_names(op_long_i64)='long_i64' + op_names(op_fmt_i64)='fmt_i64' op_names(op_add_r)='add_r' op_names(op_sub_r)='sub_r' @@ -1861,6 +1936,8 @@ subroutine set_op_names op_names(op_gt_r)='gt_r' op_names(op_ge_r)='ge_r' op_names(op_string_r)='string_r' + op_names(op_fmt_r)='fmt_r' + op_names(op_fmt_dp_r)='fmt_dp_r' op_names(op_max_r)='max_r' op_names(op_min_r)='min_r' op_names(op_assign_r)='assign_r' @@ -1906,6 +1983,8 @@ subroutine set_op_names op_names(op_gt_d)='gt_d' op_names(op_ge_d)='ge_d' op_names(op_string_d)='string_d' + op_names(op_fmt_d)='fmt_d' + op_names(op_fmt_dp_d)='fmt_dp_d' op_names(op_max_d)='max_d' op_names(op_min_d)='min_d' op_names(op_assign_d)='assign_d' @@ -2001,8 +2080,8 @@ subroutine set_op_names op_names(op_do_loop)='do_loop' op_names(op_mask)='mask' op_names(op_if)='if' - op_names(op_if_shared)='if_shared' - op_names(op_if_shared_node)='if_shared_node' + op_names(op_if_shared)='if_shrd' + op_names(op_if_shared_node)='if_shrd_node' op_names(op_if_restart)='if_restart' op_names(op_loop)='loop' op_names(op_comm_loop)='comm_loop' @@ -2017,13 +2096,48 @@ subroutine set_op_names op_names(op_blocked_loop)='blocked_loop' op_names(op_over)='over' op_names(op_comm_loop_par)='comm_loop_par' - op_names(op_inline_shared)='inline_shared' + op_names(op_inline_shared)='inline_shrd' op_names(op_assign_farray)='assign_farray' op_names(op_init_farray)='init_farray' op_names(op_wrap)='wrap' op_names(op_sync)='sync' op_names(op_init_var)='init_var' + op_names(op_add_fold)='add_fold' + op_names(op_sub_fold)='sub_fold' + op_names(op_mult_fold)='mult_fold' + op_names(op_divide_fold)='divide_fold' + op_names(op_div_fold)='div_fold' + op_names(op_mod_fold)='mod_fold' + op_names(op_pow_fold)='pow_fold' + op_names(op_uminus_fold)='uminus_fold' + op_names(op_eq_fold)='eq_fold' + op_names(op_ne_fold)='ne_fold' + op_names(op_gt_fold)='gt_fold' + op_names(op_ge_fold)='ge_fold' + op_names(op_string_fold)='string_fold' + op_names(op_max_fold)='max_fold' + op_names(op_min_fold)='min_fold' + op_names(op_abs_fold)='abs_fold' + op_names(op_band_fold)='band_fold' + op_names(op_bor_fold)='bor_fold' + op_names(op_bxor_fold)='bxor_fold' + op_names(op_bshift_fold)='bshift_fold' + op_names(op_bnot_fold)='bnot_fold' + op_names(op_pdiff_fold)='pdiff_fold' + op_names(op_sign_fold)='sign_fold' + op_names(op_modulo_fold)='modulo_fold' + op_names(op_and_fold)='and_fold' + op_names(op_or_fold)='or_fold' + op_names(op_except_fold)='except_fold' + op_names(op_concat_fold)='concat_fold' + op_names(op_num_elems_fold)='num_elems_fold' + op_names(op_type_include_fold)='type_include_fold' + op_names(op_same_type_fold)='same_type_fold' + op_names(op_same_rec_fold)='same_rec_fold' + op_names(op_clone_var)='clone_var' + op_names(op_error_type)='error_type' + !!$ do i=op_call,op_comm_loop_par !!$ if(op_names(i)=='??')then !!$ write(*,*) 'MISSING OP NAME>>>>',i,'after',op_names(i-1) @@ -2040,6 +2154,7 @@ function proc_get_name(proc) result(name) name=p%data%i16(p%offset+2) end function proc_get_name + ! Return line and module of given wcode offset into proc subroutine proc_line_module(proc,offset,line,modl) type(pm_ptr),intent(in):: proc integer,intent(in):: offset @@ -2068,6 +2183,7 @@ subroutine proc_line_module(proc,offset,line,modl) include 'fesize.inc' end subroutine proc_line_module + ! Return name associated with given slot no. at given code offset function proc_slot_name(proc,offset,slot) result(name) type(pm_ptr):: proc integer:: offset,slot @@ -2103,6 +2219,43 @@ function proc_slot_name(proc,offset,slot) result(name) include 'fesize.inc' end function proc_slot_name + ! Return slot number associated with given name at given code offset + function proc_name_slot(proc,offset,name) result(slot) + type(pm_ptr):: proc + integer:: offset,name + integer:: slot + integer:: i,j,start,finish,n + type(pm_ptr):: p + integer:: k + name=0 + if(pm_is_compiling) return + p=proc%data%ptr(proc%offset+1) + j=p%offset+pm_fast_esize(p) + do + k=p%data%i16(j) + if(k/=0) then + j=j-2 + else + n=p%data%i16(j-1) + start=p%data%i16(j-2) + finish=p%data%i16(j-3) + j=j-n*2-4 + if(offset>=start.and.offset<=finish) then + do i=1,n + if(p%data%i16(j+i*2)==name) then + slot=p%data%i16(j+i*2) + exit + endif + enddo + endif + endif + if(j0) then + call print_comp_op_block(context,iunit,op,first_index,vars,dict,values,2,masked,wstack,vsets,oindex) + endif write(iunit,'(a)') '}' end subroutine print_comp_proc - subroutine print_comp_op(context,iunit,op,index,vars,dict,values,depth,masked) + subroutine print_comp_op(context,iunit,op,index,vars,dict,values,depth,masked,wstack,vsets,oindex) type(pm_context),pointer:: context integer,intent(in):: iunit - integer,dimension(*):: op,vars + integer,dimension(*),intent(in):: op,vars integer,intent(in):: index,depth type(pm_ptr),intent(in):: dict type(pm_ptr),dimension(*),intent(in):: values logical,intent(in):: masked + integer,dimension(:),optional,intent(in):: wstack + logical,intent(in),optional:: vsets + integer,dimension(:),intent(in),optional:: oindex character(len=wcode_file_cols):: line character(len=wcode_file_cols):: location - integer:: nargs,nret,opcode,opcode2,flags,last_arg,arg1,i,nblocks,j + integer:: nargs,nret,opcode,opcode2,flags,last_arg,arg1,i,nblocks,j,loc,vset,bset logical:: shared type(pm_ptr):: p opcode=op(comp_op_opcode+index) @@ -2175,10 +2336,22 @@ subroutine print_comp_op(context,iunit,op,index,vars,dict,values,depth,masked) nargs=iand(op(comp_op_nargs+index),comp_op_nargs_mask) nret=iand(op(comp_op_nargs+index),comp_op_nret_mask)/comp_op_nret_div shared=iand(op(comp_op_nargs+index),comp_op_shared)/=0 - location=trim(pm_name_as_string(context,iand(op(index+comp_op_line),modl_mult-1)))//& - ':'//pm_int_as_string(op(index+comp_op_line)/modl_mult) + loc=op(index+comp_op_line) + vset=-1 + if(present(vsets)) then + if(vsets) vset=loc + !write(*,*) '@@@@ loc=',loc,op_names(opcode) + loc=wstack(loc) + endif + bset=0 + if(loc<0) then + bset=loc + loc=wstack(size(wstack)+loc) + endif + location=trim(pm_name_as_string(context,iand(loc,modl_mult-1)))//& + ':'//pm_int_as_string(loc/modl_mult) -! write(*,*) 'NAME=',iand(op(index+comp_op_line),modl_mult-1) +! write(*,*) 'NAME=',iand(loc,modl_mult-1) !!$ write(*,*) 'op->',op_names(opcode),opcode,opcode2,op(index+comp_op_nargs),& !!$ (op(index+comp_op_arg0+i),i=1,nargs-1),'#',nret @@ -2230,18 +2403,23 @@ subroutine print_comp_op(context,iunit,op,index,vars,dict,values,depth,masked) line(len(line)-len_trim(location)+1:)=location write(iunit,'(a)') line if(nblocks>0) then + if(bset/=0) call print_bset(context,iunit,bset,wstack,vars,values,oindex,depth) call print_comp_op_block(context,iunit,op,op(index+comp_op_arg0+1),& - vars,dict,values,min(20,depth+2),masked) + vars,dict,values,min(20,depth+2),masked,wstack,vsets,oindex) if(nblocks>1) then write(iunit,'(a)') repeat(' ',depth)//'} --- {' + if(bset/=0) call print_bset(context,iunit,bset,wstack,vars,values,oindex,depth) call print_comp_op_block(context,iunit,op,op(index+comp_op_arg0+2),& - vars,dict,values,min(20,depth+2),masked) + vars,dict,values,min(20,depth+2),masked,wstack,vsets,oindex) endif write(iunit,'(a)') repeat(' ',depth)//'}' endif + if(present(vsets)) then + if(vsets) call print_vset(context,iunit,op(index+comp_op_line),wstack,vars,values,oindex,depth) + endif end subroutine print_comp_op - subroutine print_comp_op_block(context,iunit,op,index,vars,dict,values,depth,masked) + subroutine print_comp_op_block(context,iunit,op,index,vars,dict,values,depth,masked,wstack,vsets,oindex) type(pm_context),pointer:: context integer,intent(in):: iunit integer,dimension(*),intent(in):: op,vars @@ -2249,12 +2427,20 @@ subroutine print_comp_op_block(context,iunit,op,index,vars,dict,values,depth,mas type(pm_ptr),dimension(*),intent(in):: values integer,intent(in):: index,depth logical,intent(in):: masked + integer,dimension(:),optional,intent(in):: wstack + logical,intent(in),optional:: vsets + integer,dimension(:),intent(in),optional:: oindex integer::i !write(*,*) 'BLOCK>',index i=index - do while(i>0) - call print_comp_op(context,iunit,op,i,vars,dict,values,depth,masked) - i=op(i+comp_op_link) + do while(i/=0) + if(i>0) then + call print_comp_op(context,iunit,op,i,vars,dict,values,depth,masked,wstack,vsets,oindex) + i=op(i+comp_op_link) + else + call print_comp_op(context,iunit,wstack,i,vars,dict,values,depth,masked,wstack,vsets,oindex) + i=wstack(-i+comp_op_link) + endif enddo end subroutine print_comp_op_block @@ -2325,9 +2511,9 @@ recursive subroutine printv(index,addtype) call printv(v1,.true.) call append(')') tno2=var(v1+2)/cvar_flag_mult - tk=pm_typ_kind(context,tno2) - if(tk==pm_typ_is_struct.or.tk==pm_typ_is_rec) then - ename=abs(pm_typ_elem_name(context,tno2,v2)) + tk=pm_type_kind(context,tno2) + if(tk==pm_type_is_rec) then + ename=abs(pm_type_elem_name(context,tno2,v2)) if(ename>=sym_d1.and.ename<=sym_d7) then call append('.'//pm_int_as_string(v2)) else @@ -2367,9 +2553,9 @@ recursive subroutine printv(index,addtype) case(v_is_array) call group(index,v1,v2,'<','>',.false.) case(v_is_struct) - tk=pm_typ_kind(context,tno) - if(tk==pm_typ_is_struct.or.tk==pm_typ_is_rec) then - call group(index,v1,v2,trim(pm_name_as_string(context,pm_typ_elem_name(context,tno,0)))//& + tk=pm_type_kind(context,tno) + if(tk==pm_type_is_rec) then + call group(index,v1,v2,trim(pm_name_as_string(context,pm_type_elem_name(context,tno,0)))//& '{','}',.false.) else call group(index,v1,v2,'{','}',.true.) @@ -2392,7 +2578,7 @@ recursive subroutine printv(index,addtype) call append('???'//pm_int_as_string(kind)) end select if(addtype) then - call append(':'//pm_typ_as_string(context,tno)) + call append(':'//pm_type_as_string(context,tno)) endif end subroutine printv @@ -2440,13 +2626,85 @@ end subroutine append end subroutine print_cvar + subroutine print_vset(context,iunit,vset,wstack,var,values,oindex,depth) + type(pm_context),pointer:: context + integer,intent(in):: iunit,vset,depth + integer,dimension(:),intent(in):: wstack + integer,dimension(*),intent(in):: var + type(pm_ptr),dimension(*),intent(in):: values + integer,dimension(*):: oindex + character(len=wcode_file_cols):: line + integer:: i,j,n + !write(*,*) 'vset' + line=' ' + line(depth+1:depth+1)='[' + j=depth+3 + n=wstack(vset+2) + do i=1,n + call print_cvar(context,iunit,var,oindex(wstack(vset+i+2)/acc_mult),values,.false.,depth,line,j) + call print_acc(iunit,line,j,wstack(vset+i+2),depth) + call append_to(iunit,line,j,'('//trim(pm_int_as_string(wstack(vset+i+2)/acc_mult))//')',.false.,depth) + call append_to(iunit,line,j,' ',.false.,depth) + enddo + call append_to(iunit,line,j,']',.true.,depth) + end subroutine print_vset + + subroutine print_bset(context,iunit,bset,wstack,var,values,oindex,depth) + type(pm_context),pointer:: context + integer,intent(in):: iunit,bset,depth + integer,dimension(:),intent(in):: wstack + integer,dimension(*),intent(in):: var + type(pm_ptr),dimension(*),intent(in):: values + integer,dimension(*):: oindex + character(len=wcode_file_cols):: line + integer:: i,j,wmax + wmax=size(wstack) + line=' ' + line(depth+1:depth+1)='|' + j=depth+3 + i=wstack(wmax+bset+1) + do while(i/=0) + call print_cvar(context,iunit,var,oindex(wstack(wmax+i)/acc_mult),values,.false.,depth,line,j) + call print_acc(iunit,line,j,wstack(wmax+i),depth) + call append_to(iunit,line,j,'('//trim(pm_int_as_string(wstack(wmax+i)/acc_mult))//')',.false.,depth) + call append_to(iunit,line,j,' ',.false.,depth) + i=wstack(wmax+i+1) + enddo + call append_to(iunit,line,j,'|',.true.,depth) + end subroutine print_bset + + subroutine print_acc(iunit,str,i,acc,depth) + integer,intent(in):: iunit + character(len=*),intent(inout):: str + integer,intent(inout):: i + integer,intent(in):: acc + integer,intent(in):: depth + character(len=3):: part + integer:: j + part=':' + j=1 + if(iand(acc,acc_read)/=0) then + j=j+1 + part(j:j)='r' + endif + if(iand(acc,acc_write)/=0) then + j=j+1 + part(j:j)='w' + endif + if(iand(acc,acc_alloc)/=0) then + j=j+1 + part(j:j)='a' + endif + call append_to(iunit,str,i,part(1:j),.false.,depth) + end subroutine print_acc + subroutine append_to(iunit,str,i,part,break,depth) integer,intent(in):: iunit character(len=*),intent(inout):: str integer,intent(inout):: i character(len=*),intent(in):: part - logical,intent(in):: break integer,intent(in):: depth + logical,intent(in):: break integer:: n n=len(part) if(i+n>len(str)) then diff --git a/src/wcoder.f90 b/src/wcoder.f90 index 72d4b35..aa0d9a0 100644 --- a/src/wcoder.f90 +++ b/src/wcoder.f90 @@ -3,7 +3,7 @@ ! ! Released under the MIT License (MIT) ! -! Copyright (c) Tim Bellerby, 2023 +! Copyright (c) Tim Bellerby, 2025 ! ! Permission is hereby granted, free of charge, to any person obtaining a copy ! of this software and associated documentation files (the "Software"), to deal @@ -37,9 +37,8 @@ module pm_wcode use pm_lib use pm_symbol use pm_types - use pm_sysdefs - use pm_parser - use pm_codegen + use pm_ast + use pm_cnodes use pm_infer implicit none @@ -50,6 +49,7 @@ module pm_wcode integer,parameter:: max_const=2**15-1-pm_max_args integer,parameter:: max_costack=2**15-1 + integer,parameter:: max_par_depth=256 integer,parameter:: max_comm_par_depth=256 integer,parameter:: max_labels=1024 @@ -96,10 +96,6 @@ module pm_wcode integer,dimension(2):: cotop type(costate),dimension(2,max_costack):: costack integer:: cs - - ! Loop stack - integer,dimension(0:max_par_depth):: lstack - integer:: ltop,lbase ! Labels integer:: labels(1:max_labels) @@ -107,11 +103,10 @@ module pm_wcode ! Current proc integer:: loop_extra_arg - logical:: proc_can_inline,proc_is_chan - logical:: proc_shared_inline + logical:: proc_can_inline ! Inlining - type(pm_ptr):: inline_args,outer_rv + type(pm_ptr):: inline_args,inline_keys,inline_key_names,outer_rv logical:: inline_all,inline_none ! Compile time types @@ -127,12 +122,15 @@ module pm_wcode ! Last coded instruction (compiling only) integer:: last_instr + ! Vector engines for current parallel context + integer:: shared_ve + ! Stack of nested communicating sequential loops (compiling only) integer,dimension(max_comm_par_depth):: loop_stack integer:: loop_top ! Return and parameter values (compiling only) - integer:: retvar,pvar,vevar + integer:: retvar,pvar type(pm_ptr):: keys ! Set of active types (compiling only) @@ -173,12 +171,14 @@ subroutine init_wcoder(context,wcd,sig_cache,poly_cache) wcd%true_obj%data%l(wcd%true_obj%offset)=.true. wcd%false_obj=pm_new_small(context,pm_logical,1_pm_p) wcd%false_obj%data%l(wcd%false_obj%offset)=.false. - wcd%true_name=pm_new_value_typ(wcd%context,wcd%true_obj) - wcd%false_name=pm_new_value_typ(wcd%context,wcd%false_obj) + wcd%true_name=pm_new_fix_value_type(wcd%context,wcd%true_obj) + wcd%false_name=pm_new_fix_value_type(wcd%context,wcd%false_obj) if(pm_is_compiling) then wcd%typeset=pm_set_new(wcd%context,32_pm_ln) endif wcd%inline_args=pm_null_obj + wcd%inline_keys=pm_null_obj + wcd%inline_key_names=pm_null_obj end subroutine init_wcoder !==================================================== @@ -211,13 +211,10 @@ subroutine wcode_prog(wcd,p) rv=cnode_arg(p,2) wcd%base=0 wcd%top=pm_fast_esize(rv)+1 - wcd%ltop=0 init_ve=merge(0,pm_stack_nullve,pm_is_compiling) - wcd%lstack(wcd%ltop)=init_ve wcd%proc_can_inline=.true. - wcd%proc_is_chan=.false. - wcd%proc_shared_inline=.false. ve=init_ve + wcd%shared_ve=ve break=wcode_cblock(wcd,cblock,rv,ve) if(pm_is_compiling) then call make_proc_code_comp(wcd,1_pm_ln,sym_pm_system,& @@ -243,6 +240,7 @@ subroutine wcode_procs(wcd) integer:: ve,k integer(pm_ln):: i,j,n integer:: nret,vev + vev=0 wcd%base=0 i=2 do while(i<=pm_dict_size(wcd%context,wcd%code_cache)) @@ -253,57 +251,56 @@ subroutine wcode_procs(wcd) call init_wcode_proc(wcd,proc) pr=cnode_arg(proc,1) rv=cnode_arg(proc,2) + if(pm_fast_istiny(rv)) rv=pm_dict_val(wcd%context,wcd%poly_cache,int(rv%offset,pm_ln)) taints=cnode_arg(proc,3) - keys=cnode_arg(proc,4) - wcd%lstack(wcd%ltop)=merge(0,pm_stack_nullve,pm_is_compiling) - wcd%lbtop=0 - wcd%lbbase=0 - wcd%ltop=wcd%ltop+1 + !keys=cnode_arg(proc,4) if(pm_is_compiling) then ve=0 else ve=alloc_var(wcd,pm_ve_type) endif - wcd%lstack(wcd%ltop)=ve - wcd%loop_extra_arg=iand(cnode_get_num(pr,pr_flags),proc_is_comm) + wcd%loop_extra_arg=iand(cnode_get_num(pr,pr_flags),proccall_is_comm) wcd%proc_can_inline=cnode_flags_clear(proc,& cnode_args+2,proc_is_not_inlinable) - wcd%proc_is_chan=cnode_flags_set(pr,pr_flags,proc_run_complete) - wcd%proc_shared_inline=.false. - wcd%npar=cnode_get_num(pr,pr_nret)+& - cnode_get_num(pr,pr_nkeys)+wcd%loop_extra_arg - if(pm_is_compiling) then + wcd%npar=cnode_get_num(pr,pr_nret)+wcd%loop_extra_arg + if(pm_is_compiling) then if(rv%data%i(rv%offset)==-1) then wcd%retvar=alloc_result_var(wcd,int(pm_null)) else wcd%retvar=alloc_result_var(wcd,rv%data%i(rv%offset)) endif nret=wcd%nvar - if(.not.pm_fast_isnull(keys)) then - p2=pm_fast_newnc(wcd%context,pm_int,& - int(pm_fast_esize(keys)+1)) - wcd%keys=p2 - do j=0,pm_fast_esize(keys) - p2%data%i(p2%offset+j)=& - alloc_key_var(wcd,keys%data%i(keys%offset+j)) - enddo - endif +!!$ if(.not.pm_fast_isnull(keys)) then +!!$ p2=pm_fast_newnc(wcd%context,pm_int,& +!!$ int(pm_fast_esize(keys)+1)) +!!$ wcd%keys=p2 +!!$ do j=0,pm_fast_esize(keys) +!!$ p2%data%i(p2%offset+j)=& +!!$ alloc_key_var(wcd,keys%data%i(keys%offset+j)) +!!$ enddo +!!$ endif if(wcd%loop_extra_arg/=0) then if(vev>0) then - wcd%vevar=cvar_alloc_entry(wcd,v_is_parve,0,0,int(pm_logical)) + wcd%shared_ve=cvar_alloc_entry(wcd,v_is_parve,0,0,int(pm_logical)) else - wcd%vevar=-1 + wcd%shared_ve=ve endif endif else wcd%nvar=wcd%npar+1 wcd%avar=wcd%npar+1 wcd%ref_count(1:wcd%nvar)=1 + if(wcd%loop_extra_arg/=0) then + wcd%shared_ve=pm_stack_locals+1 + else + wcd%shared_ve=ve + endif endif if(debug_wcode) then write(*,*) 'WCODE PROC> #',i,'SIGNO>',n,'VE>',ve,& 'NRET>',wcd%npar,'NVAR>',wcd%nvar,& - 'CAN INLINE> ',wcd%proc_can_inline,'CHAN>',wcd%proc_is_chan + 'CAN INLINE> ',wcd%proc_can_inline,& + 'EXTRA>',wcd%loop_extra_arg endif cblock=cnode_get(pr,pr_cblock) call wcode_proc_body(wcd,cblock,rv,ve) @@ -322,6 +319,7 @@ subroutine wcode_procs(wcd) include 'fesize.inc' include 'fisnull.inc' include 'fnewnc.inc' + include 'fistiny.inc' end subroutine wcode_procs !==================================================== @@ -337,8 +335,6 @@ subroutine init_wcode_proc(wcd,proc) wcd%mvar=0 wcd%avar=0 wcd%npar=0 - wcd%lbase=0 - wcd%ltop=0 wcd%base=0 wcd%top=pm_fast_esize(cnode_arg(proc,2))+1 wcd%xbase=wcd%top @@ -360,7 +356,7 @@ subroutine init_wcode_proc(wcd,proc) wcd%inline_none=.false. wcd%retvar=-1 wcd%pvar=-1 - wcd%vevar=-1 + wcd%shared_ve=0 wcd%keys=pm_null_obj contains include 'fesize.inc' @@ -415,7 +411,7 @@ end subroutine make_proc_code !==================================================== ! Make proc object (compiler version) ! - wcode vars taints keys values... - ! - wcode is retvar, pvar, name, vevar, wcodes... + ! - wcode is retvar, pvar, name, shared_ve, wcodes... !==================================================== subroutine make_proc_code_comp(wcd,i,name,nret,taints,keys,ve) type(wcoder),intent(inout):: wcd @@ -445,7 +441,7 @@ subroutine make_proc_code_comp(wcd,i,name,nret,taints,keys,ve) p2%data%i(p2%offset)=wcd%retvar p2%data%i(p2%offset+1)=wcd%pvar p2%data%i(p2%offset+2)=name - p2%data%i(p2%offset+3)=wcd%vevar + p2%data%i(p2%offset+3)=wcd%shared_ve p2%data%i(p2%offset+4:p2%offset+wcd%pc+2)=wcd%wc(1:wcd%pc-1) p2=pm_assign_new(wcd%context,wcd%temp,& 1_pm_ln,pm_int,int(max(1,wcd%nvar),pm_ln),.false.) @@ -507,40 +503,41 @@ function wcode_pars(wcd,cblock,rv,ve,pp) result(npar) type(pm_ptr),intent(out):: pp integer:: npar type(pm_ptr):: p,tv - integer:: slot,i + integer:: slot,i,rslot integer:: v,xpar integer:: typ logical:: isref,isshared npar=wcd%npar p=cnode_get(cblock,cblock_first_var) if(.not.pm_fast_isnull(p)) then +!!$ write(*,*) 'ALLOCATING PARAM maybe>',& +!!$ trim(pm_name_as_string(wcd%context,cnode_get_name(p,var_name))),& +!!$ cnode_flags_set(p,var_flags,var_is_param) do while(cnode_flags_set(p,var_flags,var_is_param)) slot=cnode_get_num(p,var_index) typ=get_var_type(wcd,p,rv) - isshared=cnode_get_num(p,var_par_depth)==1 isref=cnode_flags_set(p,var_flags,var_is_ref) if(debug_wcode) then write(*,*) 'ALLOCATING PARAM>',& - trim(pm_name_as_string(wcd%context,cnode_get_name(p,var_name))),& - ' depth',cnode_get_num(p,var_par_depth) + trim(pm_name_as_string(wcd%context,cnode_get_name(p,var_name))) endif - wcd%rdata(slot+wcd%base)=alloc_param_var(wcd,& - typ,isref,.false.,isshared,cnode_get_num(p,var_name)) + rslot=alloc_param_var(wcd,& + typ,isref,.false.,cnode_get_num(p,var_name)) if(debug_wcode) write(*,*) 'TO>',wcd%rdata(slot+wcd%base) - - npar=npar+1 + wcd%rdata(slot+wcd%base)=rslot + if(rslot/=0) npar=npar+1 p=cnode_get(p,var_link) if(pm_fast_isnull(p)) exit enddo if(.not.pm_fast_isnull(p)) then if(cnode_flags_set(p,var_flags,var_is_varg)) then typ=get_var_type(wcd,p,rv) - tv=pm_typ_vect(wcd%context,typ) - if(pm_tv_kind(tv)==pm_typ_is_tuple) then + tv=pm_type_vect(wcd%context,typ) + if(pm_tv_kind(tv)==pm_type_is_tuple) then xpar=pm_tv_numargs(tv) do i=1,xpar typ=pm_tv_arg(tv,i) - slot=alloc_param_var(wcd,typ,.false.,.false.,.false.,0) + slot=alloc_param_var(wcd,typ,.false.,.false.,0) if(typ/=pm_tiny_int) then wcd%top=wcd%top+1 wcd%rdata(wcd%top)=slot @@ -556,7 +553,7 @@ function wcode_pars(wcd,cblock,rv,ve,pp) result(npar) endif npar=npar+xpar else - slot=alloc_param_var(wcd,typ,.false.,.false.,.false.,0) + slot=alloc_param_var(wcd,typ,.false.,.false.,0) if(typ/=pm_tiny_int) then wcd%top=wcd%top+1 wcd%rdata(wcd%top)=slot @@ -630,8 +627,9 @@ subroutine push_costate(wcd,cblock,p,first_pc,num_named,rv,ve) cs=wcd%cs top=wcd%cotop(cs)+1 wcd%cotop(cs)=top - if(top>max_costack) & - call pm_panic('Program too complex') + if(top>max_costack) then + call pm_panic('Program too complex - costack full') + endif wcd%costack(cs,top)%cblock=cblock wcd%costack(cs,top)%p=p wcd%costack(cs,top)%first_pc=first_pc @@ -721,7 +719,7 @@ function wcode_mvars(wcd,cblock,rv,ve,pp) result(num_named) slot=cnode_get_num(p,var_index) nam=cnode_get(p,var_name) wcd%rdata(slot+wcd%base)=alloc_general_var(wcd,p,rv) - if(cnode_get_num(p,var_name)/=0.or.pm_is_compiling) & + if(slot/=0.and.cnode_get_num(p,var_name)/=0.or.pm_is_compiling) & num_named=num_named+1 endif p=cnode_get(p,var_link) @@ -740,7 +738,7 @@ subroutine close_vars(wcd,cblock,rv,ve,first_pc,nvars,pp) integer,intent(in):: first_pc,nvars type(pm_ptr),optional,intent(in):: pp type(pm_ptr):: p - integer:: slot,j + integer:: slot,rslot,j integer:: name ! Info entry for parameters & named multi-use variables @@ -764,11 +762,12 @@ subroutine close_vars(wcd,cblock,rv,ve,first_pc,nvars,pp) if(arg_is_mvar(p).or.cnode_flags_set(p,var_flags,var_is_param)) then slot=cnode_get_num(p,var_index) if(.not.pm_is_compiling) then - call release_var(wcd,wcd%rdata(slot+wcd%base)) + rslot=wcd%rdata(slot+wcd%base) + call release_var(wcd,rslot) name=cnode_get_num(p,var_name) - if(name/=0) then + if(name/=0.and.rslot/=0) then wcd%wc(wcd%last+j*2)=name - wcd%wc(wcd%last+j*2-1)=wcd%rdata(slot+wcd%base) + wcd%wc(wcd%last+j*2-1)=rslot j=j+1 endif endif @@ -783,7 +782,7 @@ end subroutine close_vars !========================================================== ! Wcode a call node (which includes control structures) !========================================================== - function wcode_call(wcd,callnode,rv,ve,restart) result(break) + recursive function wcode_call(wcd,callnode,rv,ve,restart) result(break) type(wcoder),intent(inout):: wcd type(pm_ptr),intent(in):: callnode,rv integer,intent(in):: ve @@ -791,7 +790,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) logical:: break type(pm_ptr):: args - integer:: nargs,totargs,nret + integer:: nargs,totargs,nkeys,nret integer:: costart,cs,save_xbase,save_top,save_lbtop integer(pm_p):: m integer:: i,j,k,opr,tk,name,name2,new_ve,new_ve2,sig @@ -799,20 +798,22 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) type(pm_ptr):: arg,u,v,tv logical:: varg,ok,break2,save_inline_none integer:: typ,pc,jmp,tno,idx,n,ii,kk,slot,slot1,slot2,slot3 - + if(pm_debug_checks) then if(cnode_get_kind(callnode)/=cnode_is_call) & call pm_panic('Wcode call') endif - + break=.false. + if(rvv(cnode_get_num(callnode,call_index))==sp_sig_deactivated) return + args=cnode_get(callnode,call_args) nargs=cnode_numargs(args) nret=cnode_get_num(callnode,call_nret) sig=-cnode_get_num(callnode,call_sig) new_ve=-1 - + if(debug_wcode) then if(sig>0) then write(*,*) 'WCODE CALL>',sym_names(sig) @@ -882,9 +883,9 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) endif k=wcd%pc if(wcode_cblock(wcd,arg,rv,new_ve2).neqv.break2) then - call wcode_error(wcd,callnode,& - 'Communicating operations do not match '//& - 'in different branches of "if"/"switch"') + call wcode_error(wcd,callnode,& + 'Communicating operations do not match '//& + 'in different branches of "if"/"switch"') endif if(.not.break2) call release_var(wcd,new_ve2) if(break2) then @@ -905,22 +906,22 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) new_ve=0 if(tno==wcd%true_name) then call wcode_comm_block(wcd,cnode_arg(args,2),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%shared_ve,rv,new_ve) elseif(tno==wcd%false_name) then if(.not.pm_fast_isnull(cnode_arg(args,3))) then call wcode_comm_block(wcd,cnode_arg(args,3),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%shared_ve,rv,new_ve) endif else call wc_call(wcd,callnode,op_if,0,4,0,ve) pc=comp_start_if_else_block(wcd) call wc_arg(wcd,cnode_arg(args,1),.false.,rv,ve) call wcode_comm_block(wcd,cnode_arg(args,2),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%shared_ve,rv,new_ve) if(.not.pm_fast_isnull(cnode_arg(args,3))) then call comp_start_else_block(wcd,pc) call wcode_comm_block(wcd,cnode_arg(args,3),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%shared_ve,rv,new_ve) call comp_finish_else_block(wcd,pc) else call comp_finish_block(wcd,pc) @@ -936,7 +937,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) pm_fast_isnull(cnode_arg(args,3)),rv,ve) jmp=wc_jump_call(wcd,callnode,op_skip_comms,0,1,new_ve) call wcode_comm_block(wcd,cnode_arg(args,2),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%shared_ve,rv,new_ve) call set_jump_to_here(wcd,jmp) endif if(tno/=wcd%true_name) then @@ -947,52 +948,52 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_arg(wcd,cnode_arg(args,1),.false.,rv,ve) jmp=wc_jump_call(wcd,callnode,op_skip_comms,0,1,new_ve) call wcode_comm_block(wcd,cnode_arg(args,3),& - wcd%lstack(wcd%ltop-1),rv,new_ve) + wcd%shared_ve,rv,new_ve) call set_jump_to_here(wcd,jmp) endif call release_var(wcd,new_ve) endif - case(sym_while) - tno=check_arg_type(wcd,args,rv,3) + case(sym_while,sym_while_invar) + tno=check_arg_type(wcd,args,rv,2) if(tno==wcd%false_name) return if(restart) return - if(cblock_has_comm(cnode_arg(args,2))& - .or.cblock_has_comm(cnode_arg(args,4))) then + if(cblock_has_comm(cnode_arg(args,1))& + .or.cblock_has_comm(cnode_arg(args,3))) then break=.true. return endif if(pm_is_compiling) then new_ve=alloc_var(wcd,int(pm_logical)) - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,ve) + break2=wcode_cblock(wcd,cnode_arg(args,1),rv,ve) call wc_call(wcd,callnode,op_assign,111,3,0,ve) call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) + call wc_arg(wcd,cnode_arg(args,2),.false.,rv,ve) call wc_call(wcd,callnode,op_loop,0,3,0,ve) pc=comp_start_block(wcd) call wc(wcd,-new_ve) - break2=wcode_cblock(wcd,cnode_arg(args,4),rv,0) - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,0) + break2=wcode_cblock(wcd,cnode_arg(args,3),rv,0) + break2=wcode_cblock(wcd,cnode_arg(args,1),rv,0) call wc_call(wcd,callnode,op_assign,111,3,0,0) call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) + call wc_arg(wcd,cnode_arg(args,2),.false.,rv,ve) call comp_finish_block(wcd,pc) else new_ve=alloc_var(wcd,pm_ve_type) call wc_call(wcd,callnode,op_clone_ve,int(new_ve),1,1,ve) jmp=wc_jump_call(wcd,callnode,op_jmp,0,1,ve) pc=wcd%pc - break2=wcode_cblock(wcd,cnode_arg(args,4),rv,new_ve) + break2=wcode_cblock(wcd,cnode_arg(args,3),rv,new_ve) call set_jump_to_here(wcd,jmp) - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,new_ve) + break2=wcode_cblock(wcd,cnode_arg(args,1),rv,new_ve) call wc_call(wcd,callnode,op_and_jmp_any,& pc,3,1,new_ve) call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) + call wc_arg(wcd,cnode_arg(args,2),.false.,rv,ve) call release_var(wcd,new_ve) endif - case(sym_until) + case(sym_until,sym_until_invar) if(restart) return - if(cblock_has_comm(cnode_arg(args,2))) then + if(cblock_has_comm(cnode_arg(args,1))) then break=.true. return endif @@ -1004,45 +1005,20 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_call(wcd,callnode,op_loop,0,3,0,ve) pc=comp_start_block(wcd) call wc(wcd,-new_ve) - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,0) + break2=wcode_cblock(wcd,cnode_arg(args,1),rv,0) call wc_call(wcd,callnode,op_not,111,3,1,0) call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) + call wc_arg(wcd,cnode_arg(args,2),.false.,rv,ve) call comp_finish_block(wcd,pc) else new_ve=alloc_var(wcd,pm_ve_type) call wc_call(wcd,callnode,op_clone_ve,int(new_ve),1,1,ve) pc=wcd%pc - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,new_ve) + break2=wcode_cblock(wcd,cnode_arg(args,1),rv,new_ve) call wc_call(wcd,callnode,op_andnot_jmp_any,& pc,3,1,new_ve) call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,new_ve) - call release_var(wcd,new_ve) - endif - case(sym_each) - if(restart) return - if(cblock_has_comm(cnode_arg(args,2))) then - break=.true. - return - endif - if(pm_is_compiling) then - call wc_call(wcd,callnode,op_loop,0,3,0,ve) - pc=comp_start_block(wcd) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,0) - call comp_finish_block(wcd,pc) - else - new_ve=alloc_var(wcd,pm_ve_type) - call wc_call(wcd,callnode,op_clone_ve,int(new_ve),1,1,ve) - jmp=wc_jump_call(wcd,callnode,op_jmp,0,1,ve) - pc=wcd%pc - break2=wcode_cblock(wcd,cnode_arg(args,2),rv,new_ve) - call set_jump_to_here(wcd,jmp) - call wc_call(wcd,callnode,op_and_jmp_any,& - pc,3,0,new_ve) - call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) + call wc_arg(wcd,cnode_arg(args,2),.false.,rv,new_ve) call release_var(wcd,new_ve) endif case(sym_over) @@ -1067,57 +1043,10 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) return case(sym_for,sym_also) call wcode_comm_block(wcd,cnode_arg(args,1),& - wcd%lstack(wcd%ltop-1),rv,ve) + wcd%shared_ve,rv,ve) case(sym_pct) - if(nargs==1) then - n=1 - else - n=2 - if(.not.pm_is_compiling) then - call wc_call(wcd,callnode,op_setref,0,3,1,ve) - call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) - call wc(wcd,pm_stack_locals+1) - endif - endif - save_xbase=wcd%xbase - save_top=wcd%top - wcd%lstack(wcd%ltop)=ve - wcd%ltop=wcd%ltop+1 - save_lbtop=wcd%lbtop - if(wcd%ltop>max_par_depth) & - call pm_panic('program too complex (nested for/par statements)') - if(pm_is_compiling) then - new_ve=max(0,wcd%vevar) - if(wcd%base==0) then - call wc_simple_comp_call(wcd,op_comm_proc,0,2,ve) - pc=comp_start_block(wcd) - break=wcode_cblock(wcd,cnode_arg(args,n),rv,new_ve) - call comp_finish_block(wcd,pc) - else - if(wcd%proc_is_chan) new_ve=0 - break=wcode_cblock(wcd,cnode_arg(args,n),rv,new_ve) - endif - else - if(wcd%base==0) then - new_ve=pm_stack_locals+1 - else - new_ve=wcd%vevar - endif - if(wcd%proc_is_chan) then - call wc_simple_call(wcd,op_chan,1,2,new_ve) - new_ve=alloc_var(wcd,pm_ve_type) - call wc(wcd,-new_ve) - break=wcode_cblock(wcd,cnode_arg(args,n),rv,new_ve) - call release_var(wcd,new_ve) - else - break=wcode_cblock(wcd,cnode_arg(args,n),rv,new_ve) - endif - endif - wcd%ltop=wcd%ltop-1 - if(wcd%xbase>save_xbase) call release_import_varg(save_top) - wcd%xbase=save_xbase - wcd%top=save_top - wcd%lbtop=save_lbtop + call wcode_comm_block(wcd,cnode_arg(args,2),& + wcd%shared_ve,rv,ve) case(sym_hash) if(check_arg_type(wcd,args,rv,2)/=pm_null) then break=wcode_cblock(wcd,cnode_arg(args,1),rv,ve) @@ -1144,7 +1073,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) break2=wcode_cblock(wcd,cnode_arg(args,8),rv,new_ve) call comp_start_else_block(wcd,pc) call arg_set_slot(wcd,cnode_arg(args,2),& - arg_slot(wcd,cnode_arg(args,4))) + arg_slot(wcd,cnode_arg(args,4))) if(sig==sym_pm_serve.or.sig==sym_pm_recv) then call arg_set_slot(wcd,cnode_arg(args,6),& arg_slot(wcd,cnode_arg(args,3))) @@ -1292,36 +1221,54 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc(wcd,-new_ve) break2=wcode_cblock(wcd,cnode_arg(args,1),rv,new_ve) endif - case(sym_pm_dref:sym_pm_ref) + case(sym_pm_ref) if(pm_is_compiling) then - i=var_slot(wcd,cnode_arg(args,1)) - do ii=2,nargs - if(ii==4) then - slot=arg_slot(wcd,cnode_arg(args,ii)) - call cvar_set_ptr(wcd,i,ii-1,slot) - else - call comp_alias_slots(wcd,cvar_ptr(wcd,i,ii-1),& - arg_slot(wcd,cnode_arg(args,ii))) - endif - enddo - j=var_slot(wcd,cnode_arg(args,3)) - do ii=nargs,5 - call comp_alias_slots(wcd,cvar_ptr(wcd,i,ii),cvar_ptr(wcd,j,ii)) - enddo - call wc_call(wcd,callnode,op_dref,0,nargs,0,ve) - do ii=2,nargs - call wc_arg(wcd,cnode_arg(args,ii),.false.,rv,ve) - enddo +!!$ i=var_slot(wcd,cnode_arg(args,1)) +!!$ do ii=2,nargs +!!$ if(ii==4) then +!!$ slot=arg_slot(wcd,cnode_arg(args,ii)) +!!$ call cvar_set_ptr(wcd,i,ii-1,slot) +!!$ else +!!$ call comp_alias_slots(wcd,cvar_ptr(wcd,i,ii-1),& +!!$ arg_slot(wcd,cnode_arg(args,ii))) +!!$ endif +!!$ enddo +!!$ j=var_slot(wcd,cnode_arg(args,3)) +!!$ do ii=nargs,5 +!!$ call comp_alias_slots(wcd,cvar_ptr(wcd,i,ii),cvar_ptr(wcd,j,ii)) +!!$ enddo +!!$ call wc_call(wcd,callnode,op_dref,0,nargs,0,ve) +!!$ do ii=2,nargs +!!$ call wc_arg(wcd,cnode_arg(args,ii),.false.,rv,ve) +!!$ enddo else call wc_call_args(wcd,callnode,args,op_dref,& merge(0,1,sig==sym_pm_dref.or.sig==sym_pm_dref_slice),nargs,1,rv,ve) endif - case(sym_for_stmt) - call for_statement - case(sym_each_proc) - call each_proc_body + case(sym_pm_for) + call pm_for(cnode_arg(args,1),cnode_arg(args,2),ve) + case(sym_pm_shared_always) + new_ve=wcd%shared_ve + break=wcode_cblock(wcd,cnode_arg(args,2),rv,new_ve) + case(sym_pm_shared) + new_ve=alloc_var(wcd,pm_ve_type) + call wc_call(wcd,callnode,op_skip_empty,0,3,0,ve) + call wc(wcd,-new_ve) + call wc(wcd,wcd%shared_ve) + break=wcode_cblock(wcd,cnode_arg(args,2),rv,new_ve) + case(sym_pm_chan,sym_pm_chan_always) + new_ve=alloc_var(wcd,pm_ve_type) + call wc_call(wcd,callnode,op_chan,0,2,0,ve) + call wc(wcd,-new_ve) + case(sym_task) + !!! Needs restart etc. + do i=3,nargs,3 + break2=wcode_cblock(wcd,cnode_arg(args,i),rv,ve) + enddo case(sym_any) call any_statement + case(sym_pm_each_index) + call each_index_statement case(sym_pval,sym_pval_as) if(pm_is_compiling) then tno=check_arg_type(wcd,args,rv,3) @@ -1343,51 +1290,49 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_call(wcd,callnode,op_make_type_val,tno,2,1,ve) call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) endif - case(sym_struct,sym_rec) + case(sym_rec) if(pm_is_compiling) then i=arg_slot(wcd,cnode_arg(args,1)) if(cvar_kind(wcd,i)==v_is_group) then - do kk=4,nargs + do kk=5,nargs call comp_alias(wcd,callnode,pm_null_obj,cnode_arg(args,kk),rv,ve,& - cvar_ptr(wcd,i,kk-3)) + cvar_ptr(wcd,i,kk-4)) enddo else - typ=pm_typ_strip_mode(wcd%context,get_arg_type(wcd,cnode_arg(args,1),rv),j) - tv=pm_typ_vect(wcd%context,typ) - do kk=4,nargs - if(pm_typ_needs_storage(wcd%context,pm_tv_arg(tv,kk-3))) then + typ=pm_type_strip_mode(wcd%context,get_arg_type(wcd,cnode_arg(args,1),rv),j) + tv=pm_type_vect(wcd%context,typ) + do kk=5,nargs + if(pm_type_needs_storage(wcd%context,pm_tv_arg(tv,kk-4))) then slot=arg_slot(wcd,cnode_arg(args,kk)) call comp_assign_slots(wcd,callnode,& - cvar_alloc_elem(wcd,i,kk-3),& + cvar_alloc_elem(wcd,i,kk-4),& slot,.true.,rv,ve) endif enddo endif else typ=check_arg_type(wcd,args,rv,1) - call wc_call(wcd,callnode,op_struct+sig-sym_struct,& - typ,nargs-1,1,ve) + call wc_call(wcd,callnode,op_rec,& + typ,nargs-2,1,ve) call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) - do kk=4,nargs + do kk=5,nargs arg=cnode_arg(args,kk) call wc_arg(wcd,cnode_arg(args,kk),.false.,rv,ve) enddo endif + case(sym_pm_list) + typ=check_arg_type(wcd,args,rv,1) + call wc_call_args(wcd,callnode,args,op_rec,typ,& + nargs,1,rv,ve) case(sym_dot,sym_dot_ref,sym_get_dot,sym_get_dot_ref,sym_method_call) i=rvv(cnode_get_num(callnode,call_index)) - if(i>pm_typ_dref_offset/2) then + if(i>pm_type_dref_offset/2) then j=op_elem_ref - i=i-pm_typ_dref_offset + i=i-pm_type_dref_offset else j=op_elem endif - if(i>0) then - call wc_args_get_elem(wcd,callnode,j,args,int(i),rv,ve) - elseif(i<0) then - v=pm_dict_val(wcd%context,wcd%sig_cache,int(-i,pm_ln)) - call wc_sub_elem(wcd,callnode,j,cnode_arg(args,1),cnode_arg(args,2),& - v%data%i,v%offset+1,v%offset+pm_fast_esize(v),rv,ve) - endif + call wc_args_get_elem(wcd,callnode,j,args,i,rv,ve) case(sym_test) if(pm_opts%check_stmts) then if(restart) then @@ -1409,7 +1354,8 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) new_ve=alloc_var(wcd,pm_ve_type) call wc_call(wcd,callnode,op_andnot_ve,0,3,1,ve) call wc(wcd,-new_ve) - call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) + ! Use arg_slot here as this is a single-use variable we are using later + call wc(wcd,arg_slot(wcd,cnode_arg(args,3))) break=wcode_cblock(wcd,cnode_arg(args,2),rv,new_ve) call release_var(wcd,new_ve) if(break) call wcode_error(wcd,callnode,& @@ -1421,75 +1367,77 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call wc_arg(wcd,cnode_arg(args,3),.false.,rv,ve) endif case(sym_present) - v=cnode_arg(cnode_arg(args,3),1) - idx=v%data%i(v%offset) - v=cnode_arg(cnode_arg(args,4),1) - idx=idx+v%data%i(v%offset) if(wcd%base==0) then - if(pm_is_compiling) then - v=cnode_arg(cnode_arg(args,4),1) - idx=v%data%i(v%offset) - i=wcd%keys%data%i(wcd%keys%offset+idx-1) - call wc_call(wcd,callnode,op_if,0,4,0,ve) - pc=comp_start_if_else_block(wcd) - call wc(wcd,cvar_ptr(wcd,i,1)) - call comp_assign_slots(wcd,callnode,arg_slot(wcd,cnode_arg(args,1)),& - cvar_ptr(wcd,i,2),.true.,rv,ve) - call comp_start_else_block(wcd,pc) - call comp_assign(wcd,callnode,cnode_arg(args,1),cnode_arg(args,5),.true.,rv,ve) - call comp_finish_else_block(wcd,pc) - else - call wc_call(wcd,callnode,op_get_key,idx+& - wcd%loop_extra_arg+pm_stack_locals,4,2,ve) - call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) - call wc_arg(wcd,cnode_arg(args,2),.true.,rv,ve) - call wc_arg(wcd,cnode_arg(args,5),.false.,rv,ve) - endif + call wc_call_args(wcd,callnode,args,op_present,0,2,1,rv,ve) else - arg=cnode_arg(wcd%inline_args,idx+wcd%keybase-1) - ok=.true. - if(cnode_get_kind(arg)==cnode_is_const) then - if(pm_fast_vkind(cnode_arg(arg,1))==pm_tiny_int) then - ok=.false. - endif - endif - call release_var(wcd,var_slot(wcd,cnode_arg(args,1))) - if(ok) then - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - arg,wcd%oldbase,rv,ve) - call wc_call(wcd,callnode,op_logical_return,1,2,1,ve) - call wc_arg(wcd,cnode_arg(args,2),.true.,rv,ve) + ! Inline version + if(.not.pm_fast_isnull(wcd%inline_keys)) then + ok=.false. + do j=1,cnode_numargs(wcd%inline_keys) + if(wcd%inline_key_names%data%i(wcd%inline_key_names%offset+j-1)==& + cnode_get_num(cnode_arg(args,i),var_name)) then + ok=.true. + endif + enddo else - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,5),wcd%base,rv,ve) - call wc_call(wcd,callnode,op_logical_return,0,2,1,ve) - call wc_arg(wcd,cnode_arg(args,2),.true.,rv,ve) + ok=.false. endif + call wc_call(wcd,callnode,op_logical_return,merge(1,0,ok),2,1,ve) + call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) endif case(sym_key) - v=cnode_arg(cnode_arg(args,2),1) - idx=v%data%i(v%offset) + n=nargs/4 if(wcd%base==0) then - if(pm_is_compiling) then - wcd%rdata(cnode_get_num(cnode_arg(args,1),var_index)+wcd%base)=& - -wcd%keys%data%i(wcd%keys%offset+idx-1) - else - v=cnode_arg(cnode_arg(args,3),1) - idx=idx+v%data%i(v%offset)+wcd%loop_extra_arg - call wc_call_args(wcd,callnode,args,op_get_key2,& - idx+pm_stack_locals,1,1,rv,ve) - endif + do i=1,nargs/4 + if(get_arg_type(wcd,cnode_arg(args,i+n),rv)==& + get_arg_type(wcd,cnode_arg(args,i*2+n+n),rv).or..true.) then + if(pm_is_compiling) then + call wc_call(wcd,callnode,op_get_key,0,5,1,ve) + pc=comp_start_block(wcd) + break2=wcode_cblock(wcd,cnode_arg(args,i*2+n+n-1),rv,ve) + call comp_finish_block(wcd,pc) + call wc_arg(wcd,cnode_arg(args,i+n),.true.,rv,ve) + call wc_arg(wcd,cnode_arg(args,i),.false.,rv,ve) + call wc_arg(wcd,cnode_arg(args,i*2+n+n),.false.,rv,ve) + else + new_ve=alloc_var(wcd,pm_ve_type) + call wc_call(wcd,callnode,op_get_key,0,4,0,ve) + call wc(wcd,-new_ve) + call wc_arg(wcd,cnode_arg(args,i+n),.true.,rv,ve) + call wc_arg(wcd,cnode_arg(args,i),.false.,rv,ve) + break2=wcode_cblock(wcd,cnode_arg(args,i*2+n+n-1),rv,new_ve) + call wc_call(wcd,callnode,op_default,0,3,1,new_ve) + call wc_arg(wcd,cnode_arg(args,i+n),.true.,rv,new_ve) + call wc_arg(wcd,cnode_arg(args,i*2+n+n),.false.,rv,new_ve) + endif + else + write(*,*) 'Diffnt',& + trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,i+n),rv))),& + trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,i*2+n+n),rv))) + ! key arg type differs from default value - so key arg must be present + call link_to_val(wcd,callnode,cnode_arg(args,i+n),wcd%base,& + cnode_arg(args,i),wcd%base,rv,ve) + endif + enddo else - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(wcd%inline_args,idx+wcd%keybase),wcd%oldbase,& - rv,ve) - endif - case(sym_default) - call wc_call_args(wcd,callnode,args,op_default,& - check_arg_type(wcd,args,rv,1),1,1,rv,ve) - case(sym_init_var) - call wc_call(wcd,callnode,op_init_var,0,2,1,ve) - call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) + ! Inline case + outer:do i=1,n + if(.not.pm_fast_isnull(wcd%inline_keys)) then + do j=1,cnode_numargs(wcd%inline_keys) + v=cnode_arg(wcd%inline_keys,j) + if(wcd%inline_key_names%data%i(wcd%inline_key_names%offset+j-1)==& + cnode_get_num(cnode_arg(args,i),var_name)) then + call link_to_val(wcd,callnode,cnode_arg(args,i+n),wcd%base,& + cnode_arg(wcd%inline_keys,j),wcd%oldbase,rv,ve) + cycle outer + endif + enddo + endif + break2=wcode_cblock(wcd,cnode_arg(args,i*2+n+n-1),rv,new_ve) + call link_to_val(wcd,callnode,cnode_arg(args,i+n),wcd%base,& + cnode_arg(args,i*2+n+n),wcd%base,rv,ve) + enddo outer + endif case(sym_is) if(check_arg_type(wcd,args,rv,1)==wcd%true_name) then call wc_call(wcd,callnode,op_logical_return,1,2,1,ve) @@ -1507,24 +1455,19 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) var_slot(wcd,cnode_arg(args,kk))) enddo endif - case(sym_coherent,sym_partial,sym_set_mode,& - sym_invar,sym_shared,sym_var_set_mode,sym_assign,sym_sync_assign) + case(sym_private,sym_set_mode,sym_const,sym_var,sym_dotdotdot,sym_open_brace,sym_amp,& + sym_invar,sym_shared,sym_var_set_mode,sym_assign,sym_sync_assign,sym_pm_assign) continue ! Nothing to do + case(sym_null) + call wc_call_args(wcd,callnode,args,op_nullify,0,nargs,nargs,rv,ve) case(sym_cast) i=rvv(cnode_get_num(callnode,call_index)) if(i==0) then call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& cnode_arg(args,2),wcd%base,rv,ve) else - v=pm_dict_val(wcd%context,wcd%sig_cache,int(i,pm_ln)) - v=cnode_arg(v,1) - if(pm_fast_esize(v)==0) then - call wc_call_args(wcd,callnode,args,op_make_poly,& - v%data%i(v%offset),3,1,rv,ve) - else - call wc_sub_elem(wcd,callnode,op_elem,cnode_arg(args,1),cnode_arg(args,2),& - v%data%i,v%offset,v%offset+pm_fast_esize(v),rv,ve) - endif + call wc_call_args(wcd,callnode,args,op_make_poly,& + i,3,1,rv,ve) endif case(sym_dcaret) if(pm_is_compiling) then @@ -1540,89 +1483,26 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& cnode_arg(args,2),wcd%base,rv,ve) endif - case(sym_dash,sym_caret,sym_change_mode,sym_var,sym_const) + case(sym_fix,sym_literal,sym_caret,sym_change_mode) call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& cnode_arg(args,2),wcd%base,rv,ve) - case(sym_import_val,sym_import_shared) - if(pm_is_compiling) then - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) - elseif(call_flag_set(wcd,callnode,rv)) then - if(nret==0) then - call wc_call_args(wcd,callnode,args,op_import_back,0,nargs,0,rv,ve) - else - call wc_call_args(wcd,callnode,args,op_import_val,0,nargs,1,rv,ve) - endif - elseif(nret>0)then - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) - endif - case(sym_import_param) - if(call_flag_set(wcd,callnode,rv).and..not.pm_is_compiling) then - if(wcd%base==0) then - new_ve=pm_stack_locals+1 - else - new_ve=wcd%vevar - endif - call wc_call_args(wcd,callnode,args,op_import_val,0,nargs,1,rv,new_ve) - else - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) - endif - case(sym_import_varg) - if(.not.pm_is_compiling) then - if(call_flag_set(wcd,callnode,rv)) then - n=wcd%top-wcd%xbase - if(wcd%top+n>max_code_stack) call pm_panic('out of code stack') - do i=1,n - !!! Note this is not right type (for vm only does not matter) - wcd%rdata(wcd%top+i)=alloc_var(wcd,pm_ve_type) - enddo - do i=1,n - call wc_call(wcd,callnode,op_import_val,0,3,1,ve) - call wc(wcd,-wcd%rdata(wcd%top+i)) - call wc(wcd,wcd%rdata(wcd%xbase+i)) - enddo - wcd%xbase=wcd%xbase+n - wcd%top=wcd%top+n - endif - endif - case(sym_export) - if(.not.pm_is_compiling) then - if(call_flag_set(wcd,callnode,rv)) then - call wc_call_args(wcd,callnode,args,op_export,0,nargs,0,rv,ve) - endif - endif - case(sym_export_as_new) - if(call_flag_set(wcd,callnode,rv).and..not.pm_is_compiling) then - call wc_call_args(wcd,callnode,args,op_export_param,0,nargs,1,rv,ve) - else - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) - endif - case(sym_export_param) - if(pm_is_compiling) then - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) - else - if(wcd%base==0) then - new_ve=pm_stack_locals+1 - else - new_ve=wcd%vevar - endif - if(call_flag_set(wcd,callnode,rv)) then - call wc_call_args(wcd,callnode,args,op_export_param,0,nargs,1,rv,new_ve) - else - call link_to_val(wcd,callnode,cnode_arg(args,1),wcd%base,& - cnode_arg(args,2),wcd%base,rv,ve) - endif - endif + case(sym_pm_set_dotdotdot) + wcd%xbase=wcd%top + tno=get_arg_type(wcd,cnode_arg(args,2),rv) + tv=pm_type_vect(wcd%context,tno) + do i=1,pm_tv_numargs(tv) + call wc_call(wcd,callnode, op_elem,i+1,3,1,ve) + wcd%top=wcd%top+1 + wcd%rdata(wcd%top)=alloc_var(wcd,pm_tv_arg(tv,i)) + call wc(wcd,-wcd%rdata(wcd%top)) + call wc(wcd,arg_slot(wcd,cnode_arg(args,2))) + enddo case(sym_result) if(wcd%base==0) then if(pm_is_compiling) then if(debug_wcode) then write(*,*) 'RETURN-ACTUAL[',n,']:',& - trim(pm_typ_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,n),rv))) + trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,n),rv))) endif i=wcd%retvar do kk=1,nargs @@ -1638,7 +1518,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) do n=1,nargs if(debug_wcode) then write(*,*) 'RETURN[',n,']:',& - trim(pm_typ_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,n),rv))) + trim(pm_type_as_string(wcd%context,get_arg_type(wcd,cnode_arg(args,n),rv))) endif if(pm_is_compiling) then slot=cvar_strip_alias(wcd,arg_slot_in_frame(wcd,cnode_arg(args,n),wcd%base)) @@ -1646,7 +1526,7 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) if(debug_wcode) then write(*,*) 'RETURN ASSN',& - trim(pm_typ_as_string(wcd%context,& + trim(pm_type_as_string(wcd%context,& check_arg_type_with_mode(wcd,wcd%inline_args,wcd%outer_rv,n))) endif @@ -1656,16 +1536,16 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) if((cvar_kind(wcd,slot)/=v_is_group.or.& cvar_kind(wcd,slot)==v_is_group.and.& cvar_v2(wcd,slot)/=v_is_array).and.& - wcd%loop_extra_arg==0.and..not.wcd%proc_shared_inline.and.& - pm_typ_get_mode(wcd%context,& - check_arg_type_with_mode(wcd,wcd%inline_args,wcd%outer_rv,n))>=sym_mirrored& + wcd%loop_extra_arg==0.and.& + pm_type_get_mode(wcd%context,& + check_arg_type_with_mode(wcd,wcd%inline_args,wcd%outer_rv,n))>=sym_invar& .or.cvar_kind(wcd,slot2)==v_is_chan_vect) then if(debug_wcode) then write(*,*) 'RETURN actual ASSN',cvar_kind(wcd,slot),& - trim(pm_typ_as_string(wcd%context,& + trim(pm_type_as_string(wcd%context,& check_arg_type_with_mode(wcd,wcd%inline_args,wcd%outer_rv,n))) endif - + call comp_assign_slots(wcd,callnode,& arg_slot_in_frame(wcd,cnode_arg(wcd%inline_args,n),wcd%oldbase),& slot,.true.,rv,ve) @@ -1702,16 +1582,14 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) else totargs=nargs endif - if(cnode_flags_clear(callnode,call_flags,call_is_comm)) then - call wcode_proc_call(wcd,callnode,rv,ve,-1,& - args,nargs,totargs,nret,sig) -!!$ elseif(pm_is_compiling) then -!!$ break=.true. -!!$ return + if(pm_fast_isnull(cnode_get(callnode,call_keys))) then + nkeys=0 else - call wcode_proc_call(wcd,callnode,rv,wcd%lstack(wcd%ltop-1),ve,& - args,nargs,totargs,nret,sig) + nkeys=cnode_numargs(cnode_get(callnode,call_keys)) endif + call wcode_proc_call(wcd,callnode,rv,ve,merge(wcd%shared_ve,-1,& + cnode_flags_set(callnode,call_flags,proccall_is_comm)),& + args,nargs,totargs,nkeys,nret,sig) end select if(debug_wcode) then if(sig>0) then @@ -1728,82 +1606,39 @@ function wcode_call(wcd,callnode,rv,ve,restart) result(break) include 'fesize.inc' include 'fvkind.inc' - subroutine for_statement - break2=wcode_cblock(wcd,cnode_arg(args,4),rv,ve) - if(break2) then - call wcode_error(wcd,callnode,& - 'Cannot have communicating operations in partition/workshare') - endif - if(check_arg_type(wcd,args,rv,2)==pm_null) then - call for_body(ve) - else - v=cnode_arg(args,8) - v=cnode_arg(v,1) - slot=v%data%i(v%offset) - slot2=v%data%i(v%offset+1) - u=pm_dict_val(wcd%context,wcd%sig_cache,int(& - rvv(int(cnode_get_num(callnode,call_index))),pm_ln)) - v=cnode_arg(u,1) - rv%data%i(rv%offset+slot:rv%offset+slot2)=& - v%data%i(v%offset:v%offset+slot2-slot) - if(pm_is_compiling) then - call wc_call(wcd,callnode,op_if_shared_node,0,3,0,ve) - pc=comp_start_if_else_block(wcd) - else - pc=wc_jump_call(wcd,callnode,op_jmp_noshare,0,1,ve) - endif - call for_body(merge(0,ve,pm_is_compiling)) - v=cnode_arg(u,2) - rv%data%i(rv%offset+slot:rv%offset+slot2)=& - v%data%i(v%offset:v%offset+slot2-slot) - if(pm_is_compiling) then - call comp_start_else_block(wcd,pc) - if(wcd%num_errors==0) call for_body(0) - call comp_finish_else_block(wcd,pc) - else - jmp=wc_jump_call(wcd,callnode,op_jmp,0,1,ve) - call set_jump_to_here(wcd,pc) - if(wcd%num_errors==0) call for_body(ve) - call set_jump_to_here(wcd,jmp) - endif - endif - end subroutine for_statement - - subroutine for_body(ve) - integer:: j,ve - integer:: save_xbase,save_top + subroutine pm_for(arg,stmts,ve) + type(pm_ptr),intent(in):: arg,stmts + integer,intent(in):: ve + integer:: j,new_ve,save_xbase,save_lbtop,save_top,save_shared_ve save_xbase=wcd%xbase save_top=wcd%top if(.not.pm_is_compiling) then + new_ve=alloc_var(wcd,pm_ve_type) call wc_call(wcd,callnode,op_par_loop,0,3,1,ve) - call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) - call wc_arg(wcd,cnode_arg(args,6),.false.,rv,ve) + call wc(wcd,-new_ve) + call wc_arg(wcd,arg,.false.,rv,ve) j=wc_jump_call(wcd,callnode,op_jmp,0,1,ve) - new_ve=var_slot(wcd,cnode_arg(args,1)) else call wc_simple_comp_call(wcd,op_comm_block,0,3,ve) j=comp_start_block(wcd) call wc_arg(wcd,cnode_arg(args,6),.false.,rv,ve) new_ve=0 endif - wcd%lstack(wcd%ltop)=ve - wcd%ltop=wcd%ltop+1 - if(wcd%ltop>max_par_depth) & - call pm_panic('program too complex (nested loops)') save_lbtop=wcd%lbtop - break2=wcode_cblock(wcd,cnode_arg(args,3),rv,new_ve) + save_shared_ve=wcd%shared_ve + wcd%shared_ve=ve + call wcode_comm_block(wcd,stmts,new_ve,rv,new_ve) if(.not.pm_is_compiling) then call wc_call(wcd,callnode,op_par_loop_end,0,1,0,ve) call set_jump_to_here(wcd,j) else call comp_finish_block(wcd,j) endif - wcd%ltop=wcd%ltop-1 - if(wcd%xbase>save_xbase) call release_import_varg(save_top) + wcd%shared_ve=save_shared_ve + wcd%lbtop=save_lbtop wcd%xbase=save_xbase wcd%top=save_top - wcd%lbtop=save_lbtop - end subroutine for_body + end subroutine pm_for subroutine any_statement logical:: any_break @@ -1813,7 +1648,7 @@ subroutine any_statement slot=v%data%i(v%offset) slot2=v%data%i(v%offset+1_pm_p) u=pm_dict_val(wcd%context,wcd%sig_cache,int(& - rvv(int(cnode_get_num(callnode,call_index))),pm_ln)) + rvv(int(cnode_get_num(callnode,call_index))),pm_ln)) if(.not.pm_is_compiling) new_ve=alloc_var(wcd,pm_ve_type) any_break=.false. do kk=1,cnode_numargs(u) @@ -1842,102 +1677,65 @@ subroutine any_statement any_break=any_break.or.wcode_cblock(wcd,cnode_arg(args,2),rv,new_ve) if(.not.pm_is_compiling) call set_jump_to_here(wcd,jmp) enddo - call release_var(wcd,new_ve) + if(.not.pm_is_compiling) call release_var(wcd,new_ve) end subroutine any_statement - - subroutine each_proc_body - integer:: i,j,typ,slot,slot2,slot3 - integer:: n,ii - integer,dimension(:,:),allocatable:: rtns - type(pm_ptr):: u,v,arg - slot=cnode_get_num(callnode,call_index) - slot2=rvv(slot) - if(slot2==0) then - break=wcode_cblock(wcd,cnode_arg(args,nret+2),& - rv,ve) - else - u=pm_dict_val(wcd%context,wcd%sig_cache,int(& - rvv(int(cnode_get_num(callnode,call_index))),pm_ln)) - n=cnode_numargs(u) - v=cnode_arg(args,nret+4) - v=cnode_arg(v,1) - slot=v%data%i(v%offset) - slot2=v%data%i(v%offset+1) - allocate(rtns(nret,0:n-1)) - do i=0,n-1 - if(debug_wcode) write(*,*) 'EACH PROC> Dot',i,'of',n-1 - v=cnode_arg(u,i+1) - rv%data%i(rv%offset+slot:rv%offset+slot2)=& - v%data%i(v%offset:v%offset+slot2-slot) - if(debug_wcode) write(*,*) 'EACH PROC> MOVE OVER',v%data%i(v%offset:v%offset+slot2-slot) - if(pm_is_compiling) then - do j=nargs-nret+1,nargs - arg=cnode_arg(args,j) - slot3=cnode_get_num(arg,var_index) - if(debug_wcode) write(*,*) 'EACH PROC> RE-ALLOCATE',slot3 - wcd%rdata(slot3+wcd%base)=alloc_general_var(wcd,arg,rv) - enddo - endif - do j=nret+5,nargs-nret-1,2 - if(pm_is_compiling) then - arg=cnode_arg(args,j+1) - slot3=cnode_get_num(arg,var_index) - if(debug_wcode) write(*,*) 'EACH PROC RE-ALLOCATE(b)',slot3 - wcd%rdata(slot3+wcd%base)=alloc_general_var(wcd,arg,rv) - endif - call wc_arg_get_elem(wcd,callnode,op_elem,cnode_arg(args,j+1),& - cnode_arg(args,j),i+2,rv,ve) - enddo - if(cblock_has_comm(cnode_arg(args,nret+3))) then - call wcode_comm_block(wcd,cnode_arg(args,nret+3),& - wcd%lstack(wcd%ltop-1),rv,ve) - else - break=wcode_cblock(wcd,cnode_arg(args,nret+3),rv,ve) - endif - do j=1,nret - k=cnode_get_num(cnode_arg(args,nargs-nret+j),var_index)+wcd%base - rtns(j,i)=wcd%rdata(k) - enddo + + subroutine each_index_statement + logical:: any_break + integer:: k,kk,n,num_named,first_pc + integer,dimension(:),allocatable::rets + logical:: break + type(pm_ptr):: cblock,p + v=cnode_arg(args,nret+3) + v=cnode_arg(v,1) + slot=v%data%i(v%offset) + slot2=v%data%i(v%offset+1_pm_p) + u=pm_dict_val(wcd%context,wcd%sig_cache,int(& + rvv(int(cnode_get_num(callnode,call_index))),pm_ln)) + cblock=cnode_arg(args,nret+2) + n=cnode_numargs(u) + if(nret>1) allocate(rets(n)) + do kk=1,n + arg=cnode_arg(u,kk) + rv%data%i(rv%offset+slot:rv%offset+slot2)=& + arg%data%i(arg%offset:arg%offset+slot2-slot) + + first_pc=wcd%pc + num_named=wcode_mvars(wcd,cblock,rv,ve) + + if(.not.pm_is_compiling) then + call wc_call(wcd,callnode,op_number,kk,2,1,ve) + call wc_arg(wcd,cnode_arg(args,nret),.true.,rv,ve) + endif + + p=cnode_get(cblock,cblock_first_call) + do while(.not.pm_fast_isnull(p)) + break=wcode_call(wcd,p,rv,ve,.false.) + p=cnode_get(p,call_link) enddo - do j=1,nret - if(pm_is_compiling) then - ii=arg_slot(wcd,cnode_arg(args,j)) - if(cvar_kind(wcd,ii)==v_is_group) then - do i=0,n-1 - call comp_alias_slots(wcd,cvar_ptr(wcd,ii,i+1),rtns(j,i)) - enddo - else - typ=check_arg_type(wcd,args,rv,j) - tv=pm_typ_vect(wcd%context,typ) - do i=0,n-1 - if(pm_typ_needs_storage(wcd%context,pm_tv_arg(tv,i+1))) then - call comp_assign_slots(wcd,callnode,& - cvar_alloc_elem(wcd,ii,i+1),& - rtns(j,i),& - .true.,rv,ve) - endif - enddo - endif - else - i=check_arg_type(wcd,args,rv,j) - v=pm_typ_vect(wcd%context,i) - if(pm_tv_kind(v)==pm_typ_is_struct) then - call wc_call(wcd,callnode,op_struct,i,n+2,1,ve) - elseif(pm_tv_kind(v)==pm_typ_is_rec) then - call wc_call(wcd,callnode,op_rec,i,n+2,1,ve) - else - call pm_panic('Wcode each proc') - endif - call wc_arg(wcd,cnode_arg(args,j),.true.,rv,ve) - do i=0,n-1 - call wc(wcd,rtns(j,i)) - enddo - endif + + ! Close variables + if(.not.pm_is_compiling) then + call close_vars(wcd,cblock,rv,ve,first_pc,num_named) + endif + + if(nret>1) then + call wc_call(wcd,callnode,op_setref,0,3,1,ve) + rets(kk)=alloc_var(wcd,get_arg_type(wcd,cnode_arg(args,nret+4),rv)) + call wc(wcd,-rets(kk)) + call wc_arg(wcd,cnode_arg(args,nret+4),.false.,rv,ve) + endif + + enddo + if(nret>1) then + call wc_call(wcd,callnode,op_struct,get_var_type(wcd,cnode_arg(args,1),rv),n+2,1,ve) + call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) + do kk=1,n + call wc(wcd,rets(kk)) + call release_var(wcd,rets(kk)) enddo - deallocate(rtns) - break=wcode_cblock(wcd,cnode_arg(args,nret+1),rv,ve) - endif - end subroutine each_proc_body + end if + end subroutine each_index_statement function rvv(n) result(m) integer,intent(in):: n @@ -1952,7 +1750,7 @@ subroutine release_import_varg(xbase) call release_var(wcd,wcd%rdata(i)) enddo end subroutine release_import_varg - + end function wcode_call !======================================== @@ -1970,24 +1768,24 @@ end function call_flag_set ! nargs = number of args before arg... ! totargs = total number of args passed (including arg...) ! For comm calls only (for non-comm calls ve2==0) - ! ve = vector engine for outer scope - ! ve2 = vector engine for inner scope + ! ve = vector engine for inner scope + ! ve2 = vector engine for outer scope !==================================================================== recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& - args,nargs,totargs,nret,sig) + args,nargs,totargs,nkeys,nret,sig) type(wcoder),intent(inout):: wcd type(pm_ptr),intent(in):: callnode,rv integer,intent(in):: ve,ve2 type(pm_ptr),intent(in):: args - integer,intent(in):: nargs,totargs,nret + integer,intent(in):: nargs,totargs,nkeys,nret integer,intent(in):: sig integer:: ve1,idx,procnode_kind,op,slot,slot2,slot3,typ - integer:: i,j,arg_base,nkeys,op2,taints,par_kind,pc - type(pm_ptr):: procnode,arg,tv,amps + integer:: i,j,arg_base,op2,taints,par_kind,pc,tno,nproc_keys + type(pm_ptr):: keys,key_names,proc_keys,procnode,arg,tv,amps,p logical:: varg,ok,autocv,save_inline_all,steps_back,enclosing_block integer:: extra_ve,ignore_args logical:: keep_ctime_const - integer,dimension(totargs):: conv + integer,dimension(-nkeys:totargs):: conv if(ve2<0) then extra_ve=0 else @@ -1995,7 +1793,6 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& endif ignore_args=0 idx=rvv(cnode_get_num(callnode,call_index)) - ! Check for special signatures if(idx<0) then @@ -2003,21 +1800,25 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& case(sp_sig_dup) if(pm_is_compiling) then call comp_assign(wcd,callnode,& - cnode_arg(args,1),cnode_arg(args,2),.true.,rv,ve) - else - call wc_call_args(wcd,callnode,args,op_clone,0,2,1,rv,ve) - endif - case(sp_sig_thru) - if(pm_is_compiling) then - call comp_alias(wcd,callnode,cnode_arg(args,1),cnode_arg(args,2),& - rv,ve) + cnode_arg(args,1),cnode_arg(args,3+extra_ve*(num_comm_args-1)),.true.,rv,ve) else - call link_to_val(wcd,callnode,cnode_arg(args,1),& - wcd%base,cnode_arg(args,2),wcd%base,& - rv,ve) + call wc_call(wcd,callnode,op_clone,66,3,1,ve) + call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) + call wc_arg(wcd,cnode_arg(args,3+extra_ve*(num_comm_args-1)),.false.,rv,ve) endif + case(sp_sig_link) + call link_to_val(wcd,callnode,cnode_arg(args,3+extra_ve*(num_comm_args-1)),& + wcd%base,cnode_arg(args,1),wcd%base,rv,ve) case(sp_sig_noop) continue + case(sp_sig_setval) + if(.not.pm_is_compiling) then + call wc_call(wcd,callnode,op_setref,0,3,1,ve) + call wc_arg(wcd,cnode_arg(args,1),.true.,rv,ve) + call wc(wcd,& + -pm_max_stack-& + add_const(wcd,pm_type_val(wcd%context,check_arg_type(wcd,args,rv,1)))) + endif case default call wcode_error(wcd,callnode,'System Error!') write(*,*) 'IDX=',idx @@ -2031,11 +1832,15 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& par_kind=0 ! Get signature details + + !write(*,*) 'GETSIG>',idx + procnode=pm_dict_key(wcd%context,wcd%sig_cache,int(idx,pm_ln)) if(pm_fast_esize(procnode)>1) par_kind=procnode%data%i(procnode%offset+2) procnode=pm_dict_val(wcd%context,wcd%sig_cache,int(idx,pm_ln)) varg=cnode_flags_set(callnode,call_flags,call_is_vararg) procnode_kind=cnode_get_kind(procnode) + keys=cnode_get(callnode,call_keys) ! Process any autoconversions conv=-1 @@ -2063,10 +1868,8 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& taints=cnode_get_num(procnode,node_args+2) if(wcd%inline_all.or.(wcd%proc_can_inline& .and.inlinable(procnode,args,nargs,nret,extra_ve))) then - ve1=preamble(ve1) call wcode_inlined_call(wcd,callnode,rv,ve1,ve2,args,nargs,& totargs,nret,taints,procnode,varg,conv) - call postamble wcd%inline_all=save_inline_all return else @@ -2077,19 +1880,26 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& endif wcd%inline_all=save_inline_all keep_ctime_const=.false. + key_names=pm_name_val(wcd%context,cnode_get_num(callnode,call_key_names)) + proc_keys=cnode_get(cnode_arg(procnode,1),pr_keys) + nproc_keys=pm_fast_esize(proc_keys)/2 else ! Intrinsic procedure - operator info stored in proc object op=cnode_get_num(procnode,bi_opcode) op2=cnode_get_num(procnode,bi_opcode2) - if(cnode_flags_set(procnode,bi_flags,proc_needs_type)) then + if(cnode_flags_set(procnode,pr_flags,proc_needs_type)) then if(op==op_logical_return) then - if(check_arg_type(wcd,args,rv,1)==wcd%false_name) then + if(check_arg_type(wcd,args,rv,2)==wcd%false_name) then op2=0 else op2=1 endif elseif(op==op_elem) then - call pm_panic('op_elem in proc_needs_type') + if(nargs==4) then + tno=check_arg_type(wcd,args,rv,4) + p=pm_type_val(wcd%context,tno) + op2=p%data%ln(p%offset)+1 + endif else op2=check_arg_type(wcd,args,rv,1) endif @@ -2100,25 +1910,26 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& if(comp_transform_op(wcd,callnode,op,op2,args,nargs,totargs,nret,rv,ve,ve2,extra_ve,conv)) return endif if(extra_ve>0) then - ve1=ve2 ignore_args=num_comm_args extra_ve=0 + else + ignore_args=1 endif keep_ctime_const=.true. + nproc_keys=0 endif !write(*,*) 'CALLVE> PRE',ve1 - ve1=preamble(ve1) - + if(pm_is_compiling.and.extra_ve>0) then - ve1=ve2 extra_ve=0 endif ! Start coding the call instruction !write(*,*) 'CALLVE>',ve1 - call wc_call(wcd,callnode,op,op2,totargs+extra_ve+1-ignore_args,nret,ve1) + call wc_call(wcd,callnode,op,op2,& + totargs+extra_ve+1-ignore_args+merge(nkeys,nproc_keys,pm_is_compiling),nret,ve1) if(extra_ve>0) then call wc(wcd,ve2) endif @@ -2128,16 +1939,6 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& call wc_p_arg(wcd,cnode_arg(args,i),.true.,rv,ve1,.false.) enddo - ! Keyword arguments treated slighly differenly when compiling - if(pm_is_compiling) then - nkeys=cnode_get_num(callnode,call_nkeys) - if(nkeys>0) then - call comp_keys(nkeys) - endif - else - nkeys=0 - endif - ! If compiling need to flag up any "&" args ! (mainly for optimiser) if(pm_is_compiling) then @@ -2150,7 +1951,7 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& ! Code arguments before arg... arg_base=wcd%pc j=0 - do i=nret+nkeys+1+ignore_args,nargs + do i=nret+1+ignore_args,nargs if(pm_is_compiling.and..not.pm_fast_isnull(amps)) then if(amps%data%i(amps%offset+j)+nret+nkeys==i) then call wc_p_arg(wcd,cnode_arg(args,i),.true.,rv,ve1,keep_ctime_const) @@ -2178,13 +1979,40 @@ recursive subroutine wcode_proc_call(wcd,callnode,rv,ve,ve2,& endif enddo + ! Code keyword arguments + if(pm_is_compiling) then + ! ... TODO ... + else + if(pm_fast_isnull(keys)) then + do j=1,nproc_keys + call wc(wcd,& + -pm_max_stack-add_const(wcd,pm_fast_tinyint(wcd%context,-1))) + enddo + else + outer: do j=1,nproc_keys + do i=1,nkeys + if(proc_keys%data%i(proc_keys%offset+j-1)==key_names%data%i(key_names%offset+i-1)) then + if(conv(-i)>0) then + call wc_p(wcd,conv(-i),keep_ctime_const) + call release_var(wcd,conv(-i)) + else + call wc_p_arg(wcd,cnode_arg(keys,i),.false.,rv,ve1,keep_ctime_const) + endif + cycle outer + endif + enddo + call wc(wcd,& + -pm_max_stack-add_const(wcd,pm_fast_tinyint(wcd%context,-1))) + enddo outer + endif + endif + ! When compiling some args may have been disagregated ! so neeed to correct number of arguments if(pm_is_compiling) then call wc_correct_call_args(wcd) endif - call postamble contains @@ -2211,22 +2039,15 @@ subroutine autoconv arg=cnode_arg(procnode,i) ! Argument indices are coded as displacements back from end of args ! (gets around possible presence of keyword args) - idx=totargs-arg%data%i(arg%offset) - if(pm_fast_esize(arg)==1) then - tno=arg%data%i(arg%offset+1) - slot=alloc_var(wcd,tno) - call wc_call(wcd,callnode,op_make_poly,tno,3,1,ve) - call wc(wcd,-slot) + idx=arg%data%i(arg%offset) + tno=arg%data%i(arg%offset+1) + slot=alloc_var(wcd,tno) + call wc_call(wcd,callnode,op_make_poly,tno,3,1,ve) + call wc(wcd,-slot) + if(idx<0) then call wc_arg(wcd,cnode_arg(args,idx),.false.,rv,ve) else - if(idx<=nargs) then - slot=get_sub_elem(wcd,callnode,op_elem,cnode_arg(args,idx),& - arg%data%i,arg%offset+1,arg%offset+pm_fast_esize(arg),rv,ve) - else - slot=get_sub_elem_from_slot(wcd,callnode,op_elem,& - wcd%rdata(wcd%xbase+idx-nargs),& - arg%data%i,arg%offset+1,arg%offset+pm_fast_esize(arg),rv,ve) - endif + call wc_arg(wcd,cnode_arg(args,idx),.false.,rv,ve) endif conv(idx)=slot enddo @@ -2251,11 +2072,8 @@ function add_proc(sig,ve2,extra_ve) result(n) proc=pm_dict_val(wcd%context,wcd%sig_cache,int(sig,pm_ln)) proc=cnode_arg(proc,1) if(cnode_get_kind(proc)==cnode_is_proc) then - if(cnode_flags_clear(proc,pr_flags,proc_run_complete).and.& - cnode_flags_clear(callnode,call_flags,proc_run_complete)) then - key(2)=1 - m=2 - endif + key(2)=1 + m=2 endif ! If not passing conditional context then zero extra_ve if(m==1) extra_ve=0 @@ -2295,53 +2113,27 @@ function inlinable(proc,args,nargs,nret,extra_ve) result(ok) enddo endif - ! Cannot currently inline procs with keyword args +!!$ ! Cannot currently inline procs with keyword args p=cnode_arg(proc,1) - if(cnode_get_num(p,pr_nkeys)>0) then - ok=.false. - return - endif - - ! For now cannot inline shared calls - flags=iand(ior(taints,cnode_get_num(callnode,call_flags)),proc_run_shared+proc_run_local) - if(flags/=0) then - ok=.false. - return - endif - -!!$ ! .. or calls returning shared/uniform when compiling -!!$ if(pm_is_compiling.and..false.) then -!!$ if(nret>0.and.extra_ve==0) then -!!$ tno=check_arg_type_with_mode(wcd,args,rv,1) -!!$ if(pm_typ_get_mode(wcd%context,tno)>=sym_mirrored) then -!!$ ok=.false. -!!$ return -!!$ endif -!!$ endif -!!$ endif - ! Always inline "each" procs - if(cnode_flags_set(p,pr_flags,proc_is_each_proc)) then - ok=.true. - return - endif ! Forced inline/no-inline in some contexts if(wcd%inline_none) then ok=.false. return endif + if(wcd%inline_all) then ok=.true. return endif ! Check if call and proc definition have no_inline or inline attributes - flags=iand(ior(taints,cnode_get_num(callnode,call_flags)),proc_inline+proc_no_inline) - if(iand(flags,proc_no_inline)/=0) then + flags=iand(ior(taints,cnode_get_num(callnode,call_flags)),proccall_is_inline+proccall_is_no_inline) + if(iand(flags,proccall_is_no_inline)/=0) then ok=.false. return - elseif(flags==proc_inline) then + elseif(flags==proccall_is_inline) then ok=.true. return endif @@ -2364,84 +2156,6 @@ function inlinable(proc,args,nargs,nret,extra_ve) result(ok) end function inlinable - ! Preamble dealing with <> and <>/<>/<> - function preamble(ve) result(ve1) - integer,intent(in):: ve - integer:: ve1 - logical:: is_par,run_shared_or_local,run_shared - logical:: run_call_complete,run_proc_complete,run_complete,run_if_needed - integer:: opcode2 - is_par=par_kind<=par_mode_conc - run_shared_or_local=iand(taints,proc_run_shared+proc_run_local)/=0.or.& - .not.cnode_flags_clear(callnode,call_flags,proc_run_shared+proc_run_local) - run_shared=iand(taints,proc_run_shared)/=0.or.& - .not.cnode_flags_clear(callnode,call_flags,proc_run_shared) - run_call_complete=cnode_flags_set(callnode,call_flags,proc_run_complete) - run_proc_complete=iand(taints,proc_run_shared)/=0 - run_complete=run_proc_complete.or.run_call_complete - run_if_needed=(run_shared.or.run_complete.or.run_proc_complete).and.& - (iand(taints,proc_run_always)==0.and.& - cnode_flags_clear(callnode,call_flags,proc_run_always)) - enclosing_block=.false. - if(run_if_needed) then - ! opcode2==1 if need to check for live tasks across nodes - if(is_par.and.(run_shared.or.run_complete)) then - opcode2=1 - else - opcode2=0 - endif - if(pm_is_compiling) then - call wc_call(wcd,callnode,op_skip_empty,opcode2,2,0,ve) - pc=comp_start_block(wcd) - enclosing_block=.true. - ve1=merge(shared_op_flag,0,run_shared_or_local) - else - ve1=alloc_var(wcd,pm_ve_type) - call wc_call(wcd,callnode,op_skip_empty,opcode2,3,0,merge(ve2,ve,ve2>=0)) - call wc(wcd,-ve1) - if(run_complete) then - call wc(wcd,ve) - else - call wc(wcd,wcd%lstack(wcd%ltop-1)) - endif - endif - elseif(run_shared_or_local) then - if(pm_is_compiling) then - ve1=shared_op_flag - else - ve1=wcd%lstack(wcd%ltop-1) - endif - elseif(run_complete) then - if(pm_is_compiling) then - ve1=0 - else - ve1=alloc_var(wcd,pm_ve_type) - call wc_simple_call(wcd,op_chan,0,2,ve) - call wc(wcd,-ve1) - endif - else - ve1=ve - endif - steps_back=is_par.and.iand(taints,proc_has_for)/=0.and.(& - iand(taints,proc_run_shared)/=0.or.& - cnode_flags_set(callnode,call_flags,proc_run_shared)) - if(steps_back) then - call wc_call(wcd,callnode,op_push_node_back,0,1,0,ve1) - endif - end function preamble - - ! Postamble dealing with <> and <> - subroutine postamble - if(steps_back) then - call wc_call(wcd,callnode,op_pop_off_node,0,1,0,ve1) - endif - if(pm_is_compiling) then - if(enclosing_block) then - call comp_finish_block(wcd,pc) - endif - endif - end subroutine postamble - ! Code keyword arguments (compling only) ! Each keyword comiled as pair of args: present/value subroutine comp_keys(nkeys) @@ -2463,7 +2177,7 @@ subroutine comp_keys(nkeys) endif enddo end subroutine comp_keys - + end subroutine wcode_proc_call !==================================================================== @@ -2478,23 +2192,18 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre logical,intent(in):: varg integer,dimension(totargs):: conv - integer:: save_base,save_oldbase,save_xbase,save_lbase,save_keybase,save_lbl + integer:: save_base,save_oldbase,save_xbase,save_keybase,save_lbl integer:: save_loop_extra_arg - logical:: save_proc_is_chan,save_shared_inline - type(pm_ptr):: pr,p,c,cblock,rv,save_args,save_rv,arg,tv - integer:: pc,depth,par,num_named,first_pc,npar,slot,i,n,xarg,tno,lastxarg + type(pm_ptr):: save_args,save_rv,save_keys,save_key_names + type(pm_ptr):: pr,p,c,cblock,rv,arg,tv + integer:: pc,par,num_named,first_pc,npar,slot,i,n,xarg,tno,lastxarg,flags logical:: break integer:: ve integer:: nkeys - integer:: save_vevar + integer:: save_shared_ve - depth=cnode_get_num(callnode,call_par_depth) - if(depth/=0) depth=depth+wcd%lbase - if(depth>' do i=1,nargs p=cnode_arg(args,i) - write(*,*) 'Par[',i,'] {',trim(pm_typ_as_string(wcd%context,get_arg_type(wcd,p,old_rv))),'#',& + write(*,*) 'Par[',i,'] {',trim(pm_type_as_string(wcd%context,get_arg_type(wcd,p,old_rv))),'#',& arg_slot(wcd,cnode_arg(args,i)),'##',p%offset,wcd%base,old_rv%offset call pm_dump_tree(wcd%context,6,old_rv,2) call dump_cvar(wcd,6,arg_slot(wcd,cnode_arg(args,i)),nonest=.true.) @@ -2540,15 +2250,12 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre if(debug_wcode) write(*,*) 'Inline>',pm_name_as_string(wcd%context,cnode_get_num(pr,pr_name)) cblock=cnode_get(pr,pr_cblock) rv=cnode_arg(proc,2) - nkeys=cnode_get_num(pr,pr_nkeys) - npar=nret+1+nkeys + !nkeys=cnode_get_num(pr,pr_nkeys) + npar=nret+1 wcd%keybase=nret - - wcd%proc_is_chan=cnode_flags_set(pr,pr_flags,proc_run_complete) - wcd%proc_shared_inline=.not.cnode_flags_clear(pr,pr_flags,proc_run_shared+proc_run_local) - - save_vevar=wcd%vevar - wcd%vevar=ve2 + + save_shared_ve=wcd%shared_ve + wcd%shared_ve=ve2 wcd%loop_extra_arg=merge(1,0,ve2>0) wcd%rdata(wcd%top+1:wcd%top+pm_fast_esize(rv)+1)=-1 @@ -2590,7 +2297,6 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre enddo endif - wcd%lbase=wcd%ltop-1 wcd%oldbase=wcd%base wcd%base=wcd%top wcd%top=wcd%top+pm_fast_esize(rv)+1 @@ -2610,8 +2316,8 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre call wcode_error(wcd,callnode,'tno==-1') endif if(tno/=pm_tiny_int.and.tno/=-1) then - tv=pm_typ_vect(wcd%context,tno) - if(pm_tv_kind(tv)/=pm_typ_is_tuple) then + tv=pm_type_vect(wcd%context,tno) + if(pm_tv_kind(tv)/=pm_type_is_tuple) then wcd%top=wcd%top+1 wcd%rdata(wcd%top)=& arg_slot_in_frame(wcd,cnode_arg(args,i),wcd%oldbase) @@ -2643,7 +2349,7 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre ! Process calls c=cnode_get(cblock,cblock_first_call) do while(.not.pm_fast_isnull(c)) - if(debug_wcode) write(*,*) 'INLINE> ve=',wcd%vevar + if(debug_wcode) write(*,*) 'INLINE> ve=',wcd%shared_ve break=wcode_call(wcd,c,rv,ve,.false.) c=cnode_get(c,call_link) enddo @@ -2661,18 +2367,17 @@ subroutine wcode_inlined_call(wcd,callnode,old_rv,ve1,ve2,args,nargs,totargs,nre wcd%top=wcd%base wcd%xbase=save_xbase - wcd%lbase=save_lbase wcd%base=save_base wcd%oldbase=save_oldbase wcd%outer_rv=save_rv wcd%inline_args=save_args + wcd%inline_keys=save_keys + wcd%inline_key_names=save_key_names wcd%keybase=save_keybase - wcd%vevar=save_vevar - wcd%proc_is_chan=save_proc_is_chan + wcd%shared_ve=save_shared_ve wcd%lbtop=wcd%lbbase wcd%lbbase=save_lbl wcd%loop_extra_arg=save_loop_extra_arg - wcd%proc_shared_inline=save_shared_inline ! Close down parameters releasing vars if(.not.pm_is_compiling) then @@ -2974,15 +2679,14 @@ subroutine combine_labels(wcd,sig,start,finish,step,first_p,out_ve,& name2=cnode_arg(cnode_arg(args,1),1) if(name%offset/=name2%offset) then call mismatch(wcd,first_p,p,& - 'labels do not match: '//& + '"sync" labels do not match: '//& trim(pm_name_as_string(wcd%context,int(name%offset)))//' / '//& trim(pm_name_as_string(wcd%context,int(name2%offset)))) endif call wcode_comm_block(wcd,cnode_arg(args,2),out_ve,rv,ve) - case(sym_while,sym_each,sym_until,& - sym_while_invar,sym_until_invar,sym_foreach_invar) + case(sym_sync_while) call mismatch(wcd,first_p,p,& - 'labelled statement matched to communicating loop') + '"sync" statement matched to "sync while"') end select enddo @@ -3604,7 +3308,7 @@ subroutine wc_call(wcd,node,op,op2,nargs,nret,ve) integer,intent(in):: op2 integer,intent(in):: nargs,nret integer:: modl,line,last - integer:: depth + integer:: flags !write(*,*) 'wc_call',trim(op_names(op)),' nret=',nret if(.not.(pm_fast_isnull(wcd%inline_args).or.pm_is_compiling)) then modl=cnode_get_num(wcd%inline_args,cnode_modl_name) @@ -3641,14 +3345,17 @@ subroutine wc_call(wcd,node,op,op2,nargs,nret,ve) endif endif endif + + if(pm_debug_checks) then if(cnode_get_kind(node)/=cnode_is_call) then call pm_panic('wc call not callnode') endif endif - depth=cnode_get_num(node,call_par_depth) - if(depth/=0) depth=depth+wcd%lbase - if(depth',wcd%rdata(slot1),var - wcd%rdata(slot1)=var - if(var<=0) return - if(arg_is_mvar(arg2)) then - wcd%ref_count(var-pm_stack_locals+1)=& - wcd%ref_count(var-pm_stack_locals+1)+1 + else + + slot1=cnode_get_num(arg1,var_index)+base1 + var=arg_slot_in_frame(wcd,arg2,base2) + if(debug_wcode) write(*,*) 'LINK>',wcd%rdata(slot1),var + wcd%rdata(slot1)=var + if(var<=0) return + if(arg_is_mvar(arg2)) then + wcd%ref_count(var-pm_stack_locals+1)=& + wcd%ref_count(var-pm_stack_locals+1)+1 + endif endif end subroutine link_to_val - + !==================================================================== ! Add a new constant to the current procedures constant pool !==================================================================== @@ -3934,7 +3642,11 @@ function add_const(wcd,val) result(n) n=wcd%nval+1 wcd%nval=n - wcd%values(n)=val + if(pm_fast_vkind(val)==pm_name) then + wcd%values(n)=pm_name_val(wcd%context,int(val%offset)) + else + wcd%values(n)=val + endif n=n+1 contains include 'fvkind.inc' @@ -3957,21 +3669,20 @@ end function alloc_key_var !==================================================================== ! Allocate parameter variable !==================================================================== - function alloc_param_var(wcd,typ,isref,iskey,isshared,name) result(k) + function alloc_param_var(wcd,typ,isref,iskey,name) result(k) type(wcoder),intent(inout):: wcd integer,intent(in):: typ,name - logical,intent(in):: isref,iskey,isshared + logical,intent(in):: isref,iskey integer:: k integer:: flags - !write(*,*) 'PARAM>>',trim(pm_typ_as_string(wcd%context,typ)) + !write(*,*) 'PARAM>>',trim(pm_type_as_string(wcd%context,typ)) if(pm_is_compiling) then flags=v_is_param if(isref) flags=ior(flags,v_is_ref) if(iskey) flags=ior(flags,v_is_key) - if(isshared)flags=ior(flags,v_is_shared) k=cvar_alloc(wcd,typ,flags,name) else - k=alloc_var(wcd,typ) + k=alloc_var(wcd,0) ! use zero type to avoid not allocating unused parameters endif end function alloc_param_var @@ -3987,7 +3698,7 @@ function alloc_result_var(wcd,typ) result(k) flags=v_is_result k=cvar_alloc(wcd,typ,flags) else - k=alloc_var(wcd,typ) + k=alloc_var(wcd,0) endif end function alloc_result_var @@ -4007,10 +3718,11 @@ function alloc_general_var(wcd,var,rv) result(k) if(debug_wcode) then write(*,*) 'ALLOC GENERAL VAR',cnode_get_num(var,var_index),';',k,'::',cvar_kind(wcd,k),':',& trim(pm_name_as_string(wcd%context,cnode_get_name(var,var_name))),& - ':',trim(pm_typ_as_string(wcd%context,typ)) + ':',trim(pm_type_as_string(wcd%context,typ)) endif else - k=alloc_var(wcd,0) + typ=get_var_type(wcd,var,rv) + k=alloc_var(wcd,typ) endif end function alloc_general_var @@ -4022,6 +3734,10 @@ function alloc_var(wcd,typ) result(k) integer,intent(in):: typ integer:: i integer::k + if(typ==sp_sig_deactivated) then + k=0 + return + endif if(pm_is_compiling) then k=cvar_alloc(wcd,typ,0) return @@ -4063,7 +3779,7 @@ subroutine release_var(wcd,slot) integer,intent(in):: slot integer:: k if(pm_is_compiling) return - if(slot<0) return + if(slot<=0) return k=slot-pm_stack_locals+1 if(pm_debug_checks) then if(k<1.or.k>wcd%mvar) then @@ -4124,11 +3840,11 @@ function check_arg_type(wcd,args,rv,n) result(tno) var=cnode_arg(args,n) k=cnode_get_num(var,cnode_kind) if(k==cnode_is_const) then - tno=pm_typ_strip_mode(wcd%context,cnode_get_num(var,node_args+1),mode) + tno=pm_type_strip_mode(wcd%context,cnode_get_num(var,node_args+1),mode) return endif i=cnode_get_num(var,var_index) - tno=pm_typ_strip_mode(wcd%context,rv%data%i(rv%offset+i),mode) + tno=pm_type_strip_mode(wcd%context,rv%data%i(rv%offset+i),mode) contains include 'ftypeof.inc' end function check_arg_type @@ -4186,7 +3902,7 @@ function strip_mode_for_interp(wcd,tno) result(tno2) if(pm_is_compiling) then tno2=tno else - tno2=pm_typ_strip_mode(wcd%context,tno,mode) + tno2=pm_type_strip_mode(wcd%context,tno,mode) endif end function strip_mode_for_interp @@ -4229,20 +3945,6 @@ function arg_is_mvar(arg) result(ok) endif end function arg_is_mvar - !==================================================================== - ! Argument does not exists in all tasks - ! (usually created in conditional context) - !==================================================================== - function arg_is_incomplete(arg) result(ok) - type(pm_ptr),intent(in):: arg - logical:: ok - ok=.false. - if(cnode_get_kind(arg)==cnode_is_var) then - if(.not.cnode_flags_clear(arg,var_flags,var_is_incomplete)) then - ok=.false. - endif - endif - end function arg_is_incomplete !==================================================================== ! Argument is variable created in a par statement @@ -4274,6 +3976,7 @@ subroutine wc(wcd,val) endif end subroutine wc + !==================================================================== ! Make more space for word-codes !==================================================================== @@ -4322,104 +4025,15 @@ subroutine wc_arg_get_elem(wcd,callnode,op,argout,argin,elem,rv,ve) aslot=arg_slot(wcd,argout) if(cvar_kind(wcd,aslot)/=v_is_ctime_const) then call comp_get_elem(wcd,op,& - aslot,arg_slot(wcd,argin),elem-1) + aslot,arg_slot(wcd,argin),elem) endif else - call wc_call(wcd,callnode,op,elem,3,1,ve) + call wc_call(wcd,callnode,op,merge(elem,elem+1,pm_is_compiling),3,1,ve) call wc_arg(wcd,argout,.true.,rv,ve) call wc_arg(wcd,argin,.false.,rv,ve) endif end subroutine wc_arg_get_elem - !==================================================================== - ! Gets sub-element .x.y.z of struct/rect argin, returning it in argout - !==================================================================== - subroutine wc_sub_elem(wcd,callnode,op,argout,argin,elems,start,end,rv,ve) - type(wcoder),intent(inout):: wcd - type(pm_ptr),intent(in):: callnode,argout,argin,rv - integer,dimension(*),intent(in):: elems - integer(pm_p),intent(in):: start, end - integer,intent(in):: op,ve - integer:: slot,out - if(pm_is_compiling) then - if(cvar_kind(wcd,var_slot(wcd,argout))==v_is_ctime_const) then - return - endif - endif - if(end-2pm_null.and.& tno<=pm_string.or.tno==pm_string_type) then call wc(wcd,cvar_const(wcd,arg)) elseif(keep_ctime_const) then - if(pm_typ_kind(wcd%context,tno)==pm_typ_is_value) then + if(pm_type_kind(wcd%context,tno)==pm_type_is_fix_value) then call wc(wcd,cvar_const(wcd,arg)) endif endif @@ -4547,7 +4161,7 @@ recursive subroutine comp_get_elem(wcd,op,dest,asource,elem) case(v_is_basic,v_is_elem,v_is_unit_elem,v_is_sub,v_is_vsub,& v_is_vect_wrapped,v_is_chan_vect) if(cvar_kind(wcd,dest)==v_is_group) then - tv=pm_typ_vect(wcd%context,cvar_type(wcd,dest)) + tv=pm_type_vect(wcd%context,cvar_type(wcd,dest)) call comp_alias_slots(wcd,dest,& cvar_alloc_elem(wcd,source,elem)) else @@ -4606,7 +4220,7 @@ subroutine comp_get_subs(wcd,n,aparent,asubs) !!$ call dump_cvar(wcd,6,aparent) parent=cvar_strip_alias(wcd,aparent) subs=cvar_strip_alias(wcd,asubs) - tv=pm_typ_vect(wcd%context,cvar_type(wcd,parent)) + tv=pm_type_vect(wcd%context,cvar_type(wcd,parent)) if(cvar_kind(wcd,parent)==v_is_group) then call cvar_set_info(wcd,n,v_is_vsub,& cvar_ptr(wcd,parent,1),subs,pm_tv_arg(tv,1)) @@ -4626,7 +4240,7 @@ function comp_subs(wcd,parent,subs) result(n) integer,intent(in):: parent,subs integer:: n type(pm_ptr):: tv - tv=pm_typ_vect(wcd%context,cvar_type(wcd,parent)) + tv=pm_type_vect(wcd%context,cvar_type(wcd,parent)) n=cvar_alloc_slots(wcd,3) call comp_get_subs(wcd,n,parent,subs) end function comp_subs @@ -4911,16 +4525,16 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) elseif(typ<=pm_string) then n=cvar_alloc_entry(wcd,v_is_basic,name,flags,typ) else - tv=pm_typ_vect(wcd%context,typ) + tv=pm_type_vect(wcd%context,typ) tk=pm_tv_kind(tv) select case(tk) - case(pm_typ_is_basic) + case(pm_type_is_basic) n=cvar_alloc_entry(wcd,v_is_basic,name,flags,typ) call add_to_typeset(wcd,typ) - case(pm_typ_is_struct,pm_typ_is_rec) + case(pm_type_is_rec) nflags=pm_tv_flags(tv) - if(iand(nflags,pm_typ_is_soa)/=0.or.& - iand(nflags,pm_typ_has_storage)==0)then + if(iand(nflags,pm_type_is_soa)/=0.or.& + iand(nflags,pm_type_has_storage)==0)then m=pm_tv_numargs(tv) n=cvar_alloc_slots(wcd,3+m) v1=m @@ -4930,24 +4544,24 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) enddo call cvar_set_info(wcd,n,v_is_group,v1,v2,typ) else - !write(*,*) 'STRUCT>',trim(pm_typ_as_string(wcd%context,typ)) + !write(*,*) 'STRUCT>',trim(pm_type_as_string(wcd%context,typ)) n=cvar_alloc_entry(wcd,v_is_basic,name,flags,typ) call add_to_typeset(wcd,typ) endif - case(pm_typ_is_array) + case(pm_type_is_array) if(iand(flags,v_is_param+v_is_result)/=0.and.& iand(flags,v_is_chan)==0) then nflags=ior(flags,v_is_array_par_dom) if(pm_tv_name(tv)/=sym_var) nflags=iand(nflags,not(v_is_ref)) tno=pm_tv_arg(tv,1) - if(iand(pm_typ_flags(wcd%context,tno),pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(wcd%context,tno),pm_type_has_storage)/=0) then vec=cvar_alloc_entry(wcd,v_is_basic,pm_tv_arg(tv,3),& ior(flags,v_is_array_par_vect),tno) else vec=cvar_alloc(wcd,tno,flags,aname) endif tno=pm_tv_arg(tv,2) - if(iand(pm_typ_flags(wcd%context,tno),pm_typ_has_storage)/=0) then + if(iand(pm_type_flags(wcd%context,tno),pm_type_has_storage)/=0) then dom=cvar_alloc_entry(wcd,v_is_basic,name,& nflags,tno) else @@ -4958,9 +4572,9 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) n=cvar_alloc_entry(wcd,v_is_basic,name,ior(flags,v_is_farray),typ) endif call add_to_typeset(wcd,typ) - case(pm_typ_is_user) - n=cvar_alloc(wcd,pm_user_typ_body(wcd%context,typ),flags,aname) - case(pm_typ_is_tuple,pm_typ_is_vtuple) + case(pm_type_is_user) + n=cvar_alloc(wcd,pm_user_type_body(wcd%context,typ),flags,aname) + case(pm_type_is_tuple,pm_type_is_vtuple) m=pm_tv_numargs(tv) n=cvar_alloc_slots(wcd,3+m) v1=m @@ -4969,14 +4583,14 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) wcd%vinfo(n+i+2)=ptr(cvar_alloc(wcd,pm_tv_arg(tv,i),flags)) enddo call cvar_set_info(wcd,n,v_is_group,v1,v2,typ) - case(pm_typ_is_dref) + case(pm_type_is_dref) nflags=ior(iand(flags,not(v_is_shared+v_is_ref+v_is_vect)),& merge(0,v_is_in_dref,pm_tv_name(tv)==sym_pling)) i=pm_tv_flags(tv) n=cvar_alloc_slots(wcd,8) v1=5 v2=merge(v_is_shared_dref,v_is_dref,& - pm_typ_get_mode(wcd%context,pm_tv_arg(tv,3))>=sym_mirrored) + pm_type_get_mode(wcd%context,pm_tv_arg(tv,3))>=sym_invar) wcd%vinfo(n+3)=dptr(pm_tv_arg(tv,1),nflags) !ptr(cvar_alloc(wcd,pm_tv_arg(tv,1),nflags)) wcd%vinfo(n+4)=dptr(pm_tv_arg(tv,2),ior(nflags,iand(flags,v_is_ref))) !ptr(cvar_alloc(wcd,pm_tv_arg(tv,2),ior(nflags,v_is_ref))) @@ -4984,17 +4598,17 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) wcd%vinfo(n+6)=dptr(pm_tv_arg(tv,4),nflags) !ptr(cvar_alloc(wcd,pm_tv_arg(tv,4),nflags)) wcd%vinfo(n+7)=dptr(pm_tv_arg(tv,5),nflags) !ptr(cvar_alloc(wcd,pm_tv_arg(tv,5),nflags)) call cvar_set_info(wcd,n,v_is_group,v1,v2,typ) - case(pm_typ_is_poly) + case(pm_type_is_poly) n=cvar_alloc_entry(wcd,v_is_basic,name,ior(flags,v_is_poly),typ) - case(pm_typ_is_single_name,pm_typ_is_proc,pm_typ_is_type) + case(pm_type_is_single_name,pm_type_is_proc,pm_type_is_type) n=cvar_alloc_entry(wcd,v_is_group,0,v_is_storageless,typ) - case(pm_typ_is_value) + case(pm_type_is_fix_value,pm_type_is_literal_value) n=cvar_alloc_entry(wcd,v_is_ctime_const,add_const(wcd,& - pm_typ_val(wcd%context,typ)),0,typ) - case(pm_typ_is_par_kind) + pm_type_val(wcd%context,typ)),0,typ) + case(pm_type_is_par_kind) k=pm_tv_name(tv) nflags=flags - if(k>=sym_mirrored) nflags=ior(nflags,v_is_shared) + if(k>=sym_invar) nflags=ior(nflags,v_is_shared) if(k==sym_chan) then nflags=ior(nflags,v_is_chan+v_is_vect) n=cvar_alloc_entry(wcd,v_is_chan_vect,& @@ -5004,14 +4618,14 @@ recursive function cvar_alloc(wcd,typ,flags,aname) result(n) else n=cvar_alloc(wcd,pm_tv_arg(tv,1),nflags,name) endif - case(pm_typ_is_all) + case(pm_type_is_all) ! This just caters for _nhd variables n=cvar_alloc(wcd,pm_tv_arg(tv,1),flags,name) - case(pm_typ_is_vect) + case(pm_type_is_vect) n=cvar_alloc(wcd,pm_tv_arg(tv,1),ior(flags,v_is_vect),name) n=cvar_alloc_entry(wcd,v_is_vect_wrapped,n,0,pm_tv_arg(tv,1)) case default - write(*,*) 'CVAR ALLOC:', tk,trim(pm_typ_as_string(wcd%context,typ)) + write(*,*) 'CVAR ALLOC:', tk,trim(pm_type_as_string(wcd%context,typ)) call pm_panic('cvar_alloc') end select endif @@ -5056,11 +4670,11 @@ recursive subroutine add_to_typeset(wcd,typ,dim) integer:: tno,key(2),m integer:: i type(pm_ptr):: tv - tno=pm_typ_strip_to_basic(wcd%context,typ) + tno=pm_type_strip_to_basic(wcd%context,typ) tset=wcd%typeset if(tno>0.and.tno<=pm_string.and..not.present(dim)) return - if(.not.pm_typ_needs_storage(wcd%context,abs(tno))) return - if(pm_typ_kind(wcd%context,tno)==pm_typ_is_poly) tno=pm_pointer + if(.not.pm_type_needs_storage(wcd%context,abs(tno))) return + if(pm_type_kind(wcd%context,tno)==pm_type_is_poly) tno=pm_pointer key(1)=tno if(present(dim)) then key(2)=dim @@ -5068,8 +4682,8 @@ recursive subroutine add_to_typeset(wcd,typ,dim) key(2)=0 endif if(pm_ivect_lookup(wcd%context,tset,key,2)<=0) then - tv=pm_typ_vect(wcd%context,abs(tno)) - if(pm_tv_kind(tv)==pm_typ_is_array) then + tv=pm_type_vect(wcd%context,abs(tno)) + if(pm_tv_kind(tv)==pm_type_is_array) then call add_to_typeset(wcd,pm_tv_arg(tv,1),pm_tv_arg(tv,3)) endif do i=1,pm_tv_numargs(tv) @@ -5109,18 +4723,18 @@ function cvar_const(wcd,arg) result(slot1) integer:: slot1,slot2 integer:: tno,mode,tk type(pm_ptr):: tv - tno=pm_typ_strip_mode(wcd%context,cnode_get_num(arg,cnode_args+1),mode) + tno=pm_type_strip_mode(wcd%context,cnode_get_num(arg,cnode_args+1),mode) if(tno<=pm_null) then slot1=cvar_alloc_entry(wcd,v_is_group,0,v_is_storageless,tno) else - tv=pm_typ_vect(wcd%context,tno) + tv=pm_type_vect(wcd%context,tno) tk=pm_tv_kind(tv) - if(tk==pm_typ_is_single_name.or.tk==pm_typ_is_proc) then + if(tk==pm_type_is_single_name.or.tk==pm_type_is_proc) then slot1=cvar_alloc_entry(wcd,v_is_group,0,v_is_storageless,tno) else slot2=add_const(wcd,cnode_arg(arg,1)) slot1=cvar_alloc_entry(wcd,& - merge(v_is_ctime_const,v_is_const,pm_tv_kind(tv)==pm_typ_is_value),& + merge(v_is_ctime_const,v_is_const,pm_tv_kind(tv)==pm_type_is_fix_value),& slot2,0,tno) endif endif @@ -5222,7 +4836,7 @@ function cvar_alloc_elem(wcd,parent,elem) result(n) integer,intent(in):: parent,elem integer:: n type(pm_ptr):: tv - tv=pm_typ_vect(wcd%context,cvar_type(wcd,parent)) + tv=pm_type_vect(wcd%context,cvar_type(wcd,parent)) n=cvar_alloc_entry(wcd,merge(v_is_unit_elem,v_is_elem,pm_tv_numargs(tv)==1.and..false.),& parent,elem,pm_tv_arg(tv,elem)) end function cvar_alloc_elem @@ -5263,9 +4877,9 @@ subroutine cvar_set_elem(wcd,n,parent,elem) call pm_panic('cvar_set_elem') endif endif - tv=pm_typ_vect(wcd%context,cvar_type(wcd,parent)) -!!$ write(*,*) cvar_type(wcd,parent),'>>',elem,';',trim(pm_typ_as_string(wcd%context,cvar_type(wcd,parent))),& -!!$ ';',trim(pm_typ_as_string(wcd%context,cvar_type(wcd,n))) + tv=pm_type_vect(wcd%context,cvar_type(wcd,parent)) +!!$ write(*,*) cvar_type(wcd,parent),'>>',elem,';',trim(pm_type_as_string(wcd%context,cvar_type(wcd,parent))),& +!!$ ';',trim(pm_type_as_string(wcd%context,cvar_type(wcd,n))) call cvar_set_info(wcd,n,merge(v_is_unit_elem,v_is_elem,pm_tv_numargs(tv)==1.and..false.),& parent,elem,pm_tv_arg(tv,elem)) end subroutine cvar_set_elem @@ -5306,7 +4920,7 @@ subroutine cvar_set_info(wcd,n,kind,v1,v2,tno) if(kind==v_is_alias.and.v1==0) then call pm_panic('Alias to nothing...') endif - if(tno/=0) junk=pm_typ_name(wcd%context,tno) + if(tno/=0) junk=pm_type_name(wcd%context,tno) endif wcd%vinfo(n)=v1*cvar_flag_mult+kind wcd%vinfo(n+1)=v2*cvar_flag_mult @@ -5568,7 +5182,7 @@ subroutine dump_wc(context,iunit) trim(pm_name_as_string(context,int(code(3)))),& ' (==' if(pm_is_compiling) then - write(iunit,*) 'RETVAR=',code(1),'PVAR=',code(2),'VEVAR=',code(4) + write(iunit,*) 'RETVAR=',code(1),'PVAR=',code(2),'SHARED_VE=',code(4) qq=p%data%ptr(p%offset+1) call dump_full_cvar(context,iunit,int(code(1)),2,.false.,qq%data%i(qq%offset:)) call dump_full_cvar(context,iunit,int(code(2)),2,.false.,qq%data%i(qq%offset:)) @@ -5893,7 +5507,7 @@ subroutine dump_single_cvar(context,iunit,n,array) typ=array(n+2)/cvar_flag_mult if(kind==v_is_group) then write(iunit,'(i6,1x,a5,1x,a7,1x,a,1x,10i6)') n,v_names(kind),& - v_groups(v2),trim(pm_typ_as_string(context,typ)),& + v_groups(v2),trim(pm_type_as_string(context,typ)),& (array(n+2+i)/cvar_flag_mult,i=1,min(10,v1)) n=n+v1+3 elseif(kind==v_is_basic) then @@ -5911,18 +5525,18 @@ subroutine dump_single_cvar(context,iunit,n,array) if(iand(v2,v_is_array_par_vect)==0) then write(iunit,'(i6,1x,a5,1x,a,1x,i6,a,1x,a)') n,v_names(kind),& trim(pm_name_as_string(context,v1)),& - typ,trim(pm_typ_as_string(context,typ)),flag_str + typ,trim(pm_type_as_string(context,typ)),flag_str else write(iunit,'(i6,1x,a5,1x,a,1x,i6,a,1x,a)') n,v_names(kind),& - trim(pm_typ_as_string(context,v1)),& - typ,trim(pm_typ_as_string(context,typ)),flag_str + trim(pm_type_as_string(context,v1)),& + typ,trim(pm_type_as_string(context,typ)),flag_str endif n=n+3 elseif(kind==0) then n=n+1 else write(iunit,'(i6,1x,a5,i6,i6,1x,a)') n,v_names(kind),& - v1,v2,trim(pm_typ_as_string(context,typ)) + v1,v2,trim(pm_type_as_string(context,typ)) n=n+3 endif end subroutine dump_single_cvar @@ -5951,7 +5565,7 @@ subroutine wcode_error(wcd,node,mess) if(pm_main_process) then call pm_error_header(wcd%context,cnode_get_name(node,cnode_modl_name),& cnode_get_name(node,cnode_lineno),cnode_get_name(node,cnode_charno)) - write(*,'(A,A)') trim(pm_opts%error),trim(mess) + write(*,'(A,X,A)') trim(pm_opts%error),trim(mess) endif wcd%num_errors=wcd%num_errors+1 if(wcd%num_errors>max_wcode_errors) then