Task: Flatten a list

C: #include <stdio.h>
#include <stdlib.h>
#include <string.h>

typedef struct list_t list_t, *list;
struct list_t{
	int is_list, ival; 
	list *lst;
};

list new_list()
{
	list x = malloc(sizeof(list_t));
	x->ival = 0;
	x->is_list = 1;
	x->lst = 0;
	return x;
}

void append(list parent, list child)
{
	parent->lst = realloc(parent->lst, sizeof(list) * (parent->ival + 1));
	parent->lst[parent->ival++] = child;
}

list from_string(char *s, char **e, list parent)
{
	list ret = 0;
	if (!parent) parent = new_list();

	while (*s != '\0') {
		if (*s == ']') {
			if (e) *e = s + 1;
			return parent;
		}
		if (*s == '[') {
			ret = new_list();
			ret->is_list = 1;
			ret->ival = 0;
			append(parent, ret);
			from_string(s + 1, &s, ret);
			continue;
		}
		if (*s >= '0' && *s <= '9') {
			ret = new_list();
			ret->is_list = 0;
			ret->ival = strtol(s, &s, 10);
			append(parent, ret);
			continue;
		}
		s++;
	}

	if (e) *e = s;
	return parent;
}

void show_list(list l)
{
	int i;
	if (!l) return;
	if (!l->is_list) {
		printf("%d", l->ival);
		return;
	}

	printf("[");
	for (i = 0; i < l->ival; i++) {
		show_list(l->lst[i]);
		if (i < l->ival - 1) printf(", ");
	}
	printf("]");
}

list flatten(list from, list to)
{
	int i;
	list t;

	if (!to) to = new_list();
	if (!from->is_list) {
		t = new_list();
		*t = *from;
		append(to, t);
	} else
		for (i = 0; i < from->ival; i++)
			flatten(from->lst[i], to);
	return to;
}

void delete_list(list l)
{
	int i;
	if (!l) return;
	if (l->is_list && l->ival) {
		for (i = 0; i < l->ival; i++)
			delete_list(l->lst[i]);
		free(l->lst);
	}

	free(l);
}

int main()
{
	list l = from_string("[1], 2, [[3,4], 5], [[[]]], [[[6]]], 7, 8, []", 0, 0);

	printf("Nested: ");
	show_list(l);
	printf("\n");

	list flat = flatten(l, 0);
	printf("Flattened: ");
	show_list(flat);

	
	return 0;
}










Fortran: 


module flat
  implicit none

  type n
     integer                             :: a
     type(n), dimension(:), pointer      :: p => null()
     logical                             :: empty = .false.
  end type

contains

  recursive subroutine del(this)
  type(n), intent(inout) :: this
  integer                :: i
  if (associated(this%p)) then
    do i = 1, size(this%p)
       call del(this%p(i))
    end do
  end if
  end subroutine

  function join(xs) result (r)
  type(n), dimension(:), target :: xs
  type(n)                       :: r
  integer                       :: i
  if (size(xs)>0) then
    allocate(r%p(size(xs)), source=xs)
    do i = 1, size(xs)
      r%p(i) = xs(i)
    end do
  else
    r%empty = .true.
  end if
  end function

  recursive subroutine flatten1(x,r) 
  integer, dimension (:), allocatable, intent(inout) :: r
  type(n), intent(in)                                :: x
  integer, dimension (:), allocatable                :: tmp
  integer                                            :: i
  if (associated(x%p)) then
    do i = 1, size(x%p)
      call flatten1(x%p(i), r)
    end do
  elseif (.not. x%empty) then
    allocate(tmp(size(r)+1))
    tmp(1:size(r)) = r
    tmp(size(r)+1) = x%a
    call move_alloc(tmp, r)
  end if
  end subroutine

  function flatten(x) result (r)
  type(n), intent(in)                                :: x
  integer, dimension(:), allocatable                 :: r
  allocate(r(0))
  call flatten1(x,r)
  end function

  recursive subroutine show(x)
  type(n)   :: x
  integer   :: i
  if (x%empty) then 
    write (*, "(a)", advance="no") "[]"
  elseif (associated(x%p)) then
    write (*, "(a)", advance="no") "["
    do i = 1, size(x%p)
      call show(x%p(i))
      if (i<size(x%p)) then
        write (*, "(a)", advance="no") ", "
      end if
    end do
    write (*, "(a)", advance="no") "]"
  else
    write (*, "(g0)", advance="no") x%a
  end if
  end subroutine

  function fromString(line) result (r)
  character(len=*)                      :: line
  type (n)                              :: r
  type (n), dimension(:), allocatable   :: buffer, buffer1
  integer, dimension(:), allocatable    :: stack, stack1
  integer                               :: sp,i0,i,j, a, cur, start
  character                             :: c
 
  if (.not. allocated(buffer)) then
    allocate (buffer(5)) 
  end if
  if (.not. allocated(stack)) then
    allocate (stack(5))
  end if

  sp = 1; cur = 1; i = 1
  do
    if ( i > len_trim(line) ) exit
    c = line(i:i)
    if (c=="[") then
      if (sp>size(stack)) then 
        allocate(stack1(2*size(stack)))
        stack1(1:size(stack)) = stack
        call move_alloc(stack1, stack)
      end if
      stack(sp) = cur;  sp = sp + 1; i = i+1
    elseif (c=="]") then
      sp = sp - 1; start = stack(sp)
      r = join(buffer(start:cur-1))
      do j = start, cur-1
        call del(buffer(j))
      end do
      buffer(start) = r; cur = start+1; i = i+1
    elseif (index(" ,",c)>0) then
      i = i + 1; continue
    elseif (index("-123456789",c)>0) then
      i0 = i
      do 
        if ((i>len_trim(line)).or. &
            index("1234567890",line(i:i))==0) then
          read(line(i0:i-1),*) a
          if (cur>size(buffer)) then
            allocate(buffer1(2*size(buffer)))
            buffer1(1:size(buffer)) = buffer
            call move_alloc(buffer1, buffer)
          end if
          buffer(cur) = n(a); cur = cur + 1; exit
        else
          i = i+1
        end if
      end do
    else
       stop "input corrupted"
    end if
  end do
  end function
end module

program main
  use flat
  type (n)  :: x
  x = fromString("[[1], 2, [[3,4], 5], [[[]]], [[[6]]], 7, 8, []]")
  write(*, "(a)", advance="no") "input   : "
  call show(x)
  print *
  write (*,"(a)", advance="no") "flatten : ["
  write (*, "(*(i0,:,:', '))", advance="no") flatten(x)
  print *, "]"
end program