## pervasive.pkg
#
# Global definitions visible in all packages.
#
# This global availability gets implemented (in part) by the
#
# far_imports = REF [ pervasive_far_tome ];
#
# line in analyse() from
#
# src/app/makelib/depend/make-dependency-graph.pkg#
### "We used to think that if we knew one,
### we knew two, because one and one are two.
### We are finding that we must learn a great
### deal more about `and'."
###
### -- Sir Arthur Eddington
###
### Quoted in Mathematical Maxims and Minims
### N Rose (Raleigh N C 1988).
infix my 90 ** ;
infix my 80 * / % div & // ;
infix my 70 $ + - ~ | ^ ? \ ;
infixr my 60 @ . ! << >> >>> in ;
infix my 50 > < >= <= == != =~ .. ;
infix my 40 := o ;
infix my 20 ==> ;
infix my 10 before ;
# base_types is from src/lib/compiler/front/semantic/symbolmapstack/base-types-and-ops-symbolmapstack.pkg # inline_t is from src/lib/core/init/built-in.pkgBool == base_types::Bool; # Top-level type -- we need this one early.
my (o) : ((Y -> Z), (X -> Y)) -> (X -> Z)
= inline_t::compose;
stipulate
package bt = base_types; # base_types is from src/lib/core/init/built-in.pkg package it = inline_t; # inline_t is from src/lib/core/init/built-in.pkg package ps = protostring; # protostring is from src/lib/core/init/protostring.pkg package rt = runtime; # runtime is from src/lib/core/init/built-in.pkg.
fun strcat ("", s) => s;
strcat (s, "") => s;
strcat (x, y) => ps::meld2 (x, y);
end;
# core_two_word_unt is from src/lib/core/init/core-two-word-unt.pkg package ti = it::ti; # "ti" == "tagged_int": 31-bit on 32-bit architectures, 63-bit on 64-bit architectures.
package i1w = it::i1; # "i1w" == "one-word signed int" -- 32-bit on 32-bit architectures, 64-bit on 64-bit architectures.
package u1b = it::u8; # "u1b" == "one-byte unsigned int".
package tu = it::tu; # "tu" == "tagged_unt": 31-bit on 32-bit architectures, 63-bit on 64-bit architectures.
package u1w = it::u1; # "u1w" == "one-word unsigned int" -- 32-bit on 32-bit architectures, 64-bit on 64-bit architectures.
package mwi = core_multiword_int;
package u2w = core_two_word_unt; # "u2w" == "two-word unsigned int" -- 64-bit on 32-bit architectures, 128-bit on 64-bit architectures.
package i2w = core_two_word_int; # "i22" == "two-word signed int" -- 64-bit on 32-bit architectures, 128-bit on 64-bit architectures.
package f8b = it::f64; # "f8b" == "eight-byte float".
package cv = it::vector_of_chars;
package pv = it::poly_vector;
package di = it::default_int;
fun unt08adapt op args
=
u1b::bitwise_and (op args, 0uxFF);
unt08plus = unt08adapt u1b::(+);
unt08minus = unt08adapt u1b::(-);
unt08times = unt08adapt u1b::(*);
unt08neg = unt08adapt u1b::neg;
unt08lshift = unt08adapt u1b::lshift;
unt08rshift = unt08adapt u1b::rshift;
unt08rshiftl = unt08adapt u1b::rshiftl;
unt08bitwise_or = unt08adapt u1b::bitwise_or; # XXX BUGGO FIXME Do we need to do 'unt08adapt' here?
unt08bitwise_xor = unt08adapt u1b::bitwise_xor; # XXX BUGGO FIXME Do we need to do 'unt08adapt' here?
fun stringlt (a, b)
=
compare 0
where
al = cv::length a;
bl = cv::length b;
ashort = (di::(<)) (al, bl);
n = if ashort al; else bl;fi;
fun compare i
=
if ((it::(==)) (i, n))
ashort;
else
ai = cv::get (a, i);
bi = cv::get (b, i);
it::char::(<) (ai, bi) or
(it::(==) (ai, bi) and compare (di::(+) (i, 1)));
fi;
end;
fun stringle (a, b) = if (stringlt (b, a) ) FALSE; else TRUE;fi;
fun stringgt (a, b) = stringlt (b, a);
fun stringge (a, b) = stringle (b, a);
herein
#########################################################
# WARNING:
# Order is significant here, in that when in doubt
#
# src/lib/compiler/front/typer/types/resolve-overloaded-variables.pkg #
# will default to the first entry in the list.
#########################################################
# overload (_[]) : ((X, Int) -> Y)
# as string::get;
# overload (_!) : (X -> X)
# as ti::(_!)
# also i1w::(_!)
# also i2w::(_!)
# also mwi::(_!);
# overload (_!) : (X -> X) as ti::(_!) also i1w::(_!) also i2w::(_!) also mwi::(_!);
overloaded my (-_) : (X -> X) # These (X -> X) etc type declarations are probably a mistake -- see Note [1].
=
( ti::neg,
i1w::neg,
i2w::neg,
mwi::neg,
tu::neg,
u1w::neg,
u2w::neg,
f8b::neg,
unt08neg
);
overloaded my (~_) : (X -> X)
=
( ti::bitwise_not,
# i1w::bitwise_not,
# i2w::bitwise_not,
# mwi::bitwise_not,
tu::bitwise_not,
u1w::bitwise_not,
# u2w::bitwise_not,
u1b::bitwise_not
);
overloaded my << : ((X, Y) -> X)
=
( ti::lshift,
i1w::lshift,
# i2w::lshift,
# mwi::lshift,
tu::lshift,
u1w::lshift,
# u2w::lshift,
unt08lshift
);
overloaded my >> : ((X, Y) -> X)
=
(
ti::rshift,
i1w::rshift,
# i2w::rshift,
# mwi::rshift,
tu::rshift,
u1w::rshift,
# u2w::rshift,
unt08rshift
);
overloaded my >>> : ((X, Y) -> X)
=
(
# ti::rshiftl,
# i1w::rshiftl,
# i2w::rshiftl,
# mwi::rshiftl,
tu::rshiftl,
u1w::rshiftl,
# u2w::rshiftl,
unt08rshiftl
);
overloaded my + : ((X, X) -> X)
=
( ti::(+),
i1w::(+),
i2w::(+),
mwi::(+),
tu::(+),
strcat,
u1w::(+),
u2w::(+),
f8b::(+),
unt08plus
);
overloaded my | : ((X, X) -> X)
=
( ti::bitwise_or,
i1w::bitwise_or,
# i2w::bitwise_or,
# mwi::bitwise_or,
tu::bitwise_or,
u1w::bitwise_or,
# u2w::bitwise_or,
unt08bitwise_or
);
overloaded my ^ : ((X, X) -> X)
=
( ti::bitwise_xor,
i1w::bitwise_xor,
# i2w::bitwise_xor,
# mwi::bitwise_xor,
tu::bitwise_xor,
u1w::bitwise_xor,
# u2w::bitwise_xor,
unt08bitwise_xor
);
overloaded my & : ((X, X) -> X)
=
( ti::bitwise_and,
i1w::bitwise_and,
# i2w::bitwise_and,
# mwi::bitwise_and,
tu::bitwise_and,
u1w::bitwise_and,
# u2w::bitwise_and,
u1b::bitwise_and
);
overloaded my - : ((X, X) -> X)
=
( ti::(-),
i1w::(-),
i2w::(-),
mwi::(-),
tu::(-),
u1w::(-),
u2w::(-),
f8b::(-),
unt08minus
);
overloaded my * : ((X, X) -> X)
=
( ti::(*),
i1w::(*),
i2w::(*),
mwi::(*),
tu::(*),
u1w::(*),
u2w::(*),
f8b::(*),
unt08times
);
# Can't overload ** with float and int pow() right now
# because they are not currently defined this early
# in the game. XXX BUGGO FIXME
# overload ** : ((X, X) -> X)
# as math::pow;
(//) = (f8b::(/)); # temporary hack around overloading bug XXX BUGGO FIXME
overloaded my / : ((X, X) -> X)
=
( ti::div,
i1w::div,
i2w::div,
mwi::div,
u1b::div,
tu::div,
u1w::div,
u2w::div
);
# NB: These should probably all do fast round-to-zero division (native on Intel32)
# rather than round-to-negative-infinity division (faked in software on Intel32)
# but I'm not convinced they do -- the code seems not too consistent across
# src/lib/core/init/built-in.pkg # src/lib/compiler/front/semantic/symbolmapstack/base-types-and-ops-symbolmapstack.pkg # src/lib/compiler/back/top/highcode/highcode-baseops.pkg # src/lib/compiler/back/top/nextcode/nextcode-form.pkg # src/lib/compiler/back/low/treecode/treecode-form.api # In particular, the use of 'rem' vs 'mod' seems inconsistent.
# (But perhaps only in unsigned cases where there is no difference...?)
# Anyhow, this may actually be ok, but it needs to be checked out.
# XXX BUGGO FIXME.
overloaded my % : ((X, X) -> X)
=
( ti::mod,
i1w::mod,
i2w::mod,
mwi::mod,
u1b::mod,
tu::mod,
u1w::mod,
u2w::mod
);
# Same comment as above -- XXX BUGGO FIXME.
overloaded my < : ((X, X) -> Bool)
=
( ti::(<),
i1w::(<),
i2w::(<),
mwi::(<),
u1b::(<),
tu::(<),
u1w::(<),
u2w::(<),
f8b::(<),
it::char::(<),
stringlt
);
overloaded my <= : ((X, X) -> Bool)
=
( ti::(<=),
i1w::(<=),
i2w::(<=),
mwi::(<=),
u1b::(<=),
tu::(<=),
u1w::(<=),
u2w::(<=),
f8b::(<=),
it::char::(<=),
stringle
);
overloaded my > : ((X, X) -> Bool)
=
( ti::(>),
i1w::(>),
i2w::(>),
mwi::(>),
u1b::(>),
tu::(>),
u1w::(>),
u2w::(>),
f8b::(>),
it::char::(>),
stringgt
);
overloaded my >= : ((X, X) -> Bool)
=
( ti::(>=),
i1w::(>=),
i2w::(>=),
mwi::(>=),
u1b::(>=),
tu::(>=),
u1w::(>=),
u2w::(>=),
f8b::(>=),
it::char::(>=),
stringge
);
overloaded my abs: (X -> X)
=
( ti::abs,
i1w::abs,
i2w::abs,
mwi::abs,
f8b::abs
);
overloaded my min: ((X, X) -> X)
=
( ti::min,
i1w::min,
# i2w::min,
# mwi::min,
f8b::min
);
overloaded my max: ((X, X) -> X)
=
( ti::max,
i1w::max,
# i2w::min,
# mwi::min,
f8b::max
);
Void = bt::Void;
Exception = bt::Exception;
exception BIND = core::BIND;
exception MATCH = core::MATCH;
exception SUBSCRIPT = core::SUBSCRIPT;
exception INDEX_OUT_OF_BOUNDS = core::INDEX_OUT_OF_BOUNDS; # I want this to replace SUBSCRIPT, but haven't finished that project yet -- obviously! :) -- CrT
exception SIZE = core::SIZE;
exception OVERFLOW = rt::OVERFLOW; # "rt" == "runtime" -- from src/lib/core/init/built-in.pkg exception DIVIDE_BY_ZERO = rt::DIVIDE_BY_ZERO; # "rt" == "runtime" -- from src/lib/core/init/built-in.pkg exception BAD_CHAR = it::char::BAD_CHAR;
exception DOMAIN;
exception NOT_FOUND; # Raised when a regex fails to match given string, and similar search situations.
exception IMPOSSIBLE;
String = bt::String;
exception FAIL String;
# exception SPAN
# enum order
# enum option
# exception Option
# my the_else
# my not_null
# my the
# op ==
# my op !=
include proto_pervasive; # proto_pervasive is from src/lib/core/init/proto-pervasive.pkg Null_Or(X) = Null_Or(X);
(*_) = it::deref;
deref = it::deref; # Synonym, handy when doing 'map' or such.
(:=) = it::(:=);
(before) = it::before : (X, Void) -> X;
ignore = it::ignore : X -> Void;
# Top-level types:
#
List == bt::List;
Ref == bt::Ref;
# Top-level value identifiers:
#
fun vector l
=
{ fun len ([], n) => n;
len ([_], n) => n+1;
len (_ ! _ ! r, n) => len (r, n+2);
end;
n = len (l, 0);
if (di::ltu (core::maximum_vector_length, n)) raise exception SIZE; fi;
if (n == 0) rt::zero_length_vector__global; # "rt" == "runtime" -- from src/lib/core/init/built-in.pkg else rt::asm::make_typeagnostic_ro_vector (n, l); # "rt" == "runtime" -- from src/lib/core/init/built-in.pkg fi;
};
# Bool
not = it::inlnot;
(!_) = not;
fun !*boolref # Just to avoid having to write !(*boolref) all the time.
=
not *boolref;
# Int
Int = bt::Int;
# Unt
Unt = bt::Unt;
# Float
Float = bt::Float;
real = it::f64::from_tagged_int;
fun floor x
=
if ((f8b::(<) (x, 1073741824.0))
and (f8b::(>=) (x, -1073741824.0)))
rt::asm::floor x; # "rt" == "runtime" -- from src/lib/core/init/built-in.pkg elif (f8b::(====) (x, x)) raise exception OVERFLOW; # not a NaN
else raise exception DOMAIN; # NaN
fi;
fun ceil x = (di::(-)) (-1, floor ((f8b::neg) (x + 1.0)));
fun trunc x = if (f8b::(<) (x, 0.0)) ceil x; else floor x;fi;
fun round x = floor (x + 0.5); # Bug: does not round-to-nearest XXX BUGGO FIXME
# List
exception EMPTY;
fun null [] => TRUE;
null _ => FALSE;
end;
fun head (h ! _) => h;
head [] => raise exception EMPTY;
end;
fun tail (_ ! t) => t;
tail [] => raise exception EMPTY;
end;
fun fold_forward f init list # 'f' is function to be applied, 'b' is initial value of result accumulator, 'l' is list to be folded.
=
fold' (list, init)
where
fun fold' ([], results) => results;
fold' (a ! rest, results) => fold' (rest, f (a, results));
end;
end;
fun length l
=
loop (0, l)
where
fun loop (n, []) => n;
loop (n, _ ! l) => loop (n + 1, l);
end;
end;
fun reverse l
=
fold_forward (!) [] l;
fun fold_backward f b # 'f' is function to be applied, 'b' is initial value of result accumulator, list to be folded is 3rd arg (implicit).
=
f2
where
fun f2 [] => b;
f2 (a ! r) => f (a, f2 r);
end;
end;
fun l1 @ l2
=
fold_backward (!) l2 l1;
fun apply f
=
a2
where
fun a2 [] => ();
a2 (h ! t) => { f h: Void;
a2 t;
};
end;
end;
fun apply' list func
=
apply func list;
fun map f
=
m
where
fun m [] => [];
m [a] => [f a];
m [a, b] => [f a, f b];
m [a, b, c] => [f a, f b, f c];
m (a ! b ! c ! d ! r) => f a ! f b ! f c ! f d ! m r;
end;
end;
fun map' list func
=
map func list;
# rw_vector
Array(X) = bt::Rw_Vector(X); # XXX BUGGO DELETEME
Rw_Vector(X) = bt::Rw_Vector(X);
# Vector
Vector(X) = bt::Vector(X);
# Char
Char = bt::Char;
to_int = it::char::ord;
from_int = it::char::chr;
# This doesn't work as-is because the string package isn't defined at this point:
# eq = string::(==);
# ne = string::(!=);
# le = string::(<=);
# ge = string::(>=);
# lt = string::(<);
# gt = string::(>);
#
# to_lower = string::to_lower;
# to_upper = string::to_upper;
# String:
#
stipulate
# Allocate an uninitialized string of given length
#
fun create n
=
{ if (di::ltu (core::maximum_vector_length, n)) raise exception SIZE; fi;
#
rt::asm::make_string n; # "rt" == "runtime" -- from src/lib/core/init/built-in.pkg };
unsafe_get = cv::get;
unsafe_set = cv::set;
herein
size = cv::length: String -> Int;
fun str (c: Char) : String
=
pv::get (ps::chars, it::cast c);
# Concatenate a list of strings together:
fun cat [s]
=>
s;
cat (sl: List( String ))
=>
{ fun length (i, [] ) => i;
length (i, s ! rest) => length (i+size s, rest);
end;
case (length (0, sl))
0 => "";
1 =>
{ fun find ("" ! r) => find r;
find (s ! _) => s;
find _ => "";
end; # * impossible *
find sl;
};
tot_len
=>
{ ss = create tot_len;
fun copy ([], _) => ();
copy (s ! r, i) => {
len = size s;
fun copy' j
=
if (j != len)
unsafe_set (ss, i+j, unsafe_get (s, j));
copy'(j+1);
fi;
copy' 0;
copy (r, i+len);
};
end;
copy (sl, 0);
ss;
};
esac;
};
end; # fun cat
# Implode a list of characters into a string:
fun implode [] => "";
implode cl
=>
ps::implode (length (cl, 0), cl)
where
fun length ([], n) => n;
length (_ ! r, n) => length (r, n+1);
end;
end;
end;
# Explode a string into a list of characters:
fun explode s
=
f (NIL, size s - 1)
where
fun f (l, -1) => l;
f (l, i) => f (unsafe_get (s, i) ! l, i - 1);
end;
end;
# Return the n-character substring of s starting at position i.
# NOTE: we use words to check the right bound so as to avoid
# raising overflow.
stipulate
package w = it::default_unt;
herein
fun substring (s, i, n)
=
if (((i < 0) or
(n < 0) or
(w::(<))(w::from_int (size s), (w::(+))(w::from_int i, w::from_int n)))
)
raise exception core::SUBSCRIPT;
else
ps::unsafe_substring (s, i, n);
fi;
end;
# fun "" $ s => s;
# s $ "" => s;
# x $ y => ps::meld2 (x, y);
# end;
end; # stipulate
# Substring:
#
Substring = substring::Substring;
Substring = substring::Substring;
# I/O:
#
print = print_hook_guts::print;
# Simple interface to redirect interactive
# compiler to read from some stream other
# than the default (stdin):
#
run = read_eval_print_hook::run;
# Getting info about exceptions:
#
exception_name = exception_info_hook::exception_name;
exception_message = exception_info_hook::exception_message;
# Given 1 .. 10, # Compare to 'upto' def in src/lib/compiler/back/low/main/intel32/backend-lowhalf-intel32-g.pkg # return [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 ]
#
fun i .. j
=
make_arithmetic_sequence (i, j, [])
where
fun make_arithmetic_sequence (i, j, result_so_far)
=
i > j ?? result_so_far
:: make_arithmetic_sequence (i, j - 1, j ! result_so_far);
end;
fun foreach [] thunk => ();
foreach (a ! rest) thunk => { thunk(a); foreach rest thunk; };
end;
fun identity i = i;
dotquotes__op = identity; # .'foo'
dotbrokets__op = identity; # .<foo>
dotbarets__op = identity; # .|foo|
dotslashets__op = identity; # ./foo/
dothashets__op = identity; # .#foo#
dotbackticks__op = identity; # .`foo`
backticks__op = fn _ = raise exception FAIL "`foo` op not defined; to define it do backticks__op = somefn;"; # Initialized to 'words' in src/app/makelib/main/makelib-g.pkg dotqquotes__op = fn _ = raise exception FAIL ".\"foo\" op not defined; to define it do dotqquotes__op = somefn;"; # Initialized to 'words' in src/app/makelib/main/makelib-g.pkg # NB: We also have symbols |i| <i> /i/ {i} <i| |i>.
# These are X -> Y.
# They may be set via
# (|_|) = foo;
# (<_>) = foo;
# (/_/) = foo;
# ({_}) = foo;
# (<_|) = foo;
# (|_>) = foo;
#
# I wonder if we shouldn't also have a .[_]: List(X) -> Y syntax.
end; # stipulate
# Note [1]
# ========
#
# First off, the += operator on overloaded types isn't checking these types,
# which is likely a bug. See Hue White listmail circa 2011-05-05.
#
# Secondly, as his example shows, it is reasonable to want to relax the
# (X,X)->X type for * (for example). There's no logical reason why it
# should have to be predeclared; the compiler should be able to scan
# the list and come up with the actual type signature describing the
# currently registered collection. Also, there may be room for optimizing
# the way the type-checker makes use of this information...?
# Here's an odd problem: Any reference to
# typeagnostic equality checking in this file
# triggers an error like
#
# mythryl-runtime-intel32: Fatal error -- unable to find picklehash (compiledfile identifier) '[...]'
#
# For example this stimulus exhibits the problem:
#
# fun x (a,b) = it::(==)(b, a);
#
# but this one does not (presumably the zero allows the
# compiler to produce integer equality test instead of
# typeagnostic one):
#
# fun x (a,b) = it::(==)(0, a);
#
# The simplest stimulus exhibiting the problem is likely:
#
# foo = (!=);
#
# XXX BUGGO FIXME
# Bind package _Core. We use the symbol "xcore", but after parsing
# is done this will be re-written to "_Core" by the bootstrap compilation
# machinery in ROOT/src/app/makelib/compile/compile-in-dependency-order-g.pkg.
# See file init.cmi for more details:
package xcore = core;
## (C) 1999 Lucent Technologies, Bell Laboratories
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2013,
## released per terms of SMLNJ-COPYRIGHT.