#
# The core built-ins for Perl 6.
#
# Written in 2002 by Aaron Sherman <ajs@ajs.com>
# This file can be distributed/modified under the same terms as Perl itself..

module CORE;

# So how are we doing export? I'll look up the Exegeses later....
# export:
# 	acos alarm asin atan2 bless caller chdir chmod chomp chomp
# 	chomp chop chop chop chown chr chroot cos cos crypt dbmclose
# 	dbmopen dump endgrent endhostent endnetent endprotoent
# 	endpwent endservent eval exec exp fork format formline
# 	getgrent getgrgid getgrnam gethostbyaddr gethostbyname
# 	gethostent getlogin getnetbyaddr getnetbyname getnetent
# 	getpgrp getppid getpriority getprotobyname getprotobynumber
# 	getprotoent getpwent getpwnam getpwuid getservbyname
# 	getservbyport getservent glob gmtime grep hex index int join
# 	kill lc lcfirst length link local localtime log log10 lstat
# 	map mkdir msgctl msgget msgrcv msgsnd oct open opendir ord
# 	pack pipe pop pos printf prototype push quotemeta rand read
# 	readlink readpipe ref rename reset reverse reverse rindex
# 	rmdir scalar select select select semctl semget semop setgrent
# 	sethostent setnetent setpgrp setpriority setprotoent setpwent
# 	setservent shift shmctl shmget shmread shmwrite sin sleep sort
# 	sort sort splice split split sprintf sqrt srand stat study
# 	symlink syscall system tan times truncate uc ucfirst umask
# 	umask unlink unpack unshift untie utime utime vec wait waitpid
# 	warn write

# XXX - This marker is used all over to indicate potential problems and
#	quesitons about how Perl 6 works.
#
# XXX High-level questions:
#
# When declaring:
#  sub foo($a, $b) {...}
# and
#  sub foo($a, *@rest) { ... }
# What is the correct order, and/or is this even valid? I need to know,
# given the way I did sort and reverse in order to handle exploded
# argument lists and arrays efficiently.
#
# Generally need to know how the interface ot libc will work, so
# that all of this junk can be implemented.
#
# Do I need to "@array is rw"? I would think not....
#
# Need to nail down when I should not be using "*@array", e.g. return?

# Some internal only markers for various sorts of unimplemented functionality
sub UNIMP($func) { die "Unimplemented: $func" }
sub LIBC($func,*@args) { die "Unimplemented call to external code: $func" }
sub NEVER($func) { die "Obsolete in Perl 6: $func" }

############# Internal/IMC
# Functions that are implemented in IMC and/or the parser directly
# INTERNAL abs
# INTERNAL defined
# INTERNAL delete
# INTERNAL die
# INTERNAL do
# INTERNAL each
# INTERNAL eval(string)
# INTERNAL exists
# INTERNAL exit
# INTERNAL goto
# INTERNAL keys
# INTERNAL last
# INTERNAL lock
# INTERNAL m
# INTERNAL my
# INTERNAL next
# INTERNAL no
# INTERNAL our
# INTERNAL package
# INTERNAL print
# INTERNAL q, qq, qw
# XXX - how do I do quote-like operators? I know I saw someone say...
# Need to do: qr (NEVER("qr")) and qx
# INTERNAL redo
# INTERNAL return
# INTERNAL s
# INTERNAL sleep
# INTERNAL sub
# INTERNAL substr
# INTERNAL time
# INTERNAL undef
# INTERNAL use
# INTERNAL values
# INTERNAL wantarray
# INTERNAL y

############# Math
# Mathematical functions and functions and conversions
sub atan2(real $y, real $x) { return LIBC("atan2",$y,$x) }
sub cos(real $num //= $_) { return LIBC("cos",$num) }
sub cos(real $num //= $_) { return LIBC("cos",$num) }
sub exp(real $num //= $_) { return LIBC("exp",$num) }
sub log(real $num //= $_) { return LIBC("log",$num) }
sub sin(real $num //= $_) { return LIBC("sin",$num) }
sub sqrt(real $num //= $_) { return LIBC("sqrt",$num) }
# From perlfunc
sub acos(real $num //= $_) { atan2( sqrt(1 - ($num * $num)), $num ) }
sub tan(real $num //= $_) { return sin($num) / cos($num)  }
sub log10(real $num //= $_) { return log($num)/log(10) }
sub asin(real $num //= $_) { atan2($num, sqrt(1 - $num * $num)) }
# Conversions
sub int(int $num //= $_) { $num }
sub hex($string //= $_) {
	my($tmp) = ($string =~ /^[0x]?(<[a-fA-F0-9]>+)/);
	return 0 unless defined($hex) && $hex.length;
	my $bit = 0;
	my $result = 0;
	for(my $i = $tmp.length-1;$i>=0;$i--) {
		my $n = substr($tmp,$i,1);
		given $n {
		    when 'a' .. 'f', 'A' .. 'F' {
			$n = ord(lc $n)-ord('a')+10;
		    }
		    when '0' .. '9' {
			$n = +$n;
		    }
		}
		$result += $n * (16**$bit++);
	}
	return $tmp;
}
sub oct($string //= $_) {
	given $string {
	    # XXX - handle "0b"
	    when /^0x/ {
		return hex($string);
	    }
	    default {
		my $return = 0;
		my $bit = 0;
		for(my $i = $tmp.length-1;$i>=0;$i--) {
			my $n = substr($tmp,$i,1);
			# Avoid overflow for leading 0
			$return += $n * (8**$bit++) if $n;
		}
		return $return;
	    }
	}
}
# Randomness
our $done_srand = 0;
sub srand(int $seed //= undef) {
	unless defined $seed {
		# XXX - need urandom code here, requires IO libs
		$seed = (time()<<16) ^ $$;
	}
	LIBC("srand",$seed)
	$done_srand = 1;
}
sub rand(int $num //= 1) {
	srand unless $done_srand;
	return LIBC("rand",$num)
}
# Bits
sub vec($bitvec,int $off,int $bits) is rw { UNIMP("vec") }

############# Strings
# Functions that work on strings in various ways
sub chr(int $num //= $_){ return pack 'C', $num } # XXX Not UNICODE
sub ord($char //= $_) { return unpack 'C', $char }
sub chomp($string is rw){
	my $irs = ${"/"}; # XXX What is $/ now?
	if defined $irs {
		if $irs.isa(Object) {
			return undef;
		} elsif $irs.length == 0 {
			$string =~ s/ \n+ $ //;
			return $0;
		} else {
			$string =~ s/<{"<[$irs]>"}>+$//;
			return $0;
		}
	}
}
sub chomp() { UNIMP("chomp(LIST)") }
sub chomp(*@strings is rw) { UNIMP("chomp(LIST)") }
sub chop($string is rw) { UNIMP("chop") }
sub chop() { UNIMP("chop") }
sub chop(*@strings) { UNIMP("chop") }
sub crypt($plaintext, $salt) { return LIBC("crypt",$plaintext,$salt) }
sub index($string, $substr, int $pos //= 0) {
	# XXX - slow dumb way... need to break out Knuth
	my $sl = $substr.length;
	for(my $i = $pos; $i+$sl <= $string.length; $i++) {
		return $i if substr($string,$i,$sl) eq $substr;
	}
	return -1;
}
sub rindex($string, $substr, $pos //= 0) {
	# XXX - slow dumb way
	my $sl = $substr.length;
	for(my $i = $string.length-$sl; $i >= $pos; $i--) {
		return $i if substr($string,$i,$sl) eq $substr;
	}
	return -1;
}	
sub lc($string //= $_) { $string =~ tr/A-Z/a-z/; } # XXX NOT UNICODE
sub lcfirst($string //= $_) {
	given $string.length {
		0 { return '' }
		1 { return lc $string }
		default { return lc(substr($string,0,1)) _ substr($string,1) }
	}
}
sub uc($string //= $_) { $string =~ tr/a-z/A-Z/; } # XXX NOT UNICODE
sub ucfirst($string //= $_) {
	given $string.length {
		0 { return '' }
		1 { return uc $string }
		default { return uc(substr($string,0,1)) _ substr($string,1) }
	}
}
sub length($string //= $_) { return $string.length }
sub pack($template,*@args) { UNIMP("pack") }
sub unpack($template,$value) { UNIMP("unpack") }
sub quotemeta($string //= $_) {
	$string =~ s:each/(\W)/\\$1/;
	return $string
}
sub scalar($value) { return $value }
sub split(rx $pat,$string //= $_, $limit //= undef) {
	# XXX - split may just fall out of regex syntax.. more thought needed
	UNIMP("split");
}
# For split() and split('a',...)
sub split($match //= undef, $string //= $_, $limit //= undef) {
	$match = (defined($match) ?? rx/$match/ :: rx/\s+/);
	return split $match, $string, $limit;
}
sub sprintf($format, *@list) {
	given $format {
		''	{ return $format }
		'%s'	{ return @list[0] _ '' }
	}
	UNIMP("sprintf"); # This should probably be done in C
}
sub printf($format, *@list) { print(sprintf($format, *@list)) }

############# Lists
# List management functions
sub map(&code, *@list) {
	my @result;
	for @list -> $_ {
		push @result, code($_);
	}
	return @result;
}
sub grep(&code, *@list) {
	my @newlist;
	for @list -> $_ {
		push @newlist, $_ if code($_);
	}
	return @newlist;
}
sub join($sep, *@list) {
	return '' unless @list.length;
	my $result = @list[0];
	my $len = @list.length;
	for(my $i=1;$i <= $len;$i++) {
		$result _= $sep _ @list[$i];
	}
	return $result;
}
sub pop(@list) {
	return undef if @list.length == 0;
	return delete @list[@list.length - 1];
}
sub push(@array,*@list) {
	for @list -> $_ {
		@array[@array.length] = $_;
	}
}
sub reverse(@list) {
	my @r;
	my $last = @list.length - 1;
	for(my $i=$last;$i >= 0;$i++) {
		@r[$last-$i] = @list[$i];
	}
	return *@r;
}
sub reverse(*@list) { return reverse @list }
sub shift(@list) {
	return undef if @list.length == 0;
	return delete @list[@list.length-1];
}
sub sort(&code, @list) { UNIMP("sort") }
sub sort(&code, *@list) { return sort &code, @list } # XXX syntax?
sub sort(*@list) { return sort sub($a,$b){$a cmp $b}, @list }
sub splice(@array,int $off //= 0,int $len //= undef, *@list) {
	# XXX - A9 is supposed to tell us how slicing operators work....
	if !defined($len) || $len > (@array.length-$off) {
		$len = @array.length-$off;
	}
	# XXX - Too tired to type -ajs
	UNIMP("splice");
	# return @old;
}
sub unshift(@array is rw,*@list) { @array = (*@list, *@array) }

############# Misc
# Mostly libc/POSIX functions that may get moved out to a CORE::POSIX
# at some point
sub alarm(int $seconds){ return LIBC("alarm",$seconds) }
sub caller($expr //= undef){ UNIMP("caller") }
sub chdir($path //= %ENV{HOME}){ return LIBC("chdir",$path) }
sub chmod(int $mode, *@paths){
	my int $return = 0;
	for @paths -> $_ {
		$return++ if LIBC("chmod",$_,$mode)
	}
	return $return;
}
sub chown(int $uid, int $gid, *@files) {
	my int $return;
	for @files -> $_ {
		$return++ if LIBC("chown",$_,$uid,$gid);
	}
	return $return;
}
sub chroot($path //= $_){ return LIBC("chroot",$path) }
# XXX what about the "exec $prog $argv0, $argv1..." form?
sub exec($program, *@args) {
	# XXX Probably more to be done here... probably need Parrot support
	LIBC("exec",$program, *@args)
}
sub fork() {
	# XXX Probably more to be done here... probably need Parrot support
	return LIBC("fork");
}
sub getlogin() { return LIBC("getlogin") }
sub getpgrp(int $pid) { return LIBC("getpgrp",$pid) }
sub getppid() { return LIBC("getppid") }
sub getpriority(int $which, int $who) { return LIBC("getpriority",$which,$who) }
# XXX - Many of these functions need a special scalar context behavior,
#	and/or have a complex return value
sub getpwnam($name) { return LIBC("getpwnam",$name) }
sub getgrnam($name) { return LIBC("getgrnam",$name) }
sub gethostbyname($name) { return LIBC("gethostbyname",$name) }
sub getnetbyname($name) { return LIBC("getnetbyname",$name) }
sub getprotobyname($name) { return LIBC("getprotobyname",$name) }
sub getpwuid(int $uid) { return LIBC("getpwuid",$uid) }
sub getgrgid(int $gid) { return LIBC("getgrgid",$gid) }
sub getservbyname($name, $proto) { return LIBC("getservbyname",$name,$proto) }
sub gethostbyaddr($addr, $addrtype) { return LIBC("gethostbyaddr",$addr,$addrtype) }
sub getnetbyaddr($addr, $addrtype) { return LIBC("getnetbyaddr",$addr,$addrtype) }
sub getprotobynumber(int $number) { return LIBC("getprotobynumber",$number) }
sub getservbyport(int $port, $proto) { return LIBC("getservbyport",$port,$proto) }
sub getpwent() { return LIBC("getpwent") }
sub getgrent() { return LIBC("getgrent") }
sub gethostent() { return LIBC("gethostent") }
sub getnetent() { return LIBC("getnetent") }
sub getprotoent() { return LIBC("getprotoent") }
sub getservent() { return LIBC("getservent") }
sub setpwent() { return LIBC("setpwent") }
sub setgrent() { return LIBC("setgrent") }
sub sethostent(bool $stayopen) { return LIBC("sethostent",$stayopen) }
sub setnetent(bool $stayopen) { return LIBC("setnetent",$stayopen) }
sub setprotoent(bool $stayopen) { return LIBC("setprotoent",$stayopen) }
sub setservent(bool $stayopen) { return LIBC("setservent",$stayopen) }
sub endpwent() { return LIBC("endpwent") }
sub endgrent() { return LIBC("endgrent") }
sub endhostent() { return LIBC("endhostent") }
sub endnetent() { return LIBC("endnetent") }
sub endprotoent() { return LIBC("endprotoent") }
sub endservent() { return LIBC("endservent") }
sub glob($string //= $_) { UNIMP("glob") }
sub gmtime(real $unixtime) { return LIBC("gmtime",$unixtime) }
sub kill($signal, *@procs) {
	# XXX - Need string->signum conversion
	#       Relies on Perl 6's configure process...
	my $return = 0;
	for @procs -> $_ {
		$return++ if LIBC("kill",$_,$signal);
	}
	return $return;
}
sub link($oldfile,$newfile) { return LIBC("link",$oldfile,$newfile) }
sub localtime($thetime //= time()) { return LIBC("localtime",$thetime) }
sub lstat($path //= $_) { return LIBC("lstat",$path) }
sub mkdir($file, int $mask //= 0777) { return LIBC("mkdir",$file,$mask) }
sub msgctl($id,$cmd,$arg) { return LIBC("msgctl",$id,$cmd,$arg) }
sub msgget($key,$flags) { return LIBC("msgget",$key,$flags) }
sub msgrcv($id,$var,$size,$type,$flags) { return LIBC("msgrcv",$id,$var,$size,$type,$flags) }
sub msgsnd($id,$msg,$flags) { return LIBC("msgsnd",$id,$msg,$flags) }
sub open($fh is rw, $pathspec) { UNIMP("open") }
sub open($fh is rw, $path, $mode) { UNIMP("open") }
sub prototype($function) { UNIMP("prototype") }
sub readlink($path //= $_) { return LIBC("readlink",$path) }
sub readpipe($command) { UNIMP("readpipe") }
sub rename($oldname,$newname) { return LIBC("rename",$oldname,$newname) }
sub rmdir($path //= $_) { return LIBC("rmdir",$path) }
sub select($fh) { UNIMP("select") }
sub select() { UNIMP("select") }
sub select($rbits,$wbits,$ebits,real $timeout) { UNIMP("select") }
sub semctl($id,$semnum,$cmd,$arg) { return LIBC("semctl",$id,$semnum,$cmd,$arg) }
sub semget($key,$nsems,$flags) { return LIBC("semget",$key,$nsems,$flags) }
sub semop($key,$opstring) { return LIBC("semop",$key,$opstring) }
sub setpgrp($pid,$pgrp) { return LIBC("setpgrp",$pid,$pgrp) }
sub setpriority($which,$who,$priority) { return LIBC("setpriority",$which,$who,$priority) }
sub shmctl($id,$cmd,$arg) { return LIBC("shmctl",$id,$cmd,$arg) }
sub shmget($key,$size,$flags) { return LIBC("shmget",$key,$size,$flags) }
sub shmread($id,$var,$pos,$size) { return LIBC("shmread",$id,$var,$pos,$size) }
sub shmwrite($id,$string,$pos,$size) { return LIBC("shmwrite",$id,$string,$pos,$size) }
sub sleep() { UNIMP("sleep") } # Never wake up
sub stat($path //= $_) { return LIBC("stat",$path) }
sub symlink($oldfile,$newfile) { return LIBC("symlink",$oldfile,$newfile) }
sub syscall(*@list) { UNIMP("syscall") }
# XXX system($program @list)
sub system(*@list) { UNIMP("system") }
# XXX tie, tied??
sub times() { return LIBC("times") }
# XXX tr??
sub truncate($path,int $len) { return LIBC("truncate",$path,$len) }
sub umask(int $newmask) { return LIBC("umask",$newmask) }
sub umask() {
	my int $tmp = umask(0);
	umask($tmp);
	return $tmp;
}
sub unlink($path //= $_) { return LIBC("unlink",$path) }
sub untie($var) { UNIMP("untie") }
sub utime($atime, $mtime, @paths) {
	my $return = 0;
	for @paths -> $_ {
		$return++ if LIBC("utime",$_,[$atime, $mtime]);
	}
	return $return;
}
sub wait() { return LIBC("wait") }
sub waitpid(int $pid,int $flags) { return LIBC("waitpid",$pid,$flags) }
sub warn(*@list) { UNIMP("warn") }

############# Depricated
# XXX Need to confirm, but these probably will not be in Perl 6
sub bless($ref, $name //= undef){ NEVER("bless") }
sub dbmclose(%hash) { NEVER("dbmclose") }
sub dbmopen(%hash, $dbname, $mask) { NEVER("dbmopen") }
sub dump($label //= $_) { NEVER("dump") }
sub eval(&code) {
	warn "Perl 6 uses try for blocks";
	return try(code());
}
sub format() { NEVER("format") }
sub formline($picture, *@list) { NEVER("formline") }
sub local($var) { NEVER("local") }
sub opendir(*@args) { NEVER("opendir") }
sub pipe($readhandle,$writehandle) { NEVER("pipe") }
sub pos($scalar //= $_) { NEVER("pos") } # pos is now a method on $0
sub ref($scalar //= $_) { UNIMP("ref") }
sub reset($tmp //= $_) { NEVER("reset") }
sub study($scalar //= $_) { NEVER("study") }
sub write() { NEVER("write") }

############# IO
# IO::... stuff to be moved out into IO classes:

# sub accept(IO::Socket $new, IO::Socket $gen){ UNIMP("accept") }
# sub bind(IO::Socket $socket, $name) { UNIMP("bind") }
# sub binmode(IO::Handle $fh, $disc //= ':raw'){ UNIMP("binmode") }
# sub close(IO::Handle $fh //= "XXX_defaulthandle") { UNIMP("close") }
# sub closedir(IO::DirHandle $dh) { UNIMP("closedir") }
# sub connect(IO::Socket $socket, $name) { UNIMP("connect") }
# sub eof(IO::Handle $fh //= "XXX_defaulthandle") { UNIMP("eof") }
# sub fcntl(IO::Handle $fh, $func, $scalar) { UNIMP("fcntl") }
# sub fileno(IO::Handle $fh //= "XXX_defaulthandle") { UNIMP(fileno) }
# sub flock(IO::Handle $fh, $operation) { UNIMP("flock") }
# sub getc(IO::Handle $fh //= "XXX_defaulthandle") { UNIMP("getc") }
# sub getpeername(IO::Socket $socket) { UNIMP("getpeername") }
# sub getsockname(IO::Socket $socket) { UNIMP("getsockname") }
# sub getsockopt(IO::Socket $socket,$level,$optname) { UNIMP("getsockopt") }
# sub ioctl(IO::Handle $fh,$function,$scalar) { UNIMP("ioctl") }
# sub listen(IO::Socket $socket,$queuesize) { UNIMP("listen") }
# sub lstat(IO::Handle $fh) { UNIMP("lstat") }
# sub readdir(IO::DirHandle $dh) { UNIMP("readdir") }
# sub readline(IO::Handle $fh) { UNIMP("readline") }
# sub recv(IO::Socket $socket,$buf,$len,$flags) { UNIMP("recv") }
# sub rewinddir(IO::DirHandle $dh) { UNIMP("rewinddir") }
# sub seek(IO::Handle $fh,$pos, $whence) { UNIMP("seek") }
# sub seekdir(IO::DirHandle $dh,int $pos) { UNIMP("seekdir") }
# sub send(IO::Socket $socket,$msg,$flags,$to //= undef) { UNIMP("send") }
# sub setsockopt(IO::Socket $socket,$level,$optname,$optval) { UNIMP("setsockopt") }
# sub shutdown(IO::Socket $socket,int $how) { UNIMP("shutdown") }
# sub socket(IO::Socket $socket is rw,$domain,$type,$protocol) { UNIMP("socket") }
# sub socketpair($socket1,$socket2,$domain,$type,$protocol) { NEVER("socketpair") }
# sub sysopen(*@list) { UNIMP("sysopen") }
# sub sysread(*@list) { UNIMP("sysread") }
# sub sysseek(*@list) { UNIMP("sysseek") }
# sub syswrite(*@list) { UNIMP("syswrite") }
# sub tell(IO::Handle $fh //= "XXX_defaulthandle") { UNIMP("tell") }
# sub telldir(IO::DirHandle $dh) { UNIMP("telldir") }
# sub truncate(IO::Handle $fh,$len) { UNIMP("truncate") }