This is still a monolith, but it's getting better. It's now stored in
P6C/Builtins/CORE.p6m in my tree. More functions are coded, and I now
differentiate between the functions that need external support (e.g.
POSIX/libc functions) and those that just need to be written (e.g.
sort).
I think I've covered all of the comments (other than breaking up the
file and making it part of the compilation process, which I'll work on
this weekend, and then submit this as a patch to p6i).
Anyone who wants to take a crack at answering any of the questions that
I've marked with "XXX" will be much appreciated. I'm out of town for the
weekend, but will be back and catching up on mail Sunday night.
#
# The core built-ins for Perl 6.
#
# Written in 2002 by Aaron Sherman <[EMAIL PROTECTED]>
# 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") }
