@@ -2559,39 +2559,63 @@ class CommonVisitor : public AST::BaseVisitor<Struct> {
2559
2559
2560
2560
#define fill_shape_and_lower_bound_for_CPtrToPointer () ASR::dimension_t * target_dims = nullptr ; \
2561
2561
int target_n_dims = ASRUtils::extract_dimensions_from_ttype(target_type, target_dims); \
2562
- ASR::expr_t * target_shape = nullptr ; \
2563
2562
ASR::expr_t * lower_bounds = nullptr ; \
2564
2563
if ( target_n_dims > 0 ) { \
2565
- Vec<ASR::expr_t *> sizes, lbs; \
2566
- sizes.reserve (al, target_n_dims); \
2564
+ ASR::dimension_t * alloc_asr_type_dims = nullptr ; \
2565
+ int alloc_asr_type_n_dims = ASRUtils::extract_dimensions_from_ttype ( \
2566
+ asr_alloc_type, alloc_asr_type_dims); \
2567
+ for ( int i = 0 ; i < alloc_asr_type_n_dims; i++ ) { \
2568
+ if ( alloc_asr_type_dims[i].m_length != nullptr || \
2569
+ alloc_asr_type_dims[i].m_start != nullptr ) { \
2570
+ throw SemanticError (" Target type specified in " \
2571
+ " c_p_pointer must have deferred shape." , \
2572
+ loc); \
2573
+ } \
2574
+ } \
2575
+ if ( target_shape == nullptr ) { \
2576
+ throw SemanticError (" shape argument not specified in c_f_pointer " \
2577
+ " even though pptr is an array." , \
2578
+ loc); \
2579
+ } \
2580
+ int shape_rank = ASRUtils::extract_n_dims_from_ttype ( \
2581
+ ASRUtils::expr_type (target_shape)); \
2582
+ if ( shape_rank != 1 ) { \
2583
+ throw SemanticError (" shape array passed to c_p_pointer " \
2584
+ " must be of rank 1 but given rank is " + \
2585
+ std::to_string (shape_rank), loc); \
2586
+ } \
2587
+ Vec<ASR::expr_t *> lbs; \
2567
2588
lbs.reserve (al, target_n_dims); \
2568
- bool success = true ; \
2569
2589
for ( int i = 0 ; i < target_n_dims; i++ ) { \
2570
- if ( target_dims->m_length == nullptr ) { \
2571
- success = false ; \
2572
- break ; \
2573
- } \
2574
- sizes.push_back (al, target_dims->m_length ); \
2575
2590
lbs.push_back (al, ASRUtils::EXPR (ASR::make_IntegerConstant_t ( \
2576
2591
al, loc, 0 , ASRUtils::TYPE ( \
2577
2592
ASR::make_Integer_t (al, loc, 4 ))))); \
2578
2593
} \
2579
- if ( success ) { \
2580
- target_shape = ASRUtils::EXPR (ASR::make_ArrayConstant_t (al, \
2581
- loc, sizes.p , sizes.size (), ASRUtils::expr_type (target_dims[0 ].m_length ), \
2582
- ASR::arraystorageType::RowMajor)); \
2583
- lower_bounds = ASRUtils::EXPR (ASR::make_ArrayConstant_t (al, \
2584
- loc, lbs.p , lbs.size (), ASRUtils::expr_type (lbs[0 ]), \
2585
- ASR::arraystorageType::RowMajor)); \
2586
- } \
2594
+ Vec<ASR::dimension_t > dims; \
2595
+ dims.reserve (al, 1 ); \
2596
+ ASR::dimension_t dim; \
2597
+ dim.loc = loc; \
2598
+ dim.m_length = nullptr ; \
2599
+ dim.m_start = nullptr ; \
2600
+ dims.push_back (al, dim); \
2601
+ ASR::ttype_t * type = ASRUtils::make_Array_t_util (al, loc, \
2602
+ ASRUtils::expr_type (lbs[0 ]), dims.p , dims.size ()); \
2603
+ lower_bounds = ASRUtils::EXPR (ASR::make_ArrayConstant_t (al, \
2604
+ loc, lbs.p , lbs.size (), type, \
2605
+ ASR::arraystorageType::RowMajor)); \
2587
2606
} \
2588
2607
2589
2608
ASR::asr_t * create_CPtrToPointerFromArgs (AST::expr_t * ast_cptr, AST::expr_t * ast_pptr,
2590
- AST::expr_t * ast_type_expr, const Location& loc) {
2609
+ AST::expr_t * ast_type_expr, AST:: expr_t * ast_target_shape, const Location& loc) {
2591
2610
this ->visit_expr (*ast_cptr);
2592
2611
ASR::expr_t * cptr = ASRUtils::EXPR (tmp);
2593
2612
this ->visit_expr (*ast_pptr);
2594
2613
ASR::expr_t * pptr = ASRUtils::EXPR (tmp);
2614
+ ASR::expr_t * target_shape = nullptr ;
2615
+ if ( ast_target_shape ) {
2616
+ this ->visit_expr (*ast_target_shape);
2617
+ target_shape = ASRUtils::EXPR (tmp);
2618
+ }
2595
2619
bool is_allocatable = false ;
2596
2620
ASR::ttype_t * asr_alloc_type = ast_expr_to_asr_type (ast_type_expr->base .loc , *ast_type_expr, is_allocatable);
2597
2621
ASR::ttype_t * target_type = ASRUtils::type_get_past_pointer (ASRUtils::expr_type (pptr));
@@ -2693,8 +2717,13 @@ class CommonVisitor : public AST::BaseVisitor<Struct> {
2693
2717
AST::Call_t* c_p_pointer_call = AST::down_cast<AST::Call_t>(x.m_value );
2694
2718
AST::expr_t * cptr = c_p_pointer_call->m_args [0 ];
2695
2719
AST::expr_t * pptr = assign_ast_target;
2720
+ AST::expr_t * pptr_shape = nullptr ;
2721
+ if ( c_p_pointer_call->n_args == 3 &&
2722
+ c_p_pointer_call->m_args [2 ] != nullptr ) {
2723
+ pptr_shape = c_p_pointer_call->m_args [2 ];
2724
+ }
2696
2725
tmp = create_CPtrToPointerFromArgs (cptr, pptr, c_p_pointer_call->m_args [1 ],
2697
- x.base .base .loc );
2726
+ pptr_shape, x.base .base .loc );
2698
2727
// if( current_body ) {
2699
2728
// current_body->push_back(al, ASRUtils::STMT(tmp));
2700
2729
// }
@@ -4766,8 +4795,12 @@ class BodyVisitor : public CommonVisitor<BodyVisitor> {
4766
4795
AST::Call_t* c_p_pointer_call = AST::down_cast<AST::Call_t>(x.m_value );
4767
4796
AST::expr_t * cptr = c_p_pointer_call->m_args [0 ];
4768
4797
AST::expr_t * pptr = x.m_targets [0 ];
4798
+ AST::expr_t * target_shape = nullptr ;
4799
+ if ( c_p_pointer_call->n_args == 3 ) {
4800
+ target_shape = c_p_pointer_call->m_args [2 ];
4801
+ }
4769
4802
tmp = create_CPtrToPointerFromArgs (cptr, pptr, c_p_pointer_call->m_args [1 ],
4770
- x.base .base .loc );
4803
+ target_shape, x.base .base .loc );
4771
4804
is_c_p_pointer_call = is_c_p_pointer_call;
4772
4805
return ;
4773
4806
}
@@ -6328,16 +6361,23 @@ class BodyVisitor : public CommonVisitor<BodyVisitor> {
6328
6361
6329
6362
6330
6363
ASR::asr_t * create_CPtrToPointer (const AST::Call_t& x) {
6331
- if ( x.n_args != 2 ) {
6332
- throw SemanticError (" c_p_pointer accepts two positional arguments, "
6333
- " first a variable of c_ptr type and second "
6334
- " the target type of the first variable." ,
6364
+ if ( x.n_args != 2 && x.n_args != 3 ) {
6365
+ throw SemanticError (" c_p_pointer accepts maximum three positional arguments, "
6366
+ " first a variable of c_ptr type, second "
6367
+ " the target type of the first variable and "
6368
+ " third optionally the shape of the target variable "
6369
+ " if target variable is an array" ,
6335
6370
x.base .base .loc );
6336
6371
}
6337
6372
visit_expr (*x.m_args [0 ]);
6338
6373
ASR::expr_t * cptr = ASRUtils::EXPR (tmp);
6339
6374
visit_expr (*x.m_args [1 ]);
6340
6375
ASR::expr_t * pptr = ASRUtils::EXPR (tmp);
6376
+ ASR::expr_t * target_shape = nullptr ;
6377
+ if ( x.n_args == 3 ) {
6378
+ visit_expr (*x.m_args [2 ]);
6379
+ target_shape = ASRUtils::EXPR (tmp);
6380
+ }
6341
6381
bool is_allocatable = false ;
6342
6382
ASR::ttype_t * asr_alloc_type = ast_expr_to_asr_type (x.m_args [1 ]->base .loc , *x.m_args [1 ], is_allocatable);
6343
6383
ASR::ttype_t * target_type = ASRUtils::type_get_past_pointer (ASRUtils::expr_type (pptr));
@@ -7183,8 +7223,9 @@ class BodyVisitor : public CommonVisitor<BodyVisitor> {
7183
7223
return ;
7184
7224
} else if ( call_name == " pointer" ) {
7185
7225
parse_args (x, args);
7186
- ASR::ttype_t *type = ASRUtils::TYPE (ASR::make_Pointer_t (al, x.base .base .loc ,
7187
- ASRUtils::expr_type (args[0 ].m_value )));
7226
+ ASR::ttype_t * type_ = ASRUtils::duplicate_type_with_empty_dims (
7227
+ al, ASRUtils::expr_type (args[0 ].m_value ));
7228
+ ASR::ttype_t *type = ASRUtils::TYPE (ASR::make_Pointer_t (al, x.base .base .loc , type_));
7188
7229
tmp = ASR::make_GetPointer_t (al, x.base .base .loc , args[0 ].m_value , type, nullptr );
7189
7230
return ;
7190
7231
} else if ( call_name == " array" ) {
@@ -7201,6 +7242,14 @@ class BodyVisitor : public CommonVisitor<BodyVisitor> {
7201
7242
ASR::ListConstant_t* list = ASR::down_cast<ASR::ListConstant_t>(arg);
7202
7243
ASR::expr_t **m_args = list->m_args ;
7203
7244
size_t n_args = list->n_args ;
7245
+ Vec<ASR::dimension_t > dims;
7246
+ dims.reserve (al, 1 );
7247
+ ASR::dimension_t dim;
7248
+ dim.loc = x.base .base .loc ;
7249
+ dim.m_length = nullptr ;
7250
+ dim.m_start = nullptr ;
7251
+ dims.push_back (al, dim);
7252
+ type = ASRUtils::make_Array_t_util (al, x.base .base .loc , type, dims.p , dims.size ());
7204
7253
tmp = ASR::make_ArrayConstant_t (al, x.base .base .loc , m_args, n_args, type, ASR::arraystorageType::RowMajor);
7205
7254
} else {
7206
7255
throw SemanticError (" array accepts only list for now, got " +
0 commit comments